diff options
67 files changed, 3294 insertions, 2357 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 0182139b76..9b21399c48 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -54,12 +54,12 @@ module BasicTypes( StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive, - RuleMatchInfo(..), isConLike, isFunLike, - InlinePragma(..), defaultInlinePragma, isDefaultInlinePragma, + Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive, + RuleMatchInfo(..), isConLike, isFunLike, + InlinePragma(..), defaultInlinePragma, neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, isInlinePragma, inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - InlineSpec(..), defaultInlineSpec, alwaysInlineSpec, neverInlineSpec, SuccessFlag(..), succeeded, failed, successIf ) where @@ -585,10 +585,69 @@ data Activation = NeverActive | ActiveAfter CompilerPhase -- Active in this phase and later deriving( Eq ) -- Eq used in comparing rules in HsDecls -data RuleMatchInfo = ConLike +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike deriving( Eq ) +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_inline :: Bool -- True <=> INLINE, + -- False <=> no pragma at all, or NOINLINE + , inl_act :: Activation -- Says during which phases inlining is allowed + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq ) +\end{code} + +Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = False + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function coreUtils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in Rules.lhs. + +\begin{code} isConLike :: RuleMatchInfo -> Bool isConLike ConLike = True isConLike _ = False @@ -597,55 +656,39 @@ isFunLike :: RuleMatchInfo -> Bool isFunLike FunLike = True isFunLike _ = False -data InlinePragma - = InlinePragma - Activation -- Says during which phases inlining is allowed - RuleMatchInfo -- Should the function be treated like a constructor? - deriving( Eq ) - -defaultInlinePragma :: InlinePragma -defaultInlinePragma = InlinePragma AlwaysActive FunLike +defaultInlinePragma, neverInlinePragma, dfunInlinePragma :: InlinePragma +defaultInlinePragma + = InlinePragma { inl_act = AlwaysActive, inl_rule = FunLike, inl_inline = False } +neverInlinePragma + = InlinePragma { inl_act = NeverActive, inl_rule = FunLike, inl_inline = False } +dfunInlinePragma + = InlinePragma { inl_act = AlwaysActive, inl_rule = ConLike, inl_inline = False } + isDefaultInlinePragma :: InlinePragma -> Bool -isDefaultInlinePragma (InlinePragma activation match_info) - = isAlwaysActive activation && isFunLike match_info +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = not inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = inl_inline prag inlinePragmaActivation :: InlinePragma -> Activation -inlinePragmaActivation (InlinePragma activation _) = activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -inlinePragmaRuleMatchInfo (InlinePragma _ info) = info +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma -setInlinePragmaActivation (InlinePragma _ info) activation - = InlinePragma activation info +setInlinePragmaActivation prag activation = prag { inl_act = activation } setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma -setInlinePragmaRuleMatchInfo (InlinePragma activation _) info - = InlinePragma activation info - -data InlineSpec - = Inline - InlinePragma - Bool -- True <=> INLINE - -- False <=> NOINLINE - deriving( Eq ) - -defaultInlineSpec :: InlineSpec -alwaysInlineSpec, neverInlineSpec :: RuleMatchInfo -> InlineSpec - -defaultInlineSpec = Inline defaultInlinePragma False - -- Inlining is OK, but not forced -alwaysInlineSpec match_info - = Inline (InlinePragma AlwaysActive match_info) True - -- INLINE always -neverInlineSpec match_info - = Inline (InlinePragma NeverActive match_info) False - -- NOINLINE +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } instance Outputable Activation where - ppr NeverActive = ptext (sLit "NEVER") ppr AlwaysActive = ptext (sLit "ALWAYS") + ppr NeverActive = ptext (sLit "NEVER") ppr (ActiveBefore n) = brackets (char '~' <> int n) ppr (ActiveAfter n) = brackets (int n) @@ -654,25 +697,17 @@ instance Outputable RuleMatchInfo where ppr FunLike = ptext (sLit "FUNLIKE") instance Outputable InlinePragma where - ppr (InlinePragma activation FunLike) - = ppr activation - ppr (InlinePragma activation match_info) - = ppr match_info <+> ppr activation - -instance Outputable InlineSpec where - ppr (Inline (InlinePragma act match_info) is_inline) - | is_inline = ptext (sLit "INLINE") - <+> ppr_match_info - <+> case act of - AlwaysActive -> empty - _ -> ppr act - | otherwise = ptext (sLit "NOINLINE") - <+> ppr_match_info - <+> case act of - NeverActive -> empty - _ -> ppr act - where - ppr_match_info = if isFunLike match_info then empty else ppr match_info + ppr (InlinePragma { inl_inline = inline, inl_act = activation, inl_rule = info }) + = pp_inline <+> pp_info <+> pp_activation + where + pp_inline | inline = ptext (sLit "INLINE") + | otherwise = ptext (sLit "NOINLINE") + pp_info | isFunLike info = empty + | otherwise = ppr info + pp_activation + | inline && isAlwaysActive activation = empty + | not inline && isNeverActive activation = empty + | otherwise = ppr activation isActive :: CompilerPhase -> Activation -> Bool isActive _ NeverActive = False @@ -680,11 +715,15 @@ isActive _ AlwaysActive = True isActive p (ActiveAfter n) = p <= n isActive p (ActiveBefore n) = p > n -isNeverActive, isAlwaysActive :: Activation -> Bool +isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool isNeverActive NeverActive = True isNeverActive _ = False isAlwaysActive AlwaysActive = True isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False \end{code} diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index b7aeb45cd4..8712db119c 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -69,7 +69,6 @@ module Id ( idArity, idNewDemandInfo, idNewDemandInfo_maybe, idNewStrictness, idNewStrictness_maybe, - idWorkerInfo, idUnfolding, idSpecialisation, idCoreRules, idHasRules, idCafInfo, @@ -87,7 +86,6 @@ module Id ( setIdArity, setIdNewDemandInfo, setIdNewStrictness, zapIdNewStrictness, - setIdWorkerInfo, setIdSpecialisation, setIdCafInfo, setIdOccInfo, zapIdOccInfo, @@ -140,7 +138,6 @@ infixl 1 `setIdUnfolding`, `setIdArity`, `setIdNewDemandInfo`, `setIdNewStrictness`, - `setIdWorkerInfo`, `setIdSpecialisation`, `setInlinePragma`, `idCafInfo` @@ -289,9 +286,7 @@ instantiated before use. -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty - = mkLocalId wkr_name ty - where - wkr_name = mkInternalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcSpan unwrkr) + = mkLocalId (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty -- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings mkTemplateLocal :: Int -> Type -> Id @@ -350,8 +345,8 @@ isPrimOpId id = case Var.idDetails id of _ -> False isDFunId id = case Var.idDetails id of - DFunId -> True - _ -> False + DFunId _ -> True + _ -> False isPrimOpId_maybe id = case Var.idDetails id of PrimOpId op -> Just op @@ -409,11 +404,11 @@ isImplicitId :: Id -> Bool -- file, even if it's mentioned in some other interface unfolding. isImplicitId id = case Var.idDetails id of - FCallId _ -> True - ClassOpId _ -> True - PrimOpId _ -> True - DataConWorkId _ -> True - DataConWrapId _ -> True + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True -- These are are implied by their type or class decl; -- remember that all type and class decls appear in the interface file. -- The dfun id is not an implicit Id; it must *not* be omitted, because @@ -513,14 +508,6 @@ isStrictId id (isStrictType (idType id)) --------------------------------- - -- WORKER ID -idWorkerInfo :: Id -> WorkerInfo -idWorkerInfo id = workerInfo (idInfo id) - -setIdWorkerInfo :: Id -> WorkerInfo -> Id -setIdWorkerInfo id work_info = modifyIdInfo (`setWorkerInfo` work_info) id - - --------------------------------- -- UNFOLDING idUnfolding :: Id -> Unfolding idUnfolding id = unfoldingInfo (idInfo id) @@ -549,6 +536,9 @@ setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id --------------------------------- -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs + idSpecialisation :: Id -> SpecInfo idSpecialisation id = specInfo (idInfo id) @@ -617,7 +607,7 @@ idInlineActivation :: Id -> Activation idInlineActivation id = inlinePragmaActivation (idInlinePragma id) setInlineActivation :: Id -> Activation -> Id -setInlineActivation id act = modifyInlinePragma id (\(InlinePragma _ match_info) -> InlinePragma act match_info) +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) idRuleMatchInfo :: Id -> RuleMatchInfo idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs index fb18c81085..9446f7d1e4 100644 --- a/compiler/basicTypes/IdInfo.lhs +++ b/compiler/basicTypes/IdInfo.lhs @@ -49,11 +49,6 @@ module IdInfo ( cprInfoFromNewStrictness, #endif - -- ** The WorkerInfo type - WorkerInfo(..), - workerExists, wrapperArity, workerId, - workerInfo, setWorkerInfo, ppWorkerInfo, - -- ** Unfolding Info unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, @@ -94,7 +89,6 @@ import CoreSyn ( CoreRule, setRuleIdName, seqRules, Unfolding, noUnfolding ) import Class import PrimOp import Name -import Var import VarSet import BasicTypes import DataCon @@ -119,7 +113,6 @@ infixl 1 `setSpecInfo`, `setArityInfo`, `setInlinePragInfo`, `setUnfoldingInfo`, - `setWorkerInfo`, `setLBVarInfo`, `setOccInfo`, `setCafInfo`, @@ -165,8 +158,8 @@ seqNewStrictnessInfo Nothing = () seqNewStrictnessInfo (Just ty) = seqStrictSig ty pprNewStrictness :: Maybe StrictSig -> SDoc -pprNewStrictness Nothing = empty -pprNewStrictness (Just sig) = ftext (fsLit "Str:") <+> ppr sig +pprNewStrictness Nothing = empty +pprNewStrictness (Just sig) = ppr sig #ifdef OLD_STRICTNESS oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo @@ -260,35 +253,38 @@ data IdDetails -- b) when desugaring a RecordCon we can get -- from the Id back to the data con] - | ClassOpId Class -- ^ The 'Id' is an operation of a class + | ClassOpId Class -- ^ The 'Id' is an superclass selector or class operation of a class | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator | FCallId ForeignCall -- ^ The 'Id' is for a foreign call | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - | DFunId -- ^ A dictionary function. We don't use this in an essential way, - -- currently, but it's kind of nice that we can keep track of - -- which Ids are DFuns, across module boundaries too + | DFunId Bool -- ^ A dictionary function. + -- True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary instance Outputable IdDetails where ppr = pprIdDetails pprIdDetails :: IdDetails -> SDoc -pprIdDetails VanillaId = empty -pprIdDetails (DataConWorkId _) = ptext (sLit "[DataCon]") -pprIdDetails (DataConWrapId _) = ptext (sLit "[DataConWrapper]") -pprIdDetails (ClassOpId _) = ptext (sLit "[ClassOp]") -pprIdDetails (PrimOpId _) = ptext (sLit "[PrimOp]") -pprIdDetails (FCallId _) = ptext (sLit "[ForeignCall]") -pprIdDetails (TickBoxOpId _) = ptext (sLit "[TickBoxOp]") -pprIdDetails DFunId = ptext (sLit "[DFunId]") -pprIdDetails (RecSelId { sel_naughty = is_naughty }) - = brackets $ ptext (sLit "RecSel") <> pp_naughty - where - pp_naughty | is_naughty = ptext (sLit "(naughty)") - | otherwise = empty +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = ptext (sLit "DataCon") + pp (DataConWrapId _) = ptext (sLit "DataConWrapper") + pp (ClassOpId {}) = ptext (sLit "ClassOp") + pp (PrimOpId _) = ptext (sLit "PrimOp") + pp (FCallId _) = ptext (sLit "ForeignCall") + pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") + pp (DFunId b) = ptext (sLit "DFunId") <> + ppWhen b (ptext (sLit "(newtype)")) + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ ptext (sLit "RecSel") + <> ppWhen is_naughty (ptext (sLit "(naughty)")) \end{code} @@ -314,20 +310,12 @@ data IdInfo = IdInfo { arityInfo :: !ArityInfo, -- ^ 'Id' arity specInfo :: SpecInfo, -- ^ Specialisations of the 'Id's function which exist + -- See Note [Specialisations and RULES in IdInfo] #ifdef OLD_STRICTNESS cprInfo :: CprInfo, -- ^ If the 'Id's function always constructs a product result demandInfo :: Demand.Demand, -- ^ Whether or not the 'Id' is definitely demanded strictnessInfo :: StrictnessInfo, -- ^ 'Id' strictness properties #endif - workerInfo :: WorkerInfo, -- ^ Pointer to worker function. - -- Within one module this is irrelevant; the - -- inlining of a worker is handled via the 'Unfolding'. - -- However, when the module is imported by others, the - -- 'WorkerInfo' is used /only/ to indicate the form of - -- the RHS, so that interface files don't actually - -- need to contain the RHS; it can be derived from - -- the strictness info - unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding cafInfo :: CafInfo, -- ^ 'Id' CAF info lbvarInfo :: LBVarInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one @@ -353,7 +341,6 @@ seqIdInfo (IdInfo {}) = () megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info = seqSpecInfo (specInfo info) `seq` - seqWorker (workerInfo info) `seq` -- Omitting this improves runtimes a little, presumably because -- some unfoldings are not calculated at all @@ -376,8 +363,6 @@ megaSeqIdInfo info Setters \begin{code} -setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo -setWorkerInfo info wk = wk `seq` info { workerInfo = wk } setSpecInfo :: IdInfo -> SpecInfo -> IdInfo setSpecInfo info sp = sp `seq` info { specInfo = sp } setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo @@ -433,7 +418,6 @@ vanillaIdInfo strictnessInfo = NoStrictnessInfo, #endif specInfo = emptySpecInfo, - workerInfo = NoWorker, unfoldingInfo = noUnfolding, lbvarInfo = NoLBVarInfo, inlinePragInfo = defaultInlinePragma, @@ -505,6 +489,25 @@ type InlinePragInfo = InlinePragma %* * %************************************************************************ +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalIdshas an *empty* SpecInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +jsut for convenience really. + +However, LocalIds may have non-empty SpecInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. + \begin{code} -- | Records the specializations of this 'Id' that we know about -- in the form of rewrite 'CoreRule's that target them @@ -542,67 +545,6 @@ seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs %************************************************************************ %* * -\subsection[worker-IdInfo]{Worker info about an @Id@} -%* * -%************************************************************************ - -There might not be a worker, even for a strict function, because: -(a) the function might be small enough to inline, so no need - for w/w split -(b) the strictness info might be "SSS" or something, so no w/w split. - -Sometimes the arity of a wrapper changes from the original arity from -which it was generated, so we always emit the "original" arity into -the interface file, as part of the worker info. - -How can this happen? Sometimes we get - f = coerce t (\x y -> $wf x y) -at the moment of w/w split; but the eta reducer turns it into - f = coerce t $wf -which is perfectly fine except that the exposed arity so far as -the code generator is concerned (zero) differs from the arity -when we did the split (2). - -All this arises because we use 'arity' to mean "exactly how many -top level lambdas are there" in interface files; but during the -compilation of this module it means "how many things can I apply -this to". - -\begin{code} - --- | If this Id has a worker then we store a reference to it. Worker --- functions are generated by the worker\/wrapper pass, using information --- information from strictness analysis. -data WorkerInfo = NoWorker -- ^ No known worker function - | HasWorker Id Arity -- ^ The 'Arity' is the arity of the /wrapper/ at the moment of the - -- worker\/wrapper split, which may be different from the current 'Id' 'Aritiy' - -seqWorker :: WorkerInfo -> () -seqWorker (HasWorker id a) = id `seq` a `seq` () -seqWorker NoWorker = () - -ppWorkerInfo :: WorkerInfo -> SDoc -ppWorkerInfo NoWorker = empty -ppWorkerInfo (HasWorker wk_id _) = ptext (sLit "Worker") <+> ppr wk_id - -workerExists :: WorkerInfo -> Bool -workerExists NoWorker = False -workerExists (HasWorker _ _) = True - --- | The 'Id' of the worker function if it exists, or a panic otherwise -workerId :: WorkerInfo -> Id -workerId (HasWorker id _) = id -workerId NoWorker = panic "workerId: NoWorker" - --- | The 'Arity' of the worker function at the time of the split if it exists, or a panic otherwise -wrapperArity :: WorkerInfo -> Arity -wrapperArity (HasWorker _ a) = a -wrapperArity NoWorker = panic "wrapperArity: NoWorker" -\end{code} - - -%************************************************************************ -%* * \subsection[CG-IdInfo]{Code generator-related information} %* * %************************************************************************ @@ -634,6 +576,9 @@ mayHaveCafRefs _ = False seqCaf :: CafInfo -> () seqCaf c = c `seq` () +instance Outputable CafInfo where + ppr = ppCafInfo + ppCafInfo :: CafInfo -> SDoc ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs") ppCafInfo MayHaveCafRefs = empty @@ -777,7 +722,6 @@ zapFragileInfo :: IdInfo -> Maybe IdInfo -- ^ Zap info that depends on free variables zapFragileInfo info = Just (info `setSpecInfo` emptySpecInfo - `setWorkerInfo` NoWorker `setUnfoldingInfo` noUnfolding `setOccInfo` if isFragileOcc occ then NoOccInfo else occ) where diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 7060c80306..449f09f0c6 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -345,8 +345,8 @@ mkDataConIds wrap_name wkr_name data_con -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkImplicitUnfolding $ Note InlineMe $ - mkLams wrap_tvs $ + wrap_unf = mkInlineRule InlSat wrap_rhs (length dict_args + length id_args) + wrap_rhs = mkLams wrap_tvs $ mkLams eq_args $ mkLams dict_args $ mkLams id_args $ foldr mk_case con_app @@ -460,12 +460,25 @@ mkDictSelId no_unf name clas info = noCafIdInfo `setArityInfo` 1 `setAllStrictnessInfo` Just strict_sig - `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) + `setSpecInfo` mkSpecInfo [rule] + `setInlinePragInfo` neverInlinePragma + `setUnfoldingInfo` (if no_unf then noUnfolding + else mkImplicitUnfolding rhs) + -- Experimental: NOINLINE, so that their rule matches -- We no longer use 'must-inline' on record selectors. They'll -- inline like crazy if they scrutinise a constructor + n_ty_args = length tyvars + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule index n_ty_args } + -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting -- It's worth giving one, so that absence info etc is generated @@ -480,7 +493,8 @@ mkDictSelId no_unf name clas tyvars = dataConUnivTyVars data_con arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con eq_theta = dataConEqTheta data_con - the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name + index = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name + the_arg_id = arg_ids !! index pred = mkClassPred clas (mkTyVarTys tyvars) dict_id = mkTemplateLocal 1 $ mkPredTy pred @@ -496,6 +510,20 @@ mkDictSelId no_unf name clas rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] + +dictSelRule :: Int -> Arity -> [CoreExpr] -> Maybe CoreExpr +-- Oh, very clever +-- op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm +-- op_i t1..tk (D t1..tk op1 ... opm) = opi +-- +-- NB: the data constructor has the same number of type args as the class op + +dictSelRule index n_ty_args args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, _, val_args) <- exprIsConApp_maybe dict_arg + = Just (val_args !! index) + | otherwise + = Nothing \end{code} @@ -825,8 +853,9 @@ mkDictFunId :: Name -- Name to use for the dict fun; -> Id mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys - = mkExportedLocalVar DFunId dfun_name dfun_ty vanillaIdInfo + = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo where + is_nt = isNewTyCon (classTyCon clas) dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) \end{code} @@ -934,7 +963,7 @@ c) It has quite a bit of desugaring magic. d) There is some special rule handing: Note [RULES for seq] -Note [Rules for seq] +Note [RULES for seq] ~~~~~~~~~~~~~~~~~~~~ Roman found situations where he had case (f n) of _ -> e diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index cb6785afbe..c3a1bd1fcd 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -37,7 +37,7 @@ module Name ( BuiltInSyntax(..), -- ** Creating 'Name's - mkInternalName, mkSystemName, + mkInternalName, mkSystemName, mkDerivedInternalName, mkSystemVarName, mkSysTvName, mkFCallName, mkIPName, mkTickBoxOpName, @@ -249,6 +249,11 @@ mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Inter -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name mkExternalName uniq mod occ loc diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 3a2338e8a4..a48922ac9d 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -49,7 +49,7 @@ module OccName ( -- ** Derived 'OccName's isDerivedOccName, mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, - mkDerivedTyConOcc, mkNewTyCoOcc, + mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, @@ -58,7 +58,7 @@ module OccName ( mkInstTyCoOcc, mkEqPredCoOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPDataTyConOcc, mkPDataDataConOcc, - mkPReprTyConOcc, + mkPReprTyConOcc, mkPADFunOcc, -- ** Deconstruction @@ -526,7 +526,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, - mkInstTyCoOcc, mkEqPredCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc @@ -536,6 +536,7 @@ mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con @@ -544,9 +545,9 @@ mkDictOcc = mk_simple_deriv varName "$d" mkIPOcc = mk_simple_deriv varName "$i" mkSpecOcc = mk_simple_deriv varName "$s" mkForeignExportOcc = mk_simple_deriv varName "$f" -mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes -mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions -mkEqPredCoOcc = mk_simple_deriv tcName "$co" +mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" -- used in derived instances mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs index 28732b3198..94297adbaf 100644 --- a/compiler/coreSyn/CoreArity.lhs +++ b/compiler/coreSyn/CoreArity.lhs @@ -8,7 +8,7 @@ \begin{code} -- | Arit and eta expansion module CoreArity ( - manifestArity, exprArity, + manifestArity, exprArity, exprBotStrictness_maybe, exprEtaExpandArity, etaExpand ) where @@ -138,6 +138,15 @@ exprEtaExpandArity dflags e = applyStateHack e (arityType dicts_cheap e) where dicts_cheap = dopt Opt_DictsCheap dflags + +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness signatures. It's used during +-- float-out +exprBotStrictness_maybe e + = case arityType False e of + AT _ ATop -> Nothing + AT a ABot -> Just (a, mkStrictSig (mkTopDmdType (replicate a topDmd) BotRes)) \end{code} Note [Definition of arity] @@ -430,6 +439,13 @@ simplification but it's not too hard. The alernative, of relying on a subsequent clean-up phase of the Simplifier to de-crapify the result, means you can't really use it in CorePrep, which is painful. +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + \begin{code} -- | @etaExpand n us e ty@ returns an expression with -- the same meaning as @e@, but with arity @n@. @@ -444,11 +460,6 @@ means you can't really use it in CorePrep, which is painful. etaExpand :: Arity -- ^ Result should have this number of value args -> CoreExpr -- ^ Expression to expand -> CoreExpr --- Note that SCCs are not treated specially. If we have --- etaExpand 2 (\x -> scc "foo" e) --- = (\xy -> (scc "foo" e) y) --- So the costs of evaluating 'e' (not 'e y') are attributed to "foo" - -- etaExpand deals with for-alls. For example: -- etaExpand 1 E -- where E :: forall a. a -> a @@ -468,7 +479,6 @@ etaExpand n orig_expr go 0 expr = expr go n (Lam v body) | isTyVar v = Lam v (go n body) | otherwise = Lam v (go (n-1) body) - go n (Note InlineMe expr) = Note InlineMe (go n expr) go n (Cast expr co) = Cast (go n expr) co go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ etaInfoAbs etas (etaInfoApp subst' expr etas) diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index e2eb3a2e82..f94f61d25e 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -16,6 +16,7 @@ Taken quite directly from the Peyton Jones/Lester paper. module CoreFVs ( -- * Free variables of expressions and binding groups exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars + exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids exprsFreeVars, -- [CoreExpr] -> VarSet bindFreeVars, -- CoreBind -> VarSet @@ -25,7 +26,9 @@ module CoreFVs ( exprFreeNames, exprsFreeNames, -- * Free variables of Rules, Vars and Ids - idRuleVars, idFreeVars, varTypeTyVars, varTypeTcTyVars, + varTypeTyVars, varTypeTcTyVars, + idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, + idRuleVars, idRuleRhsVars, ruleRhsFreeVars, rulesFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, @@ -71,6 +74,10 @@ but not those that are free in the type of variable occurrence. exprFreeVars :: CoreExpr -> VarSet exprFreeVars = exprSomeFreeVars isLocalVar +-- | Find all locally-defined free Ids in an expression +exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +exprFreeIds = exprSomeFreeVars isLocalId + -- | Find all locally-defined free Ids or type variables in several expressions exprsFreeVars :: [CoreExpr] -> VarSet exprsFreeVars = foldr (unionVarSet . exprFreeVars) emptyVarSet @@ -194,7 +201,8 @@ expr_fvs (Let (Rec pairs) body) --------- rhs_fvs :: (Id,CoreExpr) -> FV -rhs_fvs (bndr, rhs) = expr_fvs rhs `union` someVars (bndrRuleVars bndr) +rhs_fvs (bndr, rhs) = expr_fvs rhs `union` + someVars (bndrRuleAndUnfoldingVars bndr) -- Treat any RULES as extra RHSs of the binding --------- @@ -271,6 +279,7 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) -- | Those variables free in the both the left right hand sides of a rule ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars (BuiltinRule {}) = noFVs ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) = delFromUFM fvs fn -- Note [Rule free var hack] where @@ -334,8 +343,8 @@ delBinderFV :: Var -> VarSet -> VarSet -- (b `delBinderFV` s) removes the binder b from the free variable set s, -- but *adds* to s --- (a) the free variables of b's type --- (b) the idSpecVars of b +-- +-- the free variables of b's type -- -- This is really important for some lambdas: -- In (\x::a -> x) the only mention of "a" is in the binder. @@ -378,14 +387,41 @@ varTypeTcTyVars var | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars idFreeVars :: Id -> VarSet -idFreeVars id = ASSERT( isId id) idRuleVars id `unionVarSet` varTypeTyVars id - -bndrRuleVars ::Var -> VarSet -bndrRuleVars v | isTyVar v = emptyVarSet - | otherwise = idRuleVars v - -idRuleVars ::Id -> VarSet +-- Type variables, rule variables, and inline variables +idFreeVars id = ASSERT( isId id) + varTypeTyVars id `unionVarSet` + idRuleAndUnfoldingVars id + +bndrRuleAndUnfoldingVars ::Var -> VarSet +-- A 'let' can bind a type variable, and idRuleVars assumes +-- it's seeing an Id. This function tests first. +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet + | otherwise = idRuleAndUnfoldingVars v + +idRuleAndUnfoldingVars :: Id -> VarSet +idRuleAndUnfoldingVars id = ASSERT( isId id) + idRuleVars id `unionVarSet` + idUnfoldingVars id + +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id) + +idRuleRhsVars :: Id -> VarSet -- Does *not* include the CoreUnfolding vars +-- Just the variables free on the *rhs* of a rule +-- See Note [Choosing loop breakers] in Simplify.lhs +idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) + emptyVarSet + (idCoreRules id) + +idUnfoldingVars :: Id -> VarSet +-- Produce free vars for an unfolding, but NOT for an ordinary +-- (non-inline) unfolding, since it is a dup of the rhs +idUnfoldingVars id + = case idUnfolding id of + CoreUnfolding { uf_tmpl = rhs, uf_guidance = InlineRule {} } + -> exprFreeVars rhs + DFunUnfolding _ args -> exprsFreeVars args + _ -> emptyVarSet \end{code} @@ -436,7 +472,9 @@ freeVars (Case scrut bndr ty alts) rhs2 = freeVars rhs freeVars (Let (NonRec binder rhs) body) - = (freeVarsOf rhs2 `unionFVs` body_fvs `unionFVs` bndrRuleVars binder, + = (freeVarsOf rhs2 + `unionFVs` body_fvs + `unionFVs` bndrRuleAndUnfoldingVars binder, -- Remember any rules; cf rhs_fvs above AnnLet (AnnNonRec binder rhs2) body2) where @@ -452,7 +490,7 @@ freeVars (Let (Rec binds) body) rhss2 = map freeVars rhss rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 - all_fvs = foldr (unionFVs . idRuleVars) rhs_body_fvs binders + all_fvs = foldr (unionFVs . idRuleAndUnfoldingVars) rhs_body_fvs binders -- The "delBinderFV" happens after adding the idSpecVars, -- since the latter may add some of the binders as fvs diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index a3ba3ae250..5156bbcf40 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -7,11 +7,7 @@ A ``lint'' pass to check for Core correctness \begin{code} -module CoreLint ( - lintCoreBindings, - lintUnfolding, - showPass, endPass, endPassIf, endIteration - ) where +module CoreLint ( lintCoreBindings, lintUnfolding ) where #include "HsVersions.h" @@ -28,7 +24,6 @@ import VarEnv import VarSet import Name import Id -import IdInfo import PprCore import ErrUtils import SrcLoc @@ -47,43 +42,6 @@ import Data.Maybe %************************************************************************ %* * -\subsection{End pass} -%* * -%************************************************************************ - -@showPass@ and @endPass@ don't really belong here, but it makes a convenient -place for them. They print out stuff before and after core passes, -and do Core Lint when necessary. - -\begin{code} -endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -endPass = dumpAndLint dumpIfSet_core - -endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -endPassIf cond = dumpAndLint (dumpIf_core cond) - -endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -endIteration = dumpAndLint dumpIfSet_dyn - -dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) - -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO () -dumpAndLint dump dflags pass_name dump_flag binds - = do - -- Report result size if required - -- This has the side effect of forcing the intermediate to be evaluated - debugTraceMsg dflags 2 $ - (text " Result size =" <+> int (coreBindsSize binds)) - - -- Report verbosely, if required - dump dflags dump_flag pass_name (pprCoreBindings binds) - - -- Type check - lintCoreBindings dflags pass_name binds -\end{code} - - -%************************************************************************ -%* * \subsection[lintCoreBindings]{@lintCoreBindings@: Top-level interface} %* * %************************************************************************ @@ -226,10 +184,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) where binder_ty = idType binder maybeDmdTy = idNewStrictness_maybe binder - bndr_vars = varSetElems (idFreeVars binder `unionVarSet` wkr_vars) - wkr_vars | workerExists wkr_info = unitVarSet (workerId wkr_info) - | otherwise = emptyVarSet - wkr_info = idWorkerInfo binder + bndr_vars = varSetElems (idFreeVars binder) lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () \end{code} diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 2a5987c40c..36b6f5ce24 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -15,7 +15,7 @@ import PrelNames ( lazyIdKey, hasKey ) import CoreUtils import CoreArity import CoreFVs -import CoreLint +import CoreMonad ( endPass ) import CoreSyn import Type import Coercion @@ -147,7 +147,7 @@ corePrepPgm dflags binds data_tycons = do floats2 <- corePrepTopBinds implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPass dflags "CorePrep" Opt_D_dump_prep binds_out + endPass dflags "CorePrep" Opt_D_dump_prep binds_out [] return binds_out corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr @@ -640,7 +640,6 @@ ignoreNote :: Note -> Bool -- want to get this: -- unzip = /\ab \xs. (__inline_me__ ...) a b xs ignoreNote (CoreNote _) = True -ignoreNote InlineMe = True ignoreNote _other = False diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index f63968e0fa..f1f02d9b9c 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -11,12 +11,12 @@ module CoreSubst ( Subst, TvSubstEnv, IdSubstEnv, InScopeSet, -- ** Substituting into expressions and related types - deShadowBinds, - substTy, substExpr, substBind, substSpec, substWorker, - lookupIdSubst, lookupTvSubst, + deShadowBinds, substSpec, substRulesForImportedIds, + substTy, substExpr, substBind, substUnfolding, + substInlineRuleGuidance, lookupIdSubst, lookupTvSubst, substIdOcc, -- ** Operations on substitutions - emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst, + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, extendSubst, extendSubstList, zapSubstEnv, extendInScope, extendInScopeList, extendInScopeIds, @@ -24,7 +24,10 @@ module CoreSubst ( -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, - cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs + cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + -- ** Simple expression optimiser + simpleOptExpr ) where #include "HsVersions.h" @@ -32,12 +35,14 @@ module CoreSubst ( import CoreSyn import CoreFVs import CoreUtils +import OccurAnal( occurAnalyseExpr ) import qualified Type import Type ( Type, TvSubst(..), TvSubstEnv ) import VarSet import VarEnv import Id +import Name ( Name ) import Var ( Var, TyVar, setVarUnique ) import IdInfo import Unique @@ -211,13 +216,22 @@ lookupIdSubst (Subst in_scope ids _) v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v ) + | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope ) Var v -- | Find the substitution for a 'TyVar' in the 'Subst' lookupTvSubst :: Subst -> TyVar -> Type lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v +-- | Simultaneously substitute for a bunch of variables +-- No left-right shadowing +-- ie the substitution for (\x \y. e) a1 a2 +-- so neither x nor y scope over a1 a2 +mkOpenSubst :: [(Var,CoreArg)] -> Subst +mkOpenSubst pairs = Subst (mkInScopeSet (exprsFreeVars (map snd pairs))) + (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) + (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + ------------------------------ isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope @@ -315,6 +329,9 @@ substBind subst (Rec pairs) = (subst', Rec pairs') -- -- (Actually, within a single /type/ there might still be shadowing, because -- 'substTy' is a no-op for the empty substitution, but that's probably OK.) +-- +-- [Aug 09] This function is not used in GHC at the moment, but seems so +-- short and simple that I'm going to leave it here deShadowBinds :: [CoreBind] -> [CoreBind] deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) \end{code} @@ -474,49 +491,87 @@ substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules - `setWorkerInfo` substWorker subst old_wrkr - `setUnfoldingInfo` noUnfolding) + `setUnfoldingInfo` substUnfolding subst old_unf) where old_rules = specInfo info - old_wrkr = workerInfo info - nothing_to_do = isEmptySpecInfo old_rules && - not (workerExists old_wrkr) && - not (hasUnfolding (unfoldingInfo info)) + old_unf = unfoldingInfo info + nothing_to_do = isEmptySpecInfo old_rules && isClosedUnfolding old_unf ------------------ --- | Substitutes for the 'Id's within the 'WorkerInfo' -substWorker :: Subst -> WorkerInfo -> WorkerInfo - -- Seq'ing on the returned WorkerInfo is enough to cause all the - -- substitutions to happen completely - -substWorker _ NoWorker - = NoWorker -substWorker subst (HasWorker w a) - = case lookupIdSubst subst w of - Var w1 -> HasWorker w1 a - other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr w ) - NoWorker -- Worker has got substituted away altogether - -- (This can happen if it's trivial, - -- via postInlineUnconditionally, hence warning) +-- | Substitutes for the 'Id's within an unfolding +substUnfolding :: Subst -> Unfolding -> Unfolding + -- Seq'ing on the returned Unfolding is enough to cause + -- all the substitutions to happen completely +substUnfolding subst (DFunUnfolding con args) + = DFunUnfolding con (map (substExpr subst) args) + +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_guidance = guide@(InlineRule {}) }) + -- Retain an InlineRule! + = seqExpr new_tmpl `seq` + new_mb_wkr `seq` + unf { uf_tmpl = new_tmpl, uf_guidance = guide { ug_ir_info = new_mb_wkr } } + where + new_tmpl = substExpr subst tmpl + new_mb_wkr = substInlineRuleGuidance subst (ug_ir_info guide) + +substUnfolding _ (CoreUnfolding {}) = NoUnfolding -- Discard + -- Always zap a CoreUnfolding, to save substitution work + +substUnfolding _ unf = unf -- Otherwise no substitution to do + +------------------- +substInlineRuleGuidance :: Subst -> InlineRuleInfo -> InlineRuleInfo +substInlineRuleGuidance subst (InlWrapper wkr) + = case lookupIdSubst subst wkr of + Var w1 -> InlWrapper w1 + other -> WARN( not (exprIsTrivial other), text "CoreSubst.substWorker:" <+> ppr wkr ) + InlUnSat -- Worker has got substituted away altogether + -- (This can happen if it's trivial, via + -- postInlineUnconditionally, hence only warning) +substInlineRuleGuidance _ info = info + +------------------ +substIdOcc :: Subst -> Id -> Id +-- These Ids should not be substituted to non-Ids +substIdOcc subst v = case lookupIdSubst subst v of + Var v' -> v' + other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) ------------------ -- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' substSpec :: Subst -> Id -> SpecInfo -> SpecInfo -substSpec subst new_fn (SpecInfo rules rhs_fvs) - = seqSpecInfo new_rules `seq` new_rules +substSpec subst new_id (SpecInfo rules rhs_fvs) + = seqSpecInfo new_spec `seq` new_spec where - new_name = idName new_fn - new_rules = SpecInfo (map do_subst rules) (substVarSet subst rhs_fvs) - - do_subst rule@(BuiltinRule {}) = rule - do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) - = rule { ru_bndrs = bndrs', - ru_fn = new_name, -- Important: the function may have changed its name! - ru_args = map (substExpr subst') args, - ru_rhs = substExpr subst' rhs } - where - (subst', bndrs') = substBndrs subst bndrs + subst_ru_fn = const (idName new_id) + new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules) + (substVarSet subst rhs_fvs) + +------------------ +substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] +substRulesForImportedIds subst rules + = map (substRule subst (\name -> name)) rules + +------------------ +substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id + +substRule _ _ rule@(BuiltinRule {}) = rule +substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs }) + = rule { ru_bndrs = bndrs', + ru_fn = subst_ru_fn fn_name, + ru_args = map (substExpr subst') args, + ru_rhs = substExpr subst' rhs } + where + (subst', bndrs') = substBndrs subst bndrs ------------------ substVarSet :: Subst -> VarSet -> VarSet @@ -527,3 +582,103 @@ substVarSet subst fvs | isId fv = exprFreeVars (lookupIdSubst subst fv) | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv) \end{code} + +%************************************************************************ +%* * + The Very Simple Optimiser +%* * +%************************************************************************ + +\begin{code} +simpleOptExpr :: CoreExpr -> CoreExpr +-- Do simple optimisation on an expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or where the RHS is trivial +-- +-- The result is NOT guaranteed occurence-analysed, becuase +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically + +simpleOptExpr expr + = go init_subst (occurAnalyseExpr expr) + where + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + -- It's potentially important to make a proper in-scope set + -- Consider let x = ..y.. in \y. ...x... + -- Then we should remember to clone y before substituting + -- for x. It's very unlikely to occur, because we probably + -- won't *be* substituting for x if it occurs inside a + -- lambda. + -- + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + + go subst (Var v) = lookupIdSubst subst v + go subst (App e1 e2) = App (go subst e1) (go subst e2) + go subst (Type ty) = Type (substTy subst ty) + go _ (Lit lit) = Lit lit + go subst (Note note e) = Note note (go subst e) + go subst (Cast e co) = Cast (go subst e) (substTy subst co) + go subst (Let bind body) = go_let subst bind body + go subst (Lam bndr body) = Lam bndr' (go subst' body) + where + (subst', bndr') = substBndr subst bndr + + go subst (Case e b ty as) = Case (go subst e) b' + (substTy subst ty) + (map (go_alt subst') as) + where + (subst', b') = substBndr subst b + + + ---------------------- + go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + + ---------------------- + go_let subst (Rec prs) body + = Let (Rec (reverse rev_prs')) (go subst'' body) + where + (subst', bndrs') = substRecBndrs subst (map fst prs) + (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs') + do_pr (subst, prs) ((b,r), b') = case go_bind subst b r of + Left subst' -> (subst', prs) + Right r' -> (subst, (b',r'):prs) + + go_let subst (NonRec b r) body + = case go_bind subst b r of + Left subst' -> go subst' body + Right r' -> Let (NonRec b' r') (go subst' body) + where + (subst', b') = substBndr subst b + + + ---------------------- + go_bind :: Subst -> Var -> CoreExpr -> Either Subst CoreExpr + -- (go_bind subst old_var old_rhs) + -- either extends subst with (old_var -> new_rhs) + -- or return new_rhs for a binding new_var = new_rhs + go_bind subst b r + | Type ty <- r + , isTyVar b -- let a::* = TYPE ty in <body> + = Left (extendTvSubst subst b (substTy subst ty)) + + | isId b -- let x = e in <body> + , safe_to_inline (idOccInfo b) || exprIsTrivial r' + = Left (extendIdSubst subst b r') + + | otherwise + = Right r' + where + r' = go subst r + + ---------------------- + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline IAmDead = True + safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br + safe_to_inline (IAmALoopBreaker {}) = False + safe_to_inline NoOccInfo = False +\end{code} diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 4d8f3cb860..01e2be77c6 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -35,16 +35,19 @@ module CoreSyn ( isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, -- * Unfolding data types - Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs + Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), + -- Abstract everywhere but in CoreUnfold.lhs -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, -- ** Predicates and deconstruction on 'Unfolding' - unfoldingTemplate, maybeUnfoldingTemplate, otherCons, + unfoldingTemplate, setUnfoldingTemplate, + maybeUnfoldingTemplate, otherCons, unfoldingArity, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, - isExpandableUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, neverUnfold, + isExpandableUnfolding, + isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding, + isStableUnfolding, canUnfold, neverUnfoldGuidance, -- * Strictness seqExpr, seqExprs, seqUnfolding, @@ -272,21 +275,7 @@ See #type_let# -- | Allows attaching extra information to points in expressions rather than e.g. identifiers. data Note = SCC CostCentre -- ^ A cost centre annotation for profiling - - | InlineMe -- ^ Instructs the core simplifer to treat the enclosed expression - -- as very small, and inline it at its call sites - | CoreNote String -- ^ A generic core annotation, propagated but not used by GHC - --- NOTE: we also treat expressions wrapped in InlineMe as --- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable) --- What this means is that we obediently inline even things that don't --- look like valuse. This is sometimes important: --- {-# INLINE f #-} --- f = g . h --- Here, f looks like a redex, and we aren't going to inline (.) because it's --- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we --- should inline f even inside lambdas. In effect, we should trust the programmer. \end{code} @@ -324,6 +313,8 @@ data CoreRule -- And the right-hand side ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] -- Locality ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is @@ -338,10 +329,10 @@ data CoreRule -- | Built-in rules are used for constant folding -- and suchlike. They have no free variables. | BuiltinRule { - ru_name :: RuleName, -- ^ As above - ru_fn :: Name, -- ^ As above - ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' expects, - -- including type arguments + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments ru_try :: [CoreExpr] -> Maybe CoreExpr -- ^ This function does the rewrite. It given too many -- arguments, it simply discards them; the returned 'CoreExpr' @@ -392,59 +383,105 @@ The @Unfolding@ type is declared here to avoid numerous loops -- identifier would have if we substituted its definition in for the identifier. -- This type should be treated as abstract everywhere except in "CoreUnfold" data Unfolding - = NoUnfolding -- ^ We have no information about the unfolding - - | OtherCon [AltCon] -- ^ It ain't one of these constructors. - -- @OtherCon xs@ also indicates that something has been evaluated - -- and hence there's no point in re-evaluating it. - -- @OtherCon []@ is used even for non-data-type values - -- to indicated evaluated-ness. Notably: - -- - -- > data C = C !(Int -> Int) - -- > case x of { C f -> ... } - -- - -- Here, @f@ gets an @OtherCon []@ unfolding. - - | CompulsoryUnfolding CoreExpr -- ^ There is /no original definition/, - -- so you'd better unfold. - - | CoreUnfolding - CoreExpr - Bool - Bool - Bool - Bool - UnfoldingGuidance + = NoUnfolding -- ^ We have no information about the unfolding + + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding DataCon [CoreExpr] + -- The Unfolding of a DFunId + -- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + -- where Arity = n, the number of dict args to the dfun + -- The [CoreExpr] are the superclasses and methods [op1,op2], + -- in positional order. + -- They are usually variables, but can be trivial expressions + -- instead (e.g. a type application). + + | CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_arity :: Arity, -- Number of value arguments expected + uf_is_top :: Bool, -- True <=> top level binding + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on + -- this variable + uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: Bool, -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } -- ^ An unfolding with redundant cached information. Parameters: -- - -- 1) Template used to perform unfolding; binder-info is correct + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] -- - -- 2) Is this a top level binding? + -- uf_is_top: Is this a top level binding? -- - -- 3) 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on -- this variable -- - -- 4) Does this waste only a little work if we expand it inside an inlining? + -- uf_is_cheap: Does this waste only a little work if we expand it inside an inlining? -- Basically this is a cached version of 'exprIsCheap' -- - -- 5) Tells us about the /size/ of the unfolding template + -- uf_guidance: Tells us about the /size/ of the unfolding template --- | When unfolding should take place +------------------------------------------------ +-- | 'UnfoldingGuidance' says when unfolding should take place data UnfoldingGuidance - = UnfoldNever - | UnfoldIfGoodArgs Int -- and "n" value args - - [Int] -- Discount if the argument is evaluated. - -- (i.e., a simplification will definitely - -- be possible). One elt of the list per *value* arg. - - Int -- The "size" of the unfolding; to be elaborated - -- later. ToDo - - Int -- Scrutinee discount: the discount to substract if the thing is in - -- a context (case (thing args) of ...), - -- (where there are the right number of arguments.) - + = UnfoldAlways -- There is /no original definition/, so you'd better unfold. + -- The unfolding is guaranteed to have no free variables + -- so no need to think about it during dependency analysis + + | InlineRule { -- See Note [InlineRules] + -- Be very keen to inline this + -- The uf_tmpl is the *original* RHS; do *not* replace it on + -- each simlifier run. Hence, the *actual* RHS of the function + -- may be different by now, because it may have been optimised. + ug_ir_info :: InlineRuleInfo, -- Supplementary info about the InlineRule + ug_small :: Bool -- True <=> the RHS is so small (eg no bigger than a call) + -- that you should always inline a saturated call, + } -- regardless of how boring the context is + -- See Note [INLINE for small functions] in CoreUnfold] + + | UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfoldNever + +data InlineRuleInfo + = InlSat -- A user-specifed or compiler injected INLINE pragma + -- ONLY inline when it's applied to 'arity' arguments + + | InlUnSat -- The compiler decided to "capture" the RHS into an + -- InlineRule, but do not require that it appears saturated + + | InlWrapper Id -- This unfolding is a the wrapper in a + -- worker/wrapper split from the strictness analyser + -- Used to abbreviate the uf_tmpl in interface files + -- which don't need to contain the RHS; + -- it can be derived from the strictness info + +------------------------------------------------ noUnfolding :: Unfolding -- ^ There is no known 'Unfolding' evaldUnfolding :: Unfolding @@ -457,27 +494,30 @@ mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon seqUnfolding :: Unfolding -> () -seqUnfolding (CoreUnfolding e top b1 b2 b3 g) - = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_is_value = b1, uf_is_cheap = b2, + uf_expandable = b3, uf_arity = a, uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` seqGuidance g + seqUnfolding _ = () seqGuidance :: UnfoldingGuidance -> () -seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` () -seqGuidance _ = () +seqGuidance (UnfoldIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () \end{code} \begin{code} -- | Retrieves the template of an unfolding: panics if none is known unfoldingTemplate :: Unfolding -> CoreExpr -unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr -unfoldingTemplate (CompulsoryUnfolding expr) = expr -unfoldingTemplate _ = panic "getUnfoldingTemplate" +unfoldingTemplate = uf_tmpl + +setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding +setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs } -- | Retrieves the template of an unfolding if possible maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr -maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr -maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr -maybeUnfoldingTemplate _ = Nothing +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) = Just expr +maybeUnfoldingTemplate _ = Nothing -- | The constructors that the unfolding could never be: -- returns @[]@ if no information is available @@ -488,51 +528,106 @@ otherCons _ = [] -- | Determines if it is certainly the case that the unfolding will -- yield a value (something in HNF): returns @False@ if unsure isValueUnfolding :: Unfolding -> Bool -isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald -isValueUnfolding _ = False + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isValueUnfolding _ = False -- | Determines if it possibly the case that the unfolding will -- yield a value. Unlike 'isValueUnfolding' it returns @True@ -- for 'OtherCon' isEvaldUnfolding :: Unfolding -> Bool -isEvaldUnfolding (OtherCon _) = True -isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald -isEvaldUnfolding _ = False + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isEvaldUnfolding _ = False -- | Is the thing we will unfold into certainly cheap? isCheapUnfolding :: Unfolding -> Bool -isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap -isCheapUnfolding _ = False +isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap +isCheapUnfolding _ = False isExpandableUnfolding :: Unfolding -> Bool -isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable -isExpandableUnfolding _ = False +isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable +isExpandableUnfolding _ = False + +isInlineRule :: Unfolding -> Bool +isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True +isInlineRule _ = False + +isInlineRule_maybe :: Unfolding -> Maybe InlineRuleInfo +isInlineRule_maybe (CoreUnfolding { + uf_guidance = InlineRule { ug_ir_info = inl } }) = Just inl +isInlineRule_maybe _ = Nothing --- | Must this unfolding happen for the code to be executable? -isCompulsoryUnfolding :: Unfolding -> Bool -isCompulsoryUnfolding (CompulsoryUnfolding _) = True -isCompulsoryUnfolding _ = False +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_guidance = InlineRule {} }) = True +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False --- | Do we have an available or compulsory unfolding? -hasUnfolding :: Unfolding -> Bool -hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True -hasUnfolding (CompulsoryUnfolding _) = True -hasUnfolding _ = False +unfoldingArity :: Unfolding -> Arity +unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity +unfoldingArity _ = panic "unfoldingArity" + +isClosedUnfolding :: Unfolding -> Bool -- No free variables +isClosedUnfolding (CoreUnfolding {}) = False +isClosedUnfolding _ = True -- | Only returns False if there is no unfolding information available at all hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False hasSomeUnfolding _ = True --- | Similar to @not . hasUnfolding@, but also returns @True@ --- if it has an unfolding that says it should never occur -neverUnfold :: Unfolding -> Bool -neverUnfold NoUnfolding = True -neverUnfold (OtherCon _) = True -neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True -neverUnfold _ = False +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfoldNever = True +neverUnfoldGuidance _ = False + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False \end{code} +Note [InlineRule] +~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = <rhs> +you intend that calls (f e) are replaced by <rhs>[e/x] So we +should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise <rhs> to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. + +So the representation of an Unfolding has changed quite a bit +(see CoreSyn). An INLINE pragma gives rise to an InlineRule +unfolding. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +See also Note [Inlining an InlineRule] in CoreUnfold. + + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, +so that the occurence info on the binders is correct. This is important, +because the Simplifier does not re-analyse the template when using it. If +the occurrence info is wrong + - We may get more simpifier iterations than necessary, because + once-occ info isn't there + - More seriously, we may get an infinite loop if there's a Rec + without a loop breaker marked + %************************************************************************ %* * diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs index ff68b129f0..f634197847 100644 --- a/compiler/coreSyn/CoreTidy.lhs +++ b/compiler/coreSyn/CoreTidy.lhs @@ -153,7 +153,7 @@ tidyLetBndr env (id,rhs) -- separate compilation boundaries final_id = new_id `setIdInfo` new_info idinfo = idInfo id - new_info = vanillaIdInfo + new_info = idInfo new_id `setArityInfo` exprArity rhs `setAllStrictnessInfo` newStrictnessInfo idinfo `setNewDemandInfo` newDemandInfo idinfo @@ -166,7 +166,7 @@ tidyLetBndr env (id,rhs) -- Non-top-level variables tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) tidyIdBndr env@(tidy_env, var_env) id - = -- do this pattern match strictly, otherwise we end up holding on to + = -- Do this pattern match strictly, otherwise we end up holding on to -- stuff in the OccName. case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> let @@ -174,24 +174,36 @@ tidyIdBndr env@(tidy_env, var_env) id -- The SrcLoc isn't important now, -- though we could extract it from the Id -- - -- All nested Ids now have the same IdInfo, namely vanillaIdInfo, - -- which should save some space; except that we hang onto dead-ness - -- (at the moment, solely to make printing tidy core nicer) - -- But note that tidyLetBndr puts some of it back. ty' = tidyType env (idType id) name' = mkInternalName (idUnique id) occ' noSrcSpan id' = mkLocalIdWithInfo name' ty' new_info var_env' = extendVarEnv var_env id id' - new_info | isDeadOcc (idOccInfo id) = deadIdInfo - | otherwise = vanillaIdInfo + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + old_info = idInfo id in - ((tidy_env', var_env'), id') + ((tidy_env', var_env'), id') } - -deadIdInfo :: IdInfo -deadIdInfo = vanillaIdInfo `setOccInfo` IAmDead \end{code} +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and InlineRules, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + + \begin{code} (=:) :: a -> (a -> b) -> b m =: k = m `seq` k m diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs index 0c7e9e485b..f32d5b1482 100644 --- a/compiler/coreSyn/CoreUnfold.lhs +++ b/compiler/coreSyn/CoreUnfold.lhs @@ -18,12 +18,10 @@ find, unsurprisingly, a Core expression. module CoreUnfold ( Unfolding, UnfoldingGuidance, -- Abstract types - noUnfolding, mkTopUnfolding, mkImplicitUnfolding, mkUnfolding, - mkCompulsoryUnfolding, seqUnfolding, - evaldUnfolding, mkOtherCon, otherCons, - unfoldingTemplate, maybeUnfoldingTemplate, - isEvaldUnfolding, isValueUnfolding, isExpandableUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, neverUnfold, + noUnfolding, mkImplicitUnfolding, + mkTopUnfolding, mkUnfolding, mkCoreUnfolding, + mkInlineRule, mkWwInlineRule, + mkCompulsoryUnfolding, mkDFunUnfolding, interestingArg, ArgSummary(..), @@ -32,24 +30,32 @@ module CoreUnfold ( callSiteInline, CallCtxt(..), + exprIsConApp_maybe + ) where +#include "HsVersions.h" + import StaticFlags import DynFlags import CoreSyn import PprCore () -- Instances import OccurAnal -import CoreSubst ( Subst, emptySubst, substTy, extendIdSubst, extendTvSubst - , lookupIdSubst, substBndr, substBndrs, substRecBndrs ) +import CoreSubst hiding( substTy ) import CoreUtils import Id import DataCon +import TyCon import Literal import PrimOp import IdInfo -import Type hiding( substTy, extendTvSubst ) +import BasicTypes ( Arity ) +import TcType ( tcSplitDFunTy ) +import Type +import Coercion import PrelNames import Bag +import Util import FastTypes import FastString import Outputable @@ -69,28 +75,34 @@ mkTopUnfolding expr = mkUnfolding True {- Top level -} expr mkImplicitUnfolding :: CoreExpr -> Unfolding -- For implicit Ids, do a tiny bit of optimising first -mkImplicitUnfolding expr - = CoreUnfolding (simpleOptExpr emptySubst expr) - True - (exprIsHNF expr) - (exprIsCheap expr) - (exprIsExpandable expr) - (calcUnfoldingGuidance opt_UF_CreationThreshold expr) - -mkUnfolding :: Bool -> CoreExpr -> Unfolding -mkUnfolding top_lvl expr - = CoreUnfolding (occurAnalyseExpr expr) - top_lvl - - (exprIsHNF expr) - -- Already evaluated +mkImplicitUnfolding expr = mkTopUnfolding (simpleOptExpr expr) - (exprIsCheap expr) - -- OK to inline inside a lambda +mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule id = mkInlineRule (InlWrapper id) - (exprIsExpandable expr) +mkInlineRule :: InlineRuleInfo -> CoreExpr -> Arity -> Unfolding +mkInlineRule inl_info expr arity + = mkCoreUnfolding True -- Note [Top-level flag on inline rules] + expr' arity + (InlineRule { ug_ir_info = inl_info, ug_small = small }) + where + expr' = simpleOptExpr expr + small = case calcUnfoldingGuidance (arity+1) expr' of + (arity_e, UnfoldIfGoodArgs { ug_size = size_e }) + -> uncondInline arity_e size_e + _other {- actually UnfoldNever -} -> False + +-- Note [Top-level flag on inline rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Slight hack: note that mk_inline_rules conservatively sets the +-- top-level flag to True. It gets set more accurately by the simplifier +-- Simplify.simplUnfolding. - (calcUnfoldingGuidance opt_UF_CreationThreshold expr) +mkUnfolding :: Bool -> CoreExpr -> Unfolding +mkUnfolding top_lvl expr + = mkCoreUnfolding top_lvl expr arity guidance + where + (arity, guidance) = calcUnfoldingGuidance opt_UF_CreationThreshold expr -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains -- two copies of the thing while the occurrence-analysed expression doesn't @@ -100,17 +112,23 @@ mkUnfolding top_lvl expr -- This can occasionally mean that the guidance is very pessimistic; -- it gets fixed up next round -instance Outputable Unfolding where - ppr NoUnfolding = ptext (sLit "No unfolding") - ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs - ppr (CompulsoryUnfolding e) = ptext (sLit "Compulsory") <+> ppr e - ppr (CoreUnfolding e top hnf cheap expable g) - = ptext (sLit "Unf") <+> sep [ppr top <+> ppr hnf <+> ppr cheap <+> ppr expable <+> ppr g, - ppr e] +mkCoreUnfolding :: Bool -> CoreExpr -> Arity -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding top_lvl expr arity guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, + uf_arity = arity, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_cheap = exprIsCheap expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkDFunUnfolding :: DataCon -> [Id] -> Unfolding +mkDFunUnfolding con ops = DFunUnfolding con (map Var ops) mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded - = CompulsoryUnfolding (occurAnalyseExpr expr) + = mkCoreUnfolding True expr 0 UnfoldAlways -- Arity of unfolding doesn't matter \end{code} @@ -121,75 +139,26 @@ mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded %************************************************************************ \begin{code} -instance Outputable UnfoldingGuidance where - ppr UnfoldNever = ptext (sLit "NEVER") - ppr (UnfoldIfGoodArgs v cs size discount) - = hsep [ ptext (sLit "IF_ARGS"), int v, - brackets (hsep (map int cs)), - int size, - int discount ] -\end{code} - - -\begin{code} calcUnfoldingGuidance :: Int -- bomb out if size gets bigger than this -> CoreExpr -- expression to look at - -> UnfoldingGuidance + -> (Arity, UnfoldingGuidance) calcUnfoldingGuidance bOMB_OUT_SIZE expr - = case collect_val_bndrs expr of { (inline, val_binders, body) -> + = case collectBinders expr of { (binders, body) -> let + val_binders = filter isId binders n_val_binders = length val_binders - - max_inline_size = n_val_binders+2 - -- The idea is that if there is an INLINE pragma (inline is True) - -- and there's a big body, we give a size of n_val_binders+2. This - -- This is just enough to fail the no-size-increase test in callSiteInline, - -- so that INLINE things don't get inlined into entirely boring contexts, - -- but no more. - in case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of - - TooBig - | not inline -> UnfoldNever - -- A big function with an INLINE pragma must - -- have an UnfoldIfGoodArgs guidance - | otherwise -> UnfoldIfGoodArgs n_val_binders - (map (const 0) val_binders) - max_inline_size 0 - + TooBig -> (n_val_binders, UnfoldNever) SizeIs size cased_args scrut_discount - -> UnfoldIfGoodArgs - n_val_binders - (map discount_for val_binders) - final_size - (iBox scrut_discount) + -> (n_val_binders, UnfoldIfGoodArgs { ug_args = map discount_for val_binders + , ug_size = iBox size + , ug_res = iBox scrut_discount }) where - boxed_size = iBox size - - final_size | inline = boxed_size `min` max_inline_size - | otherwise = boxed_size - - -- Sometimes an INLINE thing is smaller than n_val_binders+2. - -- A particular case in point is a constructor, which has size 1. - -- We want to inline this regardless, hence the `min` - discount_for b = foldlBag (\acc (b',n) -> if b==b' then acc+n else acc) 0 cased_args - } - where - collect_val_bndrs e = go False [] e - -- We need to be a bit careful about how we collect the - -- value binders. In ptic, if we see - -- __inline_me (\x y -> e) - -- We want to say "2 value binders". Why? So that - -- we take account of information given for the arguments - - go _ rev_vbs (Note InlineMe e) = go True rev_vbs e - go inline rev_vbs (Lam b e) | isId b = go inline (b:rev_vbs) e - | otherwise = go inline rev_vbs e - go inline rev_vbs e = (inline, reverse rev_vbs, e) + } \end{code} Note [Computing the size of an expression] @@ -222,18 +191,28 @@ Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's a function call to account for. Notice also that constructor applications are very cheap, because exposing them to a caller is so valuable. -Thing to watch out for - -* We inline *unconditionally* if inlined thing is smaller (using sizeExpr) - than the thing it's replacing. Notice that +Note [Unconditional inlining] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inline *unconditionally* if inlined thing is smaller (using sizeExpr) +than the thing it's replacing. Notice that (f x) --> (g 3) -- YES, unconditionally (f x) --> x : [] -- YES, *even though* there are two -- arguments to the cons x --> g 3 -- NO x --> Just v -- NO - It's very important not to unconditionally replace a variable by - a non-atomic term. +It's very important not to unconditionally replace a variable by +a non-atomic term. + +\begin{code} +uncondInline :: Arity -> Int -> Bool +-- Inline unconditionally if there no size increase +-- Size of call is arity (+1 for the function) +-- See Note [Unconditional inlining] +uncondInline arity size + | arity == 0 = size == 0 + | otherwise = size <= arity + 1 +\end{code} \begin{code} @@ -248,20 +227,12 @@ sizeExpr :: FastInt -- Bomb out if it gets bigger than this sizeExpr bOMB_OUT_SIZE top_args expr = size_up expr where + size_up (Cast e _) = size_up e + size_up (Note _ e) = size_up e size_up (Type _) = sizeZero -- Types cost nothing size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) = size_up_call f 0 -- Make sure we get constructor + size_up (Var f) = size_up_call f [] -- Make sure we get constructor -- discounts even on nullary constructors - size_up (Cast e _) = size_up e - - size_up (Note InlineMe _) = sizeOne -- Inline notes make it look very small - -- This can be important. If you have an instance decl like this: - -- instance Foo a => Foo [a] where - -- {-# INLINE op1, op2 #-} - -- op1 = ... - -- op2 = ... - -- then we'll get a dfun which is a pair of two INLINE lambdas - size_up (Note _ body) = size_up body -- Other notes cost nothing size_up (App fun (Type _)) = size_up fun size_up (App fun arg) = size_up_app fun [arg] @@ -324,17 +295,18 @@ sizeExpr bOMB_OUT_SIZE top_args expr | isTypeArg arg = size_up_app fun args | otherwise = size_up_app fun (arg:args) `addSize` nukeScrutDiscount (size_up arg) - size_up_app (Var fun) args = size_up_call fun (length args) + size_up_app (Var fun) args = size_up_call fun args size_up_app other args = size_up other `addSizeN` length args ------------ - size_up_call :: Id -> Int -> ExprSize - size_up_call fun n_val_args + size_up_call :: Id -> [CoreExpr] -> ExprSize + size_up_call fun val_args = case idDetails fun of FCallId _ -> sizeN opt_UF_DearOp - DataConWorkId dc -> conSize dc n_val_args - PrimOpId op -> primOpSize op n_val_args - _ -> funSize top_args fun n_val_args + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op -> primOpSize op (length val_args) + ClassOpId _ -> classOpSize top_args val_args + _ -> funSize top_args fun (length val_args) ------------ size_up_alt (_con, _bndrs, rhs) = size_up rhs @@ -365,6 +337,22 @@ litSize _other = 0 -- Must match size of nullary constructors -- Key point: if x |-> 4, then x must inline unconditionally -- (eg via case binding) +classOpSize :: [Id] -> [CoreExpr] -> ExprSize +-- See Note [Conlike is interesting] +classOpSize _ [] + = sizeZero +classOpSize top_args (arg1 : other_args) + = SizeIs (iUnbox size) arg_discount (_ILIT(0)) + where + size = 2 + length other_args + -- If the class op is scrutinising a lambda bound dictionary then + -- give it a discount, to encourage the inlining of this function + -- The actual discount is rather arbitrarily chosen + arg_discount = case arg1 of + Var dict | dict `elem` top_args + -> unitBag (dict, opt_UF_DictDiscount) + _other -> emptyBag + funSize :: [Id] -> Id -> Int -> ExprSize -- Size for functions that are not constructors or primops -- Note [Function applications] @@ -450,6 +438,35 @@ lamScrutDiscount (SizeIs n vs _) = SizeIs n vs (iUnbox opt_UF_FunAppDiscount) lamScrutDiscount TooBig = TooBig \end{code} +Note [Discounts and thresholds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constants for discounts and thesholds are defined in main/StaticFlags, +all of form opt_UF_xxxx. They are: + +opt_UF_CreationThreshold (45) + At a definition site, if the unfolding is bigger than this, we + may discard it altogether + +opt_UF_UseThreshold (6) + At a call site, if the unfolding, less discounts, is smaller than + this, then it's small enough inline + +opt_UF_KeennessFactor (1.5) + Factor by which the discounts are multiplied before + subtracting from size + +opt_UF_DictDiscount (1) + The discount for each occurrence of a dictionary argument + as an argument of a class method. Should be pretty small + else big functions may get inlined + +opt_UF_FunAppDiscount (6) + Discount for a function argument that is applied. Quite + large, because if we inline we avoid the higher-order call. + +opt_UF_DearOp (4) + The size of a foreign call or not-dupable PrimOp + Note [Function applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -508,52 +525,38 @@ sizeN n = SizeIs (iUnbox n) emptyBag (_ILIT(0)) %* * %************************************************************************ -We have very limited information about an unfolding expression: (1)~so -many type arguments and so many value arguments expected---for our -purposes here, we assume we've got those. (2)~A ``size'' or ``cost,'' -a single integer. (3)~An ``argument info'' vector. For this, what we -have at the moment is a Boolean per argument position that says, ``I -will look with great favour on an explicit constructor in this -position.'' (4)~The ``discount'' to subtract if the expression -is being scrutinised. - -Assuming we have enough type- and value arguments (if not, we give up -immediately), then we see if the ``discounted size'' is below some -(semi-arbitrary) threshold. It works like this: for every argument -position where we're looking for a constructor AND WE HAVE ONE in our -hands, we get a (again, semi-arbitrary) discount [proportion to the -number of constructors in the type being scrutinized]. - -If we're in the context of a scrutinee ( \tr{(case <expr > of A .. -> ...;.. )}) -and the expression in question will evaluate to a constructor, we use -the computed discount size *for the result only* rather than -computing the argument discounts. Since we know the result of -the expression is going to be taken apart, discounting its size -is more accurate (see @sizeExpr@ above for how this discount size -is computed). - -We use this one to avoid exporting inlinings that we ``couldn't possibly -use'' on the other side. Can be overridden w/ flaggery. -Just the same as smallEnoughToInline, except that it has no actual arguments. +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. \begin{code} couldBeSmallEnoughToInline :: Int -> CoreExpr -> Bool -couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold rhs of - UnfoldNever -> False - _ -> True - -certainlyWillInline :: Unfolding -> Bool - -- Sees if the unfolding is pretty certain to inline -certainlyWillInline (CoreUnfolding _ _ _ is_cheap _ (UnfoldIfGoodArgs n_vals _ size _)) - = is_cheap && size - (n_vals+1) <= opt_UF_UseThreshold -certainlyWillInline _ - = False +couldBeSmallEnoughToInline threshold rhs + = case calcUnfoldingGuidance threshold rhs of + (_, UnfoldNever) -> False + _ -> True +---------------- smallEnoughToInline :: Unfolding -> Bool -smallEnoughToInline (CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ _ size _)) +smallEnoughToInline (CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_size = size}}) = size <= opt_UF_UseThreshold smallEnoughToInline _ = False + +---------------- +certainlyWillInline :: Unfolding -> Bool + -- Sees if the unfolding is pretty certain to inline +certainlyWillInline (CoreUnfolding { uf_is_cheap = is_cheap, uf_arity = n_vals, uf_guidance = guidance }) + = case guidance of + UnfoldAlways {} -> True + UnfoldNever -> False + InlineRule {} -> True + UnfoldIfGoodArgs { ug_size = size} + -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold + +certainlyWillInline _ + = False \end{code} %************************************************************************ @@ -610,87 +613,81 @@ data CallCtxt = BoringCtxt instance Outputable CallCtxt where ppr BoringCtxt = ptext (sLit "BoringCtxt") - ppr (ArgCtxt _ _) = ptext (sLit "ArgCtxt") + ppr (ArgCtxt rules disc) = ptext (sLit "ArgCtxt") <> ppr (rules,disc) ppr CaseCtxt = ptext (sLit "CaseCtxt") ppr ValAppCtxt = ptext (sLit "ValAppCtxt") callSiteInline dflags active_inline id lone_variable arg_infos cont_info - = case idUnfolding id of { - NoUnfolding -> Nothing ; - OtherCon _ -> Nothing ; - - CompulsoryUnfolding unf_template -> Just unf_template ; - -- CompulsoryUnfolding => there is no top-level binding - -- for these things, so we must inline it. - -- Only a couple of primop-like things have - -- compulsory unfoldings (see MkId.lhs). - -- We don't allow them to be inactive - - CoreUnfolding unf_template is_top is_value is_cheap is_expable guidance -> - + = let + n_val_args = length arg_infos + in + case idUnfolding id of { + NoUnfolding -> Nothing ; + OtherCon _ -> Nothing ; + DFunUnfolding {} -> Nothing ; -- Never unfold a DFun + CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top, uf_is_value = is_value, + uf_is_cheap = is_cheap, uf_arity = uf_arity, uf_guidance = guidance } -> + -- uf_arity will typically be equal to (idArity id), + -- but may be less for InlineRules let result | yes_or_no = Just unf_template | otherwise = Nothing - n_val_args = length arg_infos - - yes_or_no = active_inline && is_cheap && consider_safe - -- We consider even the once-in-one-branch - -- occurrences, because they won't all have been - -- caught by preInlineUnconditionally. In particular, - -- if the occurrence is once inside a lambda, and the - -- rhs is cheap but not a manifest lambda, then - -- pre-inline will not have inlined it for fear of - -- invalidating the occurrence info in the rhs. - - consider_safe - -- consider_safe decides whether it's a good idea to - -- inline something, given that there's no - -- work-duplication issue (the caller checks that). + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + some_benefit = interesting_args + || n_val_args > uf_arity -- Over-saturated + || interesting_saturated_call -- Exactly saturated + + interesting_saturated_call + = case cont_info of + BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] + CaseCtxt -> not (lone_variable && is_value) -- Note [Lone variables] + ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + ValAppCtxt -> True -- Note [Cast then apply] + + yes_or_no = case guidance of UnfoldNever -> False - UnfoldIfGoodArgs n_vals_wanted arg_discounts size res_discount - | uncond_inline -> True - | otherwise -> some_benefit && small_enough && inline_enough_args - - where - -- Inline unconditionally if there no size increase - -- Size of call is n_vals_wanted (+1 for the function) - uncond_inline - | n_vals_wanted == 0 = size == 0 - | otherwise = enough_args && (size <= n_vals_wanted + 1) - - enough_args = n_val_args >= n_vals_wanted - inline_enough_args = - not (dopt Opt_InlineIfEnoughArgs dflags) || enough_args - - - some_benefit = any nonTriv arg_infos || really_interesting_cont - -- There must be something interesting - -- about some argument, or the result - -- context, to make it worth inlining - - -- NB: (any nonTriv arg_infos) looks at the over-saturated - -- args too which is wrong; but if over-saturated - -- we'll probably inline anyway. - - really_interesting_cont - | n_val_args < n_vals_wanted = False -- Too few args - | n_val_args == n_vals_wanted = interesting_saturated_call - | otherwise = True -- Extra args - -- really_interesting_cont tells if the result of the - -- call is in an interesting context. - - interesting_saturated_call - = case cont_info of - BoringCtxt -> not is_top && n_vals_wanted > 0 -- Note [Nested functions] - CaseCtxt -> not lone_variable || not is_value -- Note [Lone variables] - ArgCtxt {} -> n_vals_wanted > 0 -- Note [Inlining in ArgCtxt] - ValAppCtxt -> True -- Note [Cast then apply] - - small_enough = (size - discount) <= opt_UF_UseThreshold - discount = computeDiscount n_vals_wanted arg_discounts - res_discount arg_infos cont_info + + UnfoldAlways -> True + -- UnfoldAlways => there is no top-level binding for + -- these things, so we must inline it. Only a few + -- primop-like things have compulsory unfoldings (see + -- MkId.lhs). Ignore is_active because we want to + -- inline even if SimplGently is on. + + InlineRule { ug_ir_info = inl_info, ug_small = uncond_inline } + | not active_inline -> False + | n_val_args < uf_arity -> yes_unsat -- Not enough value args + | uncond_inline -> True -- Note [INLINE for small functions] + | otherwise -> some_benefit -- Saturated or over-saturated + where + -- See Note [Inlining an InlineRule] + yes_unsat = case inl_info of + InlSat -> False + _other -> interesting_args + + UnfoldIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + | not active_inline -> False + | not is_cheap -> False + | n_val_args < uf_arity -> interesting_args && small_enough + -- Note [Unsaturated applications] + | uncondInline uf_arity size -> True + | otherwise -> some_benefit && small_enough + + where + small_enough = (size - discount) <= opt_UF_UseThreshold + discount = computeDiscount uf_arity arg_discounts + res_discount arg_infos cont_info in if dopt Opt_D_dump_inlinings dflags then @@ -700,7 +697,6 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info text "interesting continuation" <+> ppr cont_info, text "is value:" <+> ppr is_value, text "is cheap:" <+> ppr is_cheap, - text "is expandable:" <+> ppr is_expable, text "guidance" <+> ppr guidance, text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]) result @@ -709,6 +705,44 @@ callSiteInline dflags active_inline id lone_variable arg_infos cont_info } \end{code} +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Bool.False -> y GHC.Bool.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + g y = f y +Then f's RHS is no larger than its LHS, so we should inline it +into even the most boring context. (We do so if there is no INLINE +pragma!) That's the reason for the 'inl_small' flag on an InlineRule. + + Note [Things to watch] ~~~~~~~~~~~~~~~~~~~~~~ * { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } @@ -720,6 +754,21 @@ Note [Things to watch] Make sure that x does not inline unconditionally! Lest we get extra allocation. +Note [Inlining an InlineRule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An InlineRules is used for + (a) pogrammer INLINE pragmas + (b) inlinings from worker/wrapper + +For (a) the RHS may be large, and our contract is that we *only* inline +when the function is applied to all the arguments on the LHS of the +source-code defn. (The uf_arity in the rule.) + +However for worker/wrapper it may be worth inlining even if the +arity is not satisfied (as we do in the CoreUnfolding case) so we don't +require saturation. + + Note [Nested functions] ~~~~~~~~~~~~~~~~~~~~~~~ If a function has a nested defn we also record some-benefit, on the @@ -744,7 +793,7 @@ no value arguments. The ValAppCtxt gives it enough incentive to inline. Note [Inlining in ArgCtxt] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -The condition (n_vals_wanted > 0) here is very important, because otherwise +The condition (arity > 0) here is very important, because otherwise we end up inlining top-level stuff into useless places; eg x = I# 3# f = \y. g x @@ -760,11 +809,13 @@ Note [Lone variables] The "lone-variable" case is important. I spent ages messing about with unsatisfactory varaints, but this is nice. The idea is that if a variable appears all alone - as an arg of lazy fn, or rhs Stop - as scrutinee of a case Select - as arg of a strict fn ArgOf + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt AND it is bound to a value + then we should not inline it (unless there is some other reason, e.g. is is the sole occurrence). That is what is happening at the use of 'lone_variable' in 'interesting_saturated_call'. @@ -798,6 +849,11 @@ However, watch out: important: in the NDP project, 'bar' generates a closure data structure rather than a list. + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as cheap; because that is when exprIsConApp_maybe + looks through the unfolding. Hence the "&& is_cheap" in the + InlineRule branch. + * Even a type application or coercion isn't a lone variable. Consider case $fMonadST @ RealWorld of { :DMonad a b c -> c } @@ -873,10 +929,21 @@ But we don't regard (f x y) as interesting, unless f is unsaturated. If it's saturated and f hasn't inlined, then it's probably not going to now! +Note [Conlike is interesting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f d = ...((*) d x y)... + ... f (df d')... +where df is con-like. Then we'd really like to inline so that the +rule for (*) (df d) can fire. To do this + a) we give a discount for being an argument of a class-op (eg (*) d) + b) we say that a con-like argument (eg (df d)) is interesting + \begin{code} data ArgSummary = TrivArg -- Nothing interesting | NonTrivArg -- Arg has structure | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] interestingArg :: CoreExpr -> ArgSummary -- See Note [Interesting arguments] @@ -885,7 +952,8 @@ interestingArg e = go e 0 -- n is # value args to which the expression is applied go (Lit {}) _ = ValueArg go (Var v) n - | isDataConWorkId v = ValueArg + | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that + -- data constructors here | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding | n > 0 = NonTrivArg -- Saturated or unknown call | evald_unfolding = ValueArg -- n==0; look for a value @@ -910,75 +978,169 @@ nonTriv TrivArg = False nonTriv _ = True \end{code} - %************************************************************************ %* * - The Very Simple Optimiser + exprIsConApp_maybe %* * %************************************************************************ +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if \begin{code} -simpleOptExpr :: Subst -> CoreExpr -> CoreExpr --- Return an occur-analysed and slightly optimised expression --- The optimisation is very straightforward: just --- inline non-recursive bindings that are used only once, --- or wheere the RHS is trivial - -simpleOptExpr subst expr - = go subst (occurAnalyseExpr expr) +-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is +-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@, +-- where t1..tk are the *universally-qantified* type args of 'dc' +exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [Type], [CoreExpr]) + +exprIsConApp_maybe (Note _ expr) + = exprIsConApp_maybe expr + -- We ignore all notes. For example, + -- case _scc_ "foo" (C a b) of + -- C a b -> e + -- should be optimised away, but it will be only if we look + -- through the SCC note. + +exprIsConApp_maybe (Cast expr co) + = -- Here we do the KPush reduction rule as described in the FC paper + -- The transformation applies iff we have + -- (C e1 ... en) `cast` co + -- where co :: (T t1 .. tn) ~ to_ty + -- The left-hand one must be a T, because exprIsConApp returned True + -- but the right-hand one might not be. (Though it usually will.) + + case exprIsConApp_maybe expr of { + Nothing -> Nothing ; + Just (dc, _dc_univ_args, dc_args) -> + + let (_from_ty, to_ty) = coercionKind co + dc_tc = dataConTyCon dc + in + case splitTyConApp_maybe to_ty of { + Nothing -> Nothing ; + Just (to_tc, to_tc_arg_tys) + | dc_tc /= to_tc -> Nothing + -- These two Nothing cases are possible; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there't nothing wrong with it + + | otherwise -> + let + tc_arity = tyConArity dc_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tyvars = dataConExTyVars dc + arg_tys = dataConRepArgTys dc + + dc_eqs :: [(Type,Type)] -- All equalities from the DataCon + dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++ + [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc] + + (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args + (co_args, val_args) = splitAtList dc_eqs rest1 + + -- Make the "theta" from Fig 3 of the paper + gammas = decomposeCo tc_arity co + theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ stripTypeArgs ex_args) + + -- Cast the existential coercion arguments + cast_co (ty1, ty2) (Type co) + = Type $ mkSymCoercion (substTy theta ty1) + `mkTransCoercion` co + `mkTransCoercion` (substTy theta ty2) + cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg) + new_co_args = zipWith cast_co dc_eqs co_args + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg + in +#ifdef DEBUG + let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, + ppr arg_tys, ppr dc_args, ppr _dc_univ_args, + ppr ex_args, ppr val_args] + ASSERT2( coreEqType from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) +#endif + + Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args) + }} + +exprIsConApp_maybe expr + = analyse expr [] where - go subst (Var v) = lookupIdSubst subst v - go subst (App e1 e2) = App (go subst e1) (go subst e2) - go subst (Type ty) = Type (substTy subst ty) - go _ (Lit lit) = Lit lit - go subst (Note note e) = Note note (go subst e) - go subst (Cast e co) = Cast (go subst e) (substTy subst co) - go subst (Let bind body) = go_bind subst bind body - go subst (Lam bndr body) = Lam bndr' (go subst' body) - where - (subst', bndr') = substBndr subst bndr - - go subst (Case e b ty as) = Case (go subst e) b' - (substTy subst ty) - (map (go_alt subst') as) - where - (subst', b') = substBndr subst b - - - ---------------------- - go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs) - where - (subst', bndrs') = substBndrs subst bndrs - - ---------------------- - go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss')) - (go subst' body) - where - (bndrs, rhss) = unzip prs - (subst', bndrs') = substRecBndrs subst bndrs - rhss' = map (go subst') rhss - - go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body - - ---------------------- - go_nonrec subst b (Type ty') body - | isTyVar b = go (extendTvSubst subst b ty') body - -- let a::* = TYPE ty in <body> - go_nonrec subst b r' body - | isId b -- let x = e in <body> - , exprIsTrivial r' || safe_to_inline (idOccInfo b) - = go (extendIdSubst subst b r') body - go_nonrec subst b r' body - = Let (NonRec b' r') (go subst' body) - where - (subst', b') = substBndr subst b - - ---------------------- - -- Unconditionally safe to inline - safe_to_inline :: OccInfo -> Bool - safe_to_inline IAmDead = True - safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br - safe_to_inline (IAmALoopBreaker {}) = False - safe_to_inline NoOccInfo = False -\end{code}
\ No newline at end of file + analyse (App fun arg) args = analyse fun (arg:args) + analyse fun@(Lam {}) args = beta fun [] args + + analyse (Var fun) args + | Just con <- isDataConWorkId_maybe fun + , is_saturated + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args + = Just (con, stripTypeArgs univ_ty_args, rest_args) + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding con ops <- unfolding + , is_saturated + , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) + subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) + = Just (con, substTys subst dfun_res_tys, + [mkApps op args | op <- ops]) + + -- Look through unfoldings, but only cheap ones, because + -- we are effectively duplicating the unfolding + | CoreUnfolding { uf_expandable = expand_me, uf_tmpl = rhs } <- unfolding + , expand_me = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $ + analyse rhs args + where + is_saturated = count isValArg args == idArity fun + unfolding = idUnfolding fun + + analyse _ _ = Nothing + + ----------- + beta (Lam v body) pairs (arg : args) + | isTypeArg arg + = beta body ((v,arg):pairs) args + + beta (Lam {}) _ _ -- Un-saturated, or not a type lambda + = Nothing + + beta fun pairs args + = case analyse (substExpr (mkOpenSubst pairs) fun) args of + Nothing -> -- pprTrace "Bale out! exprIsConApp_maybe" doc $ + Nothing + Just ans -> -- pprTrace "Woo-hoo! exprIsConApp_maybe" doc $ + Just ans + where + -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args] + + +stripTypeArgs :: [CoreExpr] -> [Type] +stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) + [ty | Type ty <- args] +\end{code} + +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index d48d69eb81..56a84a5ab3 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -16,7 +16,7 @@ Utility functions on @Core@ syntax -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions - mkInlineMe, mkSCC, mkCoerce, mkCoerceI, + mkSCC, mkCoerce, mkCoerceI, bindNonRec, needsCaseBinding, mkAltExpr, mkPiType, mkPiTypes, @@ -27,7 +27,6 @@ module CoreUtils ( exprType, coreAltType, coreAltsType, exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable, exprIsHNF,exprOkForSpeculation, exprIsBig, - exprIsConApp_maybe, exprIsBottom, rhsIsStatic, -- * Expression and bindings size @@ -62,7 +61,6 @@ import DataCon import PrimOp import Id import IdInfo -import NewDemand import Type import Coercion import TyCon @@ -193,47 +191,6 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty %* * %************************************************************************ -mkNote removes redundant coercions, and SCCs where possible - -\begin{code} -#ifdef UNUSED -mkNote :: Note -> CoreExpr -> CoreExpr -mkNote (SCC cc) expr = mkSCC cc expr -mkNote InlineMe expr = mkInlineMe expr -mkNote note expr = Note note expr -#endif -\end{code} - -Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding -that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may -not be *applied* to anything. - -We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper -bindings like - fw = ... - f = inline_me (coerce t fw) -As usual, the inline_me prevents the worker from getting inlined back into the wrapper. -We want the split, so that the coerces can cancel at the call site. - -However, we can get left with tiresome type applications. Notably, consider - f = /\ a -> let t = e in (t, w) -Then lifting the let out of the big lambda gives - t' = /\a -> e - f = /\ a -> let t = inline_me (t' a) in (t, w) -The inline_me is to stop the simplifier inlining t' right back -into t's RHS. In the next phase we'll substitute for t (since -its rhs is trivial) and *then* we could get rid of the inline_me. -But it hardly seems worth it, so I don't bother. - -\begin{code} --- | Wraps the given expression in an inlining hint unless the expression --- is trivial in some sense, so that doing so would usually hurt us -mkInlineMe :: CoreExpr -> CoreExpr -mkInlineMe e@(Var _) = e -mkInlineMe e@(Note InlineMe _) = e -mkInlineMe e = Note InlineMe e -\end{code} - \begin{code} -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr @@ -418,10 +375,9 @@ Similar things can happen (augmented by GADTs) when the Simplifier filters down the matching alternatives in Simplify.rebuildCase. - %************************************************************************ %* * -\subsection{Figuring out things about expressions} + Figuring out things about expressions %* * %************************************************************************ @@ -478,12 +434,11 @@ exprIsTrivial _ = False \begin{code} exprIsDupable :: CoreExpr -> Bool -exprIsDupable (Type _) = True -exprIsDupable (Var _) = True -exprIsDupable (Lit lit) = litIsDupable lit -exprIsDupable (Note InlineMe _) = True -exprIsDupable (Note _ e) = exprIsDupable e -exprIsDupable (Cast e _) = exprIsDupable e +exprIsDupable (Type _) = True +exprIsDupable (Var _) = True +exprIsDupable (Lit lit) = litIsDupable lit +exprIsDupable (Note _ e) = exprIsDupable e +exprIsDupable (Cast e _) = exprIsDupable e exprIsDupable expr = go expr 0 where @@ -530,7 +485,6 @@ exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool exprIsCheap' _ (Lit _) = True exprIsCheap' _ (Type _) = True exprIsCheap' _ (Var _) = True -exprIsCheap' _ (Note InlineMe _) = True exprIsCheap' is_conlike (Note _ e) = exprIsCheap' is_conlike e exprIsCheap' is_conlike (Cast e _) = exprIsCheap' is_conlike e exprIsCheap' is_conlike (Lam x e) = isRuntimeVar x @@ -559,7 +513,7 @@ exprIsCheap' is_conlike other_expr -- Applications and variables go (Var f) args = case idDetails f of RecSelId {} -> go_sel args - ClassOpId _ -> go_sel args + ClassOpId {} -> go_sel args PrimOpId op -> go_primop op args _ | is_conlike f -> go_pap args @@ -597,7 +551,7 @@ exprIsCheap :: CoreExpr -> Bool exprIsCheap = exprIsCheap' isDataConWorkId exprIsExpandable :: CoreExpr -> Bool -exprIsExpandable = exprIsCheap' isConLikeId +exprIsExpandable = exprIsCheap' isConLikeId -- See Note [CONLIKE pragma] in BasicTypes \end{code} \begin{code} @@ -665,6 +619,10 @@ exprOkForSpeculation other_expr -- A bit conservative: we don't really need -- to care about lazy arguments, but this is easy + spec_ok (DFunId new_type) _ = not new_type + -- DFuns terminate, unless the dict is implemented with a newtype + -- in which case they may not + spec_ok _ _ = False -- | True of dyadic operators that can fail only if the second arg is zero! @@ -682,8 +640,9 @@ isDivOp _ = False \end{code} \begin{code} +{- Never used -- omitting -- | True of expressions that are guaranteed to diverge upon execution -exprIsBottom :: CoreExpr -> Bool +exprIsBottom :: CoreExpr -> Bool -- True => definitely bottom exprIsBottom e = go 0 e where -- n is the number of args @@ -699,6 +658,7 @@ exprIsBottom e = go 0 e idAppIsBottom :: Id -> Int -> Bool idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args +-} \end{code} \begin{code} @@ -754,8 +714,8 @@ exprIsHNF _ = False -- There is at least one value argument app_is_value :: CoreExpr -> [CoreArg] -> Bool app_is_value (Var fun) args - = idArity fun > valArgCount args -- Under-applied function - || isDataConWorkId fun -- or data constructor + = idArity fun > valArgCount args -- Under-applied function + || isDataConWorkId fun -- or data constructor app_is_value (Note _ f) as = app_is_value f as app_is_value (Cast f _) as = app_is_value f as app_is_value (App f a) as = app_is_value f (a:as) @@ -854,131 +814,11 @@ dataConInstPat arg_fun fss uniqs con inst_tys mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys --- | Returns @Just (dc, [x1..xn])@ if the argument expression is --- a constructor application of the form @dc x1 .. xn@ -exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr]) -exprIsConApp_maybe (Cast expr co) - = -- Here we do the KPush reduction rule as described in the FC paper - case exprIsConApp_maybe expr of { - Nothing -> Nothing ; - Just (dc, dc_args) -> - - -- The transformation applies iff we have - -- (C e1 ... en) `cast` co - -- where co :: (T t1 .. tn) ~ (T s1 ..sn) - -- That is, with a T at the top of both sides - -- The left-hand one must be a T, because exprIsConApp returned True - -- but the right-hand one might not be. (Though it usually will.) - - let (from_ty, to_ty) = coercionKind co - (from_tc, from_tc_arg_tys) = splitTyConApp from_ty - -- The inner one must be a TyConApp - in - case splitTyConApp_maybe to_ty of { - Nothing -> Nothing ; - Just (to_tc, to_tc_arg_tys) - | from_tc /= to_tc -> Nothing - -- These two Nothing cases are possible; we might see - -- (C x y) `cast` (g :: T a ~ S [a]), - -- where S is a type function. In fact, exprIsConApp - -- will probably not be called in such circumstances, - -- but there't nothing wrong with it - - | otherwise -> - let - tc_arity = tyConArity from_tc - - (univ_args, rest1) = splitAt tc_arity dc_args - (ex_args, rest2) = splitAt n_ex_tvs rest1 - (co_args_spec, rest3) = splitAt n_cos_spec rest2 - (co_args_theta, val_args) = splitAt n_cos_theta rest3 - - arg_tys = dataConRepArgTys dc - dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tyvars = dataConExTyVars dc - dc_eq_spec = dataConEqSpec dc - dc_eq_theta = dataConEqTheta dc - dc_tyvars = dc_univ_tyvars ++ dc_ex_tyvars - n_ex_tvs = length dc_ex_tyvars - n_cos_spec = length dc_eq_spec - n_cos_theta = length dc_eq_theta - - -- Make the "theta" from Fig 3 of the paper - gammas = decomposeCo tc_arity co - new_tys = gammas ++ map (\ (Type t) -> t) ex_args - theta = zipOpenTvSubst dc_tyvars new_tys - - -- First we cast the existential coercion arguments - cast_co_spec (tv, ty) co - = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co - cast_co_theta eqPred (Type co) - | (ty1, ty2) <- getEqPredTys eqPred - = Type $ mkSymCoercion (substTy theta ty1) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty2) - new_co_args = zipWith cast_co_spec dc_eq_spec co_args_spec ++ - zipWith cast_co_theta dc_eq_theta co_args_theta - - -- ...and now value arguments - new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg - - in - ASSERT( length univ_args == tc_arity ) - ASSERT( from_tc == dataConTyCon dc ) - ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) ) - ASSERT( all isTypeArg (univ_args ++ ex_args) ) - ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys ) - - Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args) - }} - -{- --- We do not want to tell the world that we have a --- Cons, to *stop* Case of Known Cons, which removes --- the TickBox. -exprIsConApp_maybe (Note (TickBox {}) expr) - = Nothing -exprIsConApp_maybe (Note (BinaryTickBox {}) expr) - = Nothing --} - -exprIsConApp_maybe (Note _ expr) - = exprIsConApp_maybe expr - -- We ignore InlineMe notes in case we have - -- x = __inline_me__ (a,b) - -- All part of making sure that INLINE pragmas never hurt - -- Marcin tripped on this one when making dictionaries more inlinable - -- - -- In fact, we ignore all notes. For example, - -- case _scc_ "foo" (C a b) of - -- C a b -> e - -- should be optimised away, but it will be only if we look - -- through the SCC note. - -exprIsConApp_maybe expr = analyse (collectArgs expr) - where - analyse (Var fun, args) - | Just con <- isDataConWorkId_maybe fun, - args `lengthAtLeast` dataConRepArity con - -- Might be > because the arity excludes type args - = Just (con,args) - - -- Look through unfoldings, but only cheap ones, because - -- we are effectively duplicating the unfolding - analyse (Var fun, []) - | let unf = idUnfolding fun, - isExpandableUnfolding unf - = exprIsConApp_maybe (unfoldingTemplate unf) - - analyse _ = Nothing \end{code} - - %************************************************************************ %* * -\subsection{Equality} + Equality %* * %************************************************************************ @@ -1007,6 +847,7 @@ exprIsBig :: Expr b -> Bool exprIsBig (Lit _) = False exprIsBig (Var _) = False exprIsBig (Type _) = False +exprIsBig (Lam _ e) = exprIsBig e exprIsBig (App f a) = exprIsBig f || exprIsBig a exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! exprIsBig _ = True @@ -1039,7 +880,6 @@ exprSize (Type t) = seqType t `seq` 1 noteSize :: Note -> Int noteSize (SCC cc) = cc `seq` 1 -noteSize InlineMe = 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int @@ -1195,7 +1035,7 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool -- This is a bit like CoreUtils.exprIsHNF, with the following differences: -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) -- --- b) (C x xs), where C is a contructors is updatable if the application is +-- b) (C x xs), where C is a contructor is updatable if the application is -- dynamic -- -- c) don't look through unfolding of f in (f x). diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 6288b7ea29..3eb9cd98e0 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -160,7 +160,6 @@ make_exp (Case e v ty alts) = do return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts make_exp (Note (SCC _) e) = make_exp e >>= (return . C.Note "SCC") -- temporary make_exp (Note (CoreNote s) e) = make_exp e >>= (return . C.Note s) -- hdaume: core annotations -make_exp (Note InlineMe e) = make_exp e >>= (return . C.Note "InlineMe") make_exp _ = error "MkExternalCore died: make_exp" make_alt :: CoreAlt -> CoreM C.Alt diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 84bf8689c6..55e192d34d 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -32,6 +32,7 @@ import BasicTypes import Util import Outputable import FastString +import Data.Maybe \end{code} %************************************************************************ @@ -215,9 +216,6 @@ ppr_expr add_par (Let bind expr) ppr_expr add_par (Note (SCC cc) expr) = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr]) -ppr_expr add_par (Note InlineMe expr) - = add_par $ ptext (sLit "__inline_me") <+> pprParendExpr expr - ppr_expr add_par (Note (CoreNote s) expr) = add_par $ sep [sep [ptext (sLit "__core_note"), pprHsString (mkFastString s)], @@ -255,11 +253,8 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder | isTyVar binder = pprKindedTyVarBndr binder - | otherwise - = vcat [sig, pprIdExtras binder, pragmas] - where - sig = pprTypedBinder binder - pragmas = ppIdInfo binder (idInfo binder) + | otherwise = pprTypedBinder binder $$ + ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder LambdaBind bndr @@ -274,6 +269,9 @@ pprCoreBinder LambdaBind bndr -- Case bound things don't get a signature or a herald, unless we have debug on pprCoreBinder CaseBind bndr + | isDeadBinder bndr -- False for tyvars + = ptext (sLit "_") + | otherwise = getPprStyle $ \ sty -> if debugStyle sty then parens (pprTypedBinder bndr) @@ -290,7 +288,7 @@ pprTypedBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) pprTypedBinder binder | isTyVar binder = pprKindedTyVarBndr binder - | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder) + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -316,55 +314,111 @@ pprIdBndrInfo info dmd_info = newDemandInfo info lbv_info = lbvarInfo info - no_info = isDefaultInlinePragma prag_info && isNoOcc occ_info && - (case dmd_info of { Nothing -> True; Just d -> isTop d }) && - hasNoLBVarInfo lbv_info - - doc | no_info = empty - | otherwise - = brackets $ hsep [ppr prag_info, ppr occ_info, - ppr dmd_info, ppr lbv_info -#ifdef OLD_STRICTNESS - , ppr (demandInfo id) -#endif - ] + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isNoOcc occ_info) + has_dmd = case dmd_info of { Nothing -> False; Just d -> not (isTop d) } + has_lbv = not (hasNoLBVarInfo lbv_info) + + doc = showAttributes + [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info) + , (has_occ, ptext (sLit "Occ=") <> ppr occ_info) + , (has_dmd, ptext (sLit "Dmd=") <> ppr dmd_info) + , (has_lbv , ptext (sLit "Lbv=") <> ppr lbv_info) + ] \end{code} +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- + \begin{code} -pprIdExtras :: Id -> SDoc -pprIdExtras id = pp_scope <> ppr (idDetails id) +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, ptext (sLit "Arity=") <> int arity) + , (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info) + , (has_strictness, ptext (sLit "Str=") <> pprNewStrictness str_info) + , (has_unf, ptext (sLit "Unf=") <> ppr unf_info) + , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, lbvar info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr where pp_scope | isGlobalId id = ptext (sLit "GblId") | isExportedId id = ptext (sLit "LclIdX") | otherwise = ptext (sLit "LclId") -ppIdInfo :: Id -> IdInfo -> SDoc -ppIdInfo _ info - = brackets $ - vcat [ ppArityInfo a, - ppWorkerInfo (workerInfo info), - ppCafInfo (cafInfo info), -#ifdef OLD_STRICTNESS - ppStrictnessInfo s, - ppCprInfo m, -#endif - pprNewStrictness (newStrictnessInfo info), - if null rules then empty - else ptext (sLit "RULES:") <+> vcat (map pprRule rules) - -- Inline pragma, occ, demand, lbvar info - -- printed out with all binders (when debug is on); - -- see PprCore.pprIdBndr - ] - where - a = arityInfo info -#ifdef OLD_STRICTNESS - s = strictnessInfo info - m = cprInfo info -#endif + arity = arityInfo info + has_arity = arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = newStrictnessInfo info + has_strictness = isJust str_info + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + rules = specInfoRules (specInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] +\end{code} + +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- + +\begin{code} +instance Outputable UnfoldingGuidance where + ppr UnfoldNever = ptext (sLit "NEVER") + ppr UnfoldAlways = ptext (sLit "ALWAYS") + ppr (InlineRule { ug_ir_info = inl_info, ug_small = small }) + = ptext (sLit "InlineRule") <> ppr (inl_info,small) + ppr (UnfoldIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ ptext (sLit "IF_ARGS"), + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable InlineRuleInfo where + ppr (InlWrapper w) = ptext (sLit "worker=") <> ppr w + ppr InlSat = ptext (sLit "sat") + ppr InlUnSat = ptext (sLit "unsat") + +instance Outputable Unfolding where + ppr NoUnfolding = ptext (sLit "No unfolding") + ppr (OtherCon cs) = ptext (sLit "OtherCon") <+> ppr cs + ppr (DFunUnfolding con ops) = ptext (sLit "DFun") <+> ppr con + <+> brackets (pprWithCommas pprParendExpr ops) + ppr (CoreUnfolding { uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf, uf_is_cheap=cheap + , uf_expandable=exp, uf_guidance=g, uf_arity=arity}) + = ptext (sLit "Unf") <> braces (pp_info $$ pp_rhs) + where + pp_info = hsep [ ptext (sLit "TopLvl=") <> ppr top + , ptext (sLit "Arity=") <> int arity + , ptext (sLit "Value=") <> ppr hnf + , ptext (sLit "Cheap=") <> ppr cheap + , ptext (sLit "Expandable=") <> ppr exp + , ppr g ] + pp_rhs = case g of + UnfoldNever -> usually_empty + UnfoldIfGoodArgs {} -> usually_empty + _other -> ppr rhs + usually_empty = ifPprDebug (ppr rhs) + -- In this case show 'rhs' only in debug mode \end{code} +----------------------------------------------------- +-- Rules +----------------------------------------------------- \begin{code} instance Outputable CoreRule where diff --git a/compiler/cprAnalysis/CprAnalyse.lhs b/compiler/cprAnalysis/CprAnalyse.lhs index f28336b2c6..14c80176d4 100644 --- a/compiler/cprAnalysis/CprAnalyse.lhs +++ b/compiler/cprAnalysis/CprAnalyse.lhs @@ -14,7 +14,7 @@ module CprAnalyse ( cprAnalyse ) where #include "HsVersions.h" import DynFlags -import CoreLint +import CoreMonad import CoreSyn import CoreUtils import Id @@ -142,7 +142,7 @@ cprAnalyse dflags binds showPass dflags "Constructed Product analysis" ; let { binds_plus_cpr = do_prog binds } ; endPass dflags "Constructed Product analysis" - Opt_D_dump_cpranal binds_plus_cpr + Opt_D_dump_cpranal binds_plus_cpr [] return binds_plus_cpr } where diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 521d1ad401..7e284ae949 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -27,10 +27,8 @@ import DsExpr () -- Forces DsExpr to be compiled; DsBinds only import Module import RdrName import NameSet -import VarSet import Rules -import CoreLint -import CoreFVs +import CoreMonad ( endPass ) import ErrUtils import Outputable import SrcLoc @@ -107,7 +105,7 @@ deSugar hsc_env { -- Add export flags to bindings keep_alive <- readIORef keep_var ; let final_prs = addExportFlags target export_set - keep_alive all_prs ds_rules + keep_alive all_prs ds_binds = [Rec final_prs] -- Notice that we put the whole lot in a big Rec, even the foreign binds -- When compiling PrelFloat, which defines data Float = F# Float# @@ -116,7 +114,7 @@ deSugar hsc_env -- things into the in-scope set before simplifying; so we get no unfolding for F#! -- Lint result if necessary - ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds + ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds ds_rules -- Dump output ; doIfSet (dopt Opt_D_dump_ds dflags) @@ -206,26 +204,17 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do -- it's just because the type checker is rather busy already and -- I didn't want to pass in yet another mapping. -addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [CoreRule] +addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)] -> [(Id, t)] -addExportFlags target exports keep_alive prs rules +addExportFlags target exports keep_alive prs = [(add_export bndr, rhs) | (bndr,rhs) <- prs] where add_export bndr | dont_discard bndr = setIdExported bndr | otherwise = bndr - orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule - | rule <- rules, - not (isLocalRule rule) ] - -- A non-local rule keeps alive the free vars of its right-hand side. - -- (A "non-local" is one whose head function is not locally defined.) - -- Local rules are (later, after gentle simplification) - -- attached to the Id, and that keeps the rhs free vars alive. - dont_discard bndr = is_exported name || name `elemNameSet` keep_alive - || bndr `elemVarSet` orph_rhs_fvs where name = idName bndr @@ -260,7 +249,10 @@ dsRule :: LRuleDecl Id -> DsM (Maybe CoreRule) dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) = putSrcSpanDs loc $ do { let bndrs' = [var | RuleBndr (L _ var) <- vars] - ; lhs' <- dsLExpr lhs + + ; lhs' <- unsetOptM Opt_EnableRewriteRules $ + dsLExpr lhs -- Note [Desugaring RULE lhss] + ; rhs' <- dsLExpr rhs -- Substitute the dict bindings eagerly, @@ -273,15 +265,21 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs)) -- NB: isLocalId is False of implicit Ids. This is good becuase -- we don't want to attach rules to the bindings of implicit Ids, -- because they don't show up in the bindings until just before code gen - fn_name = idName fn_id - - rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act, - ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', - ru_rough = roughTopNames args, - ru_local = local_rule } + fn_name = idName fn_id + rule = mkRule local_rule name act fn_name bndrs args rhs' ; return (Just rule) } } } where msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar; ignored")) 2 (ppr lhs) \end{code} + +Note [Desugaring RULE left hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the LHS of a RULE we do *not* want to desugar + [x] to build (\cn. x `c` n) +We want to leave explicit lists simply as chains +of cons's. We can achieve that slightly indirectly by +switching off EnableRewriteRules. + +That keeps the desugaring of list comprehensions simple too. diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 515ac8565f..0222594095 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -17,18 +17,19 @@ module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, #include "HsVersions.h" -import {-# SOURCE #-} DsExpr( dsLExpr, dsExpr ) +import {-# SOURCE #-} DsExpr( dsLExpr ) import {-# SOURCE #-} Match( matchWrapper ) import DsMonad import DsGRHSs import DsUtils -import OccurAnal import HsSyn -- lots of things import CoreSyn -- lots of things +import CoreSubst import MkCore import CoreUtils +import CoreUnfold import CoreFVs import TcType @@ -38,6 +39,7 @@ import Module import Id import MkId ( seqId ) import Var ( Var, TyVar, tyVarKind ) +import IdInfo ( vanillaIdInfo ) import VarSet import Rules import VarEnv @@ -48,8 +50,9 @@ import Bag import BasicTypes hiding ( TopLevel ) import FastString import StaticFlags ( opt_DsMultiTyVar ) -import Util ( mapSnd, mapAndUnzip, lengthExceeds ) +import Util ( count, lengthExceeds ) +import MonadUtils import Control.Monad import Data.List \end{code} @@ -70,6 +73,7 @@ dsLHsBinds binds = ds_lhs_binds NoSccs binds ------------------------ ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)] + -- scc annotation policy (see below) ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds) @@ -85,25 +89,30 @@ dsHsBind :: AutoScc -> HsBind Id -> DsM [(Id,CoreExpr)] -- Result -dsHsBind _ rest (VarBind var expr) = do - core_expr <- dsLExpr expr +dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) + = do { core_expr <- dsLExpr expr + + -- Dictionary bindings are always VarBinds, + -- so we only need do this here + ; core_expr' <- addDictScc var core_expr + ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr' + | otherwise = var - -- Dictionary bindings are always VarMonoBinds, so - -- we only need do this here - core_expr' <- addDictScc var core_expr - return ((var, core_expr') : rest) + ; return ((var', core_expr') : rest) } -dsHsBind _ rest (FunBind { fun_id = L _ fun, fun_matches = matches, - fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) = do - (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches - body' <- mkOptTickBox tick body - rhs <- dsCoercion co_fn (return (mkLams args body')) - return ((fun,rhs) : rest) +dsHsBind _ rest + (FunBind { fun_id = L _ fun, fun_matches = matches, + fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) + = do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches + ; body' <- mkOptTickBox tick body + ; wrap_fn' <- dsCoercion co_fn + ; return ((fun, wrap_fn' (mkLams args body')) : rest) } -dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = do - body_expr <- dsGuarded grhss ty - sel_binds <- mkSelectorBinds pat body_expr - return (sel_binds ++ rest) +dsHsBind _ rest + (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) + = do { body_expr <- dsGuarded grhss ty + ; sel_binds <- mkSelectorBinds pat body_expr + ; return (sel_binds ++ rest) } {- Note [Rules and inlining] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -132,10 +141,15 @@ dsHsBind _ rest (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) = dsHsBind auto_scc rest (AbsBinds [] [] exports binds) = do { core_prs <- ds_lhs_binds NoSccs binds ; let env = mkABEnv exports - do_one (lcl_id, rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id - = addInlinePrags prags gbl_id $ - addAutoScc auto_scc gbl_id rhs - | otherwise = (lcl_id, rhs) + ar_env = mkArityEnv binds + do_one (lcl_id, rhs) + | Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id + = ASSERT( null spec_prags ) -- Not overloaded + makeCorePair gbl_id (lookupArity ar_env lcl_id) $ + addAutoScc auto_scc gbl_id rhs + + | otherwise = (lcl_id, rhs) + locals' = [(lcl_id, Var gbl_id) | (_, gbl_id, lcl_id, _) <- exports] -- Note [Rules and inlining] ; return (map do_one core_prs ++ locals' ++ rest) } @@ -192,63 +206,74 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds) -- see if it has any impact; it is on by default = -- Note [Abstracting over tyvars only] do { core_prs <- ds_lhs_binds NoSccs binds - ; ; let arby_env = mkArbitraryTypeEnv tyvars exports - (lg_binds, core_prs') = mapAndUnzip do_one core_prs bndrs = mkVarSet (map fst core_prs) add_lets | core_prs `lengthExceeds` 10 = add_some - | otherwise = mkLets lg_binds - add_some rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds - , b `elemVarSet` fvs] rhs + | otherwise = mkLets + add_some lg_binds rhs = mkLets [ NonRec b r | NonRec b r <- lg_binds + , b `elemVarSet` fvs] rhs where fvs = exprSomeFreeVars (`elemVarSet` bndrs) rhs + ar_env = mkArityEnv binds env = mkABEnv exports - do_one (lcl_id, rhs) - | Just (id_tvs, gbl_id, _, prags) <- lookupVarEnv env lcl_id - = (NonRec lcl_id (mkTyApps (Var gbl_id) (mkTyVarTys id_tvs)), - addInlinePrags prags gbl_id $ - addAutoScc auto_scc gbl_id $ - mkLams id_tvs $ - mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv)) - | tv <- tyvars, not (tv `elem` id_tvs)] $ - add_lets rhs) + mk_lg_bind lcl_id gbl_id tyvars + = NonRec (setIdInfo lcl_id vanillaIdInfo) + -- Nuke the IdInfo so that no old unfoldings + -- confuse use (it might mention something not + -- even in scope at the new site + (mkTyApps (Var gbl_id) (mkTyVarTys tyvars)) + + do_one lg_binds (lcl_id, rhs) + | Just (id_tvs, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id + = ASSERT( null spec_prags ) -- Not overloaded + let rhs' = addAutoScc auto_scc gbl_id $ + mkLams id_tvs $ + mkLets [ NonRec tv (Type (lookupVarEnv_NF arby_env tv)) + | tv <- tyvars, not (tv `elem` id_tvs)] $ + add_lets lg_binds rhs + in return (mk_lg_bind lcl_id gbl_id id_tvs, + makeCorePair gbl_id (lookupArity ar_env lcl_id) rhs') | otherwise - = (NonRec lcl_id (mkTyApps (Var non_exp_gbl_id) (mkTyVarTys tyvars)), - (non_exp_gbl_id, mkLams tyvars (add_lets rhs))) - where - non_exp_gbl_id = setIdType lcl_id (mkForAllTys tyvars (idType lcl_id)) + = do { non_exp_gbl_id <- newUniqueId lcl_id (mkForAllTys tyvars (idType lcl_id)) + ; return (mk_lg_bind lcl_id non_exp_gbl_id tyvars, + (non_exp_gbl_id, mkLams tyvars (add_lets lg_binds rhs))) } + ; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs) ; return (core_prs' ++ rest) } -- Another common case: one exported variable -- Non-recursive bindings come through this way + -- So do self-recursive bindings, and recursive bindings + -- that have been chopped up with type signatures dsHsBind auto_scc rest (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds) - = ASSERT( all (`elem` tyvars) all_tyvars ) do - core_prs <- ds_lhs_binds NoSccs binds - let - -- Always treat the binds as recursive, because the typechecker - -- makes rather mixed-up dictionary bindings - core_bind = Rec core_prs + = ASSERT( all (`elem` tyvars) all_tyvars ) + do { core_prs <- ds_lhs_binds NoSccs binds + + ; let -- Always treat the binds as recursive, because the typechecker + -- makes rather mixed-up dictionary bindings + core_bind = Rec core_prs + inl_arity = lookupArity (mkArityEnv binds) local - mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global local core_bind) prags - let - (spec_binds, rules) = unzip (catMaybes mb_specs) - global' = addIdSpecialisations global rules - rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local) - bind = addInlinePrags prags global' $ addAutoScc auto_scc global' rhs' + ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global + local inl_arity core_bind prags + + ; let global' = addIdSpecialisations global rules + rhs = addAutoScc auto_scc global $ + mkLams tyvars $ mkLams dicts $ Let core_bind (Var local) + main_bind = makeCorePair global' (inl_arity + dictArity dicts) rhs - return (bind : spec_binds ++ rest) + ; return (main_bind : spec_binds ++ rest) } dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) = do { core_prs <- ds_lhs_binds NoSccs binds ; let env = mkABEnv exports - do_one (lcl_id,rhs) | Just (_, gbl_id, _, prags) <- lookupVarEnv env lcl_id - = addInlinePrags prags lcl_id $ - addAutoScc auto_scc gbl_id rhs + ar_env = mkArityEnv binds + do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id + = (lcl_id, addAutoScc auto_scc gbl_id rhs) | otherwise = (lcl_id,rhs) -- Rec because of mixed-up dictionary bindings @@ -263,18 +288,17 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) ; poly_tup_id <- newSysLocalDs (exprType poly_tup_expr) - ; let mk_bind ((tyvars, global, local, prags), n) -- locals!!n == local + ; let mk_bind ((tyvars, global, local, spec_prags), n) -- locals!!n == local = -- Need to make fresh locals to bind in the selector, -- because some of the tyvars will be bound to 'Any' do { let ty_args = map mk_ty_arg all_tyvars substitute = substTyWith all_tyvars ty_args ; locals' <- newSysLocalsDs (map substitute local_tys) ; tup_id <- newSysLocalDs (substitute tup_ty) - ; mb_specs <- mapM (dsSpec all_tyvars dicts tyvars global - local core_bind) - prags - ; let (spec_binds, rules) = unzip (catMaybes mb_specs) - global' = addIdSpecialisations global rules + ; (spec_binds, rules) <- dsSpecs all_tyvars dicts tyvars global local + (lookupArity ar_env local) core_bind + spec_prags + ; let global' = addIdSpecialisations global rules rhs = mkLams tyvars $ mkLams dicts $ mkTupleSelector locals' (locals' !! n) tup_id $ mkVarApps (mkTyApps (Var poly_tup_id) ty_args) @@ -286,23 +310,85 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds) | otherwise = dsMkArbitraryType all_tyvar ; export_binds_s <- mapM mk_bind (exports `zip` [0..]) - -- don't scc (auto-)annotate the tuple itself. + -- Don't scc (auto-)annotate the tuple itself. ; return ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest)) } -mkABEnv :: [([TyVar], Id, Id, [LPrag])] -> VarEnv ([TyVar], Id, Id, [LPrag]) +------------------------ +makeCorePair :: Id-> Arity -> CoreExpr -> (Id, CoreExpr) +makeCorePair gbl_id arity rhs + = (addInline gbl_id arity rhs, rhs) + +------------------------ +type AbsBindEnv = VarEnv ([TyVar], Id, Id, [LSpecPrag]) + -- Maps the "lcl_id" for an AbsBind to + -- its "gbl_id" and associated pragmas, if any + +mkABEnv :: [([TyVar], Id, Id, [LSpecPrag])] -> AbsBindEnv -- Takes the exports of a AbsBinds, and returns a mapping -- lcl_id -> (tyvars, gbl_id, lcl_id, prags) mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports] +mkArityEnv :: LHsBinds Id -> IdEnv Arity + -- Maps a local to the arity of its definition +mkArityEnv binds = foldrBag (plusVarEnv . lhsBindArity) emptyVarEnv binds + +lhsBindArity :: LHsBind Id -> IdEnv Arity +lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) + = unitVarEnv (unLoc id) (matchGroupArity ms) +lhsBindArity (L _ (AbsBinds { abs_exports = exports + , abs_dicts = dicts + , abs_binds = binds })) + = mkVarEnv [ (gbl, lookupArity ar_env lcl + n_val_dicts) + | (_, gbl, lcl, _) <- exports] + where -- See Note [Nested arities] + ar_env = mkArityEnv binds + n_val_dicts = dictArity dicts + +lhsBindArity _ = emptyVarEnv -- PatBind/VarBind + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts + +lookupArity :: IdEnv Arity -> Id -> Arity +lookupArity ar_env id = lookupVarEnv ar_env id `orElse` 0 + +addInline :: Id -> Arity -> CoreExpr -> Id +addInline id arity rhs + | isInlinePragma (idInlinePragma id) + -- Add an Unfolding for an INLINE (but not for NOINLINE) + = id `setIdUnfolding` mkInlineRule InlSat rhs arity + | otherwise + = id +\end{code} + +Nested arities +~~~~~~~~~~~~~~ +For reasons that are not entirely clear, method bindings come out looking like +this: + + AbsBinds [] [] [$cfromT <= [] fromT] + $cfromT [InlPrag=INLINE] :: T Bool -> Bool + { AbsBinds [] [] [fromT <= [] fromT_1] + fromT :: T Bool -> Bool + { fromT_1 ((TBool b)) = not b } } } + +Note the nested AbsBind. The arity for the InlineRule on $cfromT should be +gotten from the binding for fromT_1. + +It might be better to have just one level of AbsBinds, but that requires more +thought! -dsSpec :: [TyVar] -> [DictId] -> [TyVar] - -> Id -> Id -- Global, local - -> CoreBind -> LPrag - -> DsM (Maybe ((Id,CoreExpr), -- Binding for specialised Id - CoreRule)) -- Rule for the Global Id +\begin{code} +------------------------ +dsSpecs :: [TyVar] -> [DictId] -> [TyVar] + -> Id -> Id -> Arity -- Global, local, arity of local + -> CoreBind -> [LSpecPrag] + -> DsM ( [(Id,CoreExpr)] -- Binding for specialised Ids + , [CoreRule] ) -- Rules for the Global Ids -- Example: -- f :: (Eq a, Ix b) => a -> b -> b -- {-# SPECIALISE f :: Ix b => Int -> b -> b #-} @@ -326,46 +412,60 @@ dsSpec :: [TyVar] -> [DictId] -> [TyVar] -- -- It is *possible* that 'es' does not mention all of the dictionaries 'ds' -- (a bit silly, because then the -dsSpec _ _ _ _ _ _ (L _ (InlinePrag {})) - = return Nothing - -dsSpec all_tvs dicts tvs poly_id mono_id mono_bind - (L loc (SpecPrag spec_expr spec_ty inl)) - = putSrcSpanDs loc $ - do { let poly_name = idName poly_id - ; spec_name <- newLocalName poly_name - ; ds_spec_expr <- dsExpr spec_expr - ; case (decomposeRuleLhs ds_spec_expr) of { - Nothing -> do { warnDs decomp_msg; return Nothing } ; - - Just (bndrs, _fn, args) -> - - -- Check for dead binders: Note [Unused spec binders] - case filter isDeadBinder bndrs of { - bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } - | otherwise -> do - - { let f_body = fix_up (Let mono_bind (Var mono_id)) - - local_poly = setIdNotExported poly_id - -- Very important to make the 'f' non-exported, - -- else it won't be inlined! - spec_id = mkLocalId spec_name spec_ty - spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr - poly_f_body = mkLams (tvs ++ dicts) f_body - - extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts] - | d <- varSetElems (exprFreeVars ds_spec_expr) - , isDictId d] - -- Note [Const rule dicts] - - rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) - AlwaysActive poly_name - (extra_dict_bndrs ++ bndrs) args - (mkVarApps (Var spec_id) bndrs) - ; return (Just (addInlineInfo inl spec_id spec_rhs, rule)) - } } } } - where + +dsSpecs all_tvs dicts tvs poly_id mono_id inl_arity mono_bind prags + = do { pairs <- mapMaybeM spec_one prags + ; let (spec_binds_s, rules) = unzip pairs + ; return (concat spec_binds_s, rules) } + where + spec_one :: LSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule)) + spec_one (L loc (SpecPrag spec_co spec_inl)) + = putSrcSpanDs loc $ + do { let poly_name = idName poly_id + ; spec_name <- newLocalName poly_name + ; wrap_fn <- dsCoercion spec_co + ; let ds_spec_expr = wrap_fn (Var poly_id) + ; case decomposeRuleLhs ds_spec_expr of { + Nothing -> do { warnDs (decomp_msg spec_co) + ; return Nothing } ; + + Just (bndrs, _fn, args) -> + + -- Check for dead binders: Note [Unused spec binders] + case filter isDeadBinder bndrs of { + bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } + | otherwise -> do + + { (spec_unf, unf_pairs) <- specUnfolding wrap_fn (idUnfolding poly_id) + + ; let f_body = fix_up (Let mono_bind (Var mono_id)) + spec_ty = exprType ds_spec_expr + spec_id = mkLocalId spec_name spec_ty + `setInlinePragma` inl_prag + `setIdUnfolding` spec_unf + inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id + | otherwise = spec_inl + -- Get the INLINE pragma from SPECIALISE declaration, or, + -- failing that, from the original Id + + spec_id_arity = inl_arity + count isDictId bndrs + + extra_dict_bndrs = [ localiseId d -- See Note [Constant rule dicts] + | d <- varSetElems (exprFreeVars ds_spec_expr) + , isDictId d] + -- Note [Const rule dicts] + + rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name))) + AlwaysActive poly_name + (extra_dict_bndrs ++ bndrs) args + (mkVarApps (Var spec_id) bndrs) + + spec_rhs = wrap_fn (mkLams (tvs ++ dicts) f_body) + spec_pair = makeCorePair spec_id spec_id_arity spec_rhs + + ; return (Just (spec_pair : unf_pairs, rule)) + } } } } + -- Bind to Any any of all_ptvs that aren't -- relevant for this particular function fix_up body | null void_tvs = body @@ -380,10 +480,19 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind , ptext (sLit "SPECIALISE pragma ignored")] get_pred b = ASSERT( isId b ) expectJust "dsSpec" (tcSplitPredTy_maybe (idType b)) - decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored")) - 2 (ppr spec_expr) + decomp_msg spec_co + = hang (ptext (sLit "Specialisation too complicated to desugar; ignored")) + 2 (pprHsWrapper (ppr poly_id) spec_co) +specUnfolding :: (CoreExpr -> CoreExpr) -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)]) +specUnfolding wrap_fn (DFunUnfolding con ops) + = do { let spec_rhss = map wrap_fn ops + ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss + ; return (DFunUnfolding con (map Var spec_ids), spec_ids `zip` spec_rhss) } +specUnfolding _ _ + = return (noUnfolding, []) + mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type -- If any of the tyvars is missing from any of the lists in -- the second arg, return a binding in the result @@ -431,7 +540,7 @@ So for example when you have {-# SPECIALISE f :: Int -> Int #-} Then we get the SpecPrag - SpecPrag (f Int dInt) Int + SpecPrag (f Int dInt) And from that we want the rule @@ -457,81 +566,31 @@ decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr]) -- That is, the RULE binders are lambda-bound -- Returns Nothing if the LHS isn't of the expected shape decomposeRuleLhs lhs - = case (decomp emptyVarEnv body) of - Nothing -> Nothing - Just (fn, args) -> Just (bndrs, fn, args) - where - occ_lhs = occurAnalyseExpr lhs - -- The occurrence-analysis does two things - -- (a) identifies unused binders: Note [Unused spec binders] - -- (b) sorts dict bindings into NonRecs - -- so they can be inlined by 'decomp' - (bndrs, body) = collectBinders occ_lhs - - -- Substitute dicts in the LHS args, so that there - -- aren't any lets getting in the way - -- Note that we substitute the function too; we might have this as - -- a LHS: let f71 = M.f Int in f71 - decomp env (Let (NonRec dict rhs) body) - = decomp (extendVarEnv env dict (simpleSubst env rhs)) body - - decomp env (Case scrut bndr ty [(DEFAULT, _, body)]) - | isDeadBinder bndr -- Note [Matching seqId] - = Just (seqId, [Type (idType bndr), Type ty, - simpleSubst env scrut, simpleSubst env body]) - - decomp env body - = case collectArgs (simpleSubst env body) of - (Var fn, args) -> Just (fn, args) - _ -> Nothing - -simpleSubst :: IdEnv CoreExpr -> CoreExpr -> CoreExpr --- Similar to CoreSubst.substExpr, except that --- (a) Takes no account of capture; at this point there is no shadowing --- (b) Can have a GlobalId (imported) in its domain --- (c) Ids only; no types are substituted --- (d) Does not insist (as does CoreSubst.lookupIdSubst) that the --- in-scope set mentions all LocalIds mentioned in the argument of the subst --- --- (b) and (d) are the reasons we can't use CoreSubst --- --- (I had a note that (b) is "no longer relevant", and indeed it doesn't --- look relevant here. Perhaps there was another caller of simpleSubst.) + = case collectArgs body of + (Var fn, args) -> Just (bndrs, fn, args) -simpleSubst subst expr - = go expr - where - go (Var v) = lookupVarEnv subst v `orElse` Var v - go (Cast e co) = Cast (go e) co - go (Type ty) = Type ty - go (Lit lit) = Lit lit - go (App fun arg) = App (go fun) (go arg) - go (Note note e) = Note note (go e) - go (Lam bndr body) = Lam bndr (go body) - go (Let (NonRec bndr rhs) body) = Let (NonRec bndr (go rhs)) (go body) - go (Let (Rec pairs) body) = Let (Rec (mapSnd go pairs)) (go body) - go (Case scrut bndr ty alts) = Case (go scrut) bndr ty - [(c,bs,go r) | (c,bs,r) <- alts] - -addInlinePrags :: [LPrag] -> Id -> CoreExpr -> (Id,CoreExpr) -addInlinePrags prags bndr rhs - = case [inl | L _ (InlinePrag inl) <- prags] of - [] -> (bndr, rhs) - (inl:_) -> addInlineInfo inl bndr rhs - -addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr) -addInlineInfo (Inline prag is_inline) bndr rhs - = (attach_pragma bndr prag, wrap_inline is_inline rhs) + (Case scrut bndr ty [(DEFAULT, _, body)], args) + | isDeadBinder bndr -- Note [Matching seqId] + -> Just (bndrs, seqId, args' ++ args) + where + args' = [Type (idType bndr), Type ty, scrut, body] + + _other -> Nothing -- Unexpected shape where - attach_pragma bndr prag - | isDefaultInlinePragma prag = bndr - | otherwise = bndr `setInlinePragma` prag - - wrap_inline True body = mkInlineMe body - wrap_inline False body = body + (bndrs, body) = collectBinders (simpleOptExpr lhs) + -- simpleOptExpr occurrence-analyses and simplifies the lhs + -- and thereby + -- (a) identifies unused binders: Note [Unused spec binders] + -- (b) sorts dict bindings into NonRecs + -- so they can be inlined by 'decomp' + -- (c) substitute trivial lets so that they don't get in the way + -- Note that we substitute the function too; we might + -- have this as a LHS: let f71 = M.f Int in f71 + -- NB: tcSimplifyRuleLhs is very careful not to generate complicated + -- dictionary expressions that we might have to match \end{code} -Note [Matching seq] +Note [Matching seqId] ~~~~~~~~~~~~~~~~~~~ The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack and this code turns it back into an application of seq! @@ -589,25 +648,19 @@ addDictScc _ rhs = return rhs \begin{code} -dsCoercion :: HsWrapper -> DsM CoreExpr -> DsM CoreExpr -dsCoercion WpHole thing_inside = thing_inside -dsCoercion (WpCompose c1 c2) thing_inside = dsCoercion c1 (dsCoercion c2 thing_inside) -dsCoercion (WpCast co) thing_inside = do { expr <- thing_inside - ; return (Cast expr co) } -dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside - ; return (Lam id expr) } -dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside - ; return (Lam tv expr) } -dsCoercion (WpApp v) thing_inside - | isTyVar v = do { expr <- thing_inside - {- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) } - | otherwise = do { expr <- thing_inside - {- An Id -} ; return (App expr (Var v)) } -dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside - ; return (App expr (Type ty)) } -dsCoercion WpInline thing_inside = do { expr <- thing_inside - ; return (mkInlineMe expr) } -dsCoercion (WpLet bs) thing_inside = do { prs <- dsLHsBinds bs - ; expr <- thing_inside - ; return (Let (Rec prs) expr) } +dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr) +dsCoercion WpHole = return (\e -> e) +dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1 + ; k2 <- dsCoercion c2 + ; return (k1 . k2) } +dsCoercion (WpCast co) = return (\e -> Cast e co) +dsCoercion (WpLam id) = return (\e -> Lam id e) +dsCoercion (WpTyLam tv) = return (\e -> Lam tv e) +dsCoercion (WpApp v) | isTyVar v -- Probably a coercion var + = return (\e -> App e (Type (mkTyVarTy v))) + | otherwise + = return (\e -> App e (Var v)) +dsCoercion (WpTyApp ty) = return (\e -> App e (Type ty)) +dsCoercion (WpLet bs) = do { prs <- dsLHsBinds bs + ; return (\e -> Let (Rec prs) e) } \end{code} diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 6d7d7622d3..94009fd1fa 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -51,6 +51,7 @@ import StaticFlags import CostCentre import Id import Var +import VarSet import PrelInfo import DataCon import TysWiredIn @@ -210,7 +211,9 @@ dsExpr (HsVar var) = return (Var var) dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsWrap co_fn e) = dsCoercion co_fn (dsExpr e) +dsExpr (HsWrap co_fn e) = do { co_fn' <- dsCoercion co_fn + ; e' <- dsExpr e + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -645,7 +648,6 @@ makes all list literals be generated via the simple route. \begin{code} - dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr -- See Note [Desugaring explicit lists] dsExplicitList elt_ty xs diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index 83dac63491..53400393f5 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -19,6 +19,7 @@ import DsMonad import HsSyn import DataCon import CoreUtils +import CoreUnfold import Id import Literal import Module @@ -205,9 +206,10 @@ dsFCall fn_id fcall = do -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers - wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body) + wrap_rhs = mkLams (tvs ++ args) wrapper_body + fn_id_w_inl = fn_id `setIdUnfolding` mkInlineRule InlSat wrap_rhs (length args) - return ([(work_id, work_rhs), (fn_id, wrap_rhs)], empty, empty) + return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs)], empty, empty) \end{code} @@ -567,8 +569,8 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc <> comma <> text "cap") <> semi , assignCResult , ptext (sLit "rts_unlock(cap);") - , if res_hty_is_unit then empty - else if libffi + , ppUnless res_hty_is_unit $ + if libffi then char '*' <> parens (cResType <> char '*') <> ptext (sLit "resp = cret;") else ptext (sLit "return cret;") diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 162e90fa01..d0d3f4c788 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -36,11 +36,11 @@ import PrelNames -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using -- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) import Module import Id -import Name +import Name hiding( isVarOcc, isTcOcc, varName, tcName ) import NameEnv import TcType import TyCon @@ -435,35 +435,38 @@ rep_proto nm ty loc ; return [(loc, sig)] } -rep_inline :: Located Name -> InlineSpec -> SrcSpan +rep_inline :: Located Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_inline nm ispec loc = do { nm1 <- lookupLOcc nm - ; (_, ispec1) <- rep_InlineSpec ispec + ; ispec1 <- rep_InlinePrag ispec ; pragma <- repPragInl nm1 ispec1 ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan +rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm ; ty1 <- repLTy ty - ; (hasSpec, ispec1) <- rep_InlineSpec ispec - ; pragma <- if hasSpec - then repPragSpecInl nm1 ty1 ispec1 - else repPragSpec nm1 ty1 + ; pragma <- if isDefaultInlinePragma ispec + then repPragSpec nm1 ty1 -- SPECIALISE + else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE + ; repPragSpecInl nm1 ty1 ispec1 } ; return [(loc, pragma)] } --- extract all the information needed to build a TH.InlineSpec +-- Extract all the information needed to build a TH.InlinePrag -- -rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ) -rep_InlineSpec (Inline (InlinePragma activation match) inline) +rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma + -> DsM (Core TH.InlineSpecQ) +rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline }) | Nothing <- activation1 - = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1 + = repInlineSpecNoPhase inline1 match1 | Just (flag, phase) <- activation1 - = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase + = repInlineSpecPhase inline1 match1 flag phase | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec" where match1 = coreBool (rep_RuleMatchInfo match) @@ -473,8 +476,8 @@ rep_InlineSpec (Inline (InlinePragma activation match) inline) rep_RuleMatchInfo FunLike = False rep_RuleMatchInfo ConLike = True - rep_Activation NeverActive = Nothing - rep_Activation AlwaysActive = Nothing + rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive + rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive rep_Activation (ActiveBefore phase) = Just (coreBool False, MkC $ mkIntExprInt phase) rep_Activation (ActiveAfter phase) = Just (coreBool True, diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index fa968119bd..5245eaaaa6 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -9,7 +9,7 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, - foldlM, foldrM, ifOptM, + foldlM, foldrM, ifOptM, unsetOptM, Applicative(..),(<$>), newLocalName, @@ -221,8 +221,8 @@ it easier to read debugging output. \begin{code} -- Make a new Id with the same print name, but different type, and new unique -newUniqueId :: Name -> Type -> DsM Id -newUniqueId id = mkSysLocalM (occNameFS (nameOccName id)) +newUniqueId :: Id -> Type -> DsM Id +newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id))) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index d90f9048c3..d6769118c6 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -344,10 +344,11 @@ matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the coercion to the match variable and then match that matchCoercion (var:vars) ty (eqns@(eqn1:_)) = do { let CoPat co pat _ = firstPat eqn1 - ; var' <- newUniqueId (idName var) (hsPatType pat) + ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns) - ; rhs <- dsCoercion co (return (Var var)) - ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) } + ; co' <- dsCoercion co + ; let rhs' = co' (Var var) + ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) } matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -- Apply the view function to the match variable and then match that @@ -357,7 +358,7 @@ matchView (var:vars) ty (eqns@(eqn1:_)) -- to figure out the type of the fresh variable let ViewPat viewExpr (L _ pat) _ = firstPat eqn1 -- do the rest of the compilation - ; var' <- newUniqueId (idName var) (hsPatType pat) + ; var' <- newUniqueId var (hsPatType pat) ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns) -- compile the view expressions ; viewExpr' <- dsLExpr viewExpr diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 56ec2d763d..0ff26917ed 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -394,20 +394,22 @@ cvtPragmaD (SpecialiseP nm ty opt_ispec) ; ty' <- cvtType ty ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) } -cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlineSpec +cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma cvtInlineSpec Nothing - = defaultInlineSpec + = defaultInlinePragma cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) - = mkInlineSpec opt_activation' matchinfo inline + = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo, inl_inline = inline } where matchinfo = cvtRuleMatchInfo conlike - opt_activation' = fmap cvtActivation opt_activation + opt_activation' = cvtActivation opt_activation cvtRuleMatchInfo False = FunLike cvtRuleMatchInfo True = ConLike - cvtActivation (False, phase) = ActiveBefore phase - cvtActivation (True , phase) = ActiveAfter phase + cvtActivation Nothing | inline = AlwaysActive + | otherwise = NeverActive + cvtActivation (Just (False, phase)) = ActiveBefore phase + cvtActivation (Just (True , phase)) = ActiveAfter phase --------------------------------------------------- -- Declarations diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index 0cf796692e..a6d8523e93 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -16,7 +16,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. module HsBinds where -import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, +import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, MatchGroup, pprFunBind, GRHSs, pprPatBind ) import {-# SOURCE #-} HsPat ( LPat ) @@ -130,8 +130,10 @@ data HsBindLR idL idR } | VarBind { -- Dictionary binding and suchlike - var_id :: idL, -- All VarBinds are introduced by the type checker - var_rhs :: LHsExpr idR -- Located only for consistency + var_id :: idL, -- All VarBinds are introduced by the type checker + var_rhs :: LHsExpr idR, -- Located only for consistency + var_inline :: Bool -- True <=> inline this binding regardless + -- (used for implication constraints only) } | AbsBinds { -- Binds abstraction; TRANSLATION @@ -141,7 +143,7 @@ data HsBindLR idL idR -- AbsBinds only gets used when idL = idR after renaming, -- but these need to be idL's for the collect... code in HsUtil to have -- the right type - abs_exports :: [([TyVar], idL, idL, [LPrag])], -- (tvs, poly_id, mono_id, prags) + abs_exports :: [([TyVar], idL, idL, [LSpecPrag])], -- (tvs, poly_id, mono_id, prags) abs_binds :: LHsBinds idL -- The dictionary bindings and typechecked user bindings -- mixed up together; you can tell the dict bindings because -- they are all VarBinds @@ -363,7 +365,6 @@ data HsWrapper | WpLam Var -- \d. [] the 'd' is a type-class dictionary or coercion variable | WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var) - | WpInline -- inline_me [] Wrap inline around the thing -- Non-empty bindings, so that the identity coercion -- is always exactly WpHole @@ -384,7 +385,6 @@ pprHsWrapper it wrap = help it (WpLam id) = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it] help it (WpTyLam tv) = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it] help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it] - help it WpInline = sep [ptext (sLit "_inline_me_"), it] in -- in debug mode, print the wrapper -- otherwise just print what's inside @@ -452,13 +452,15 @@ data Sig name -- Signatures and pragmas -- An inline pragma -- {#- INLINE f #-} | InlineSig (Located name) -- Function name - InlineSpec + InlinePragma -- Never defaultInlinePragma -- A specialisation pragma -- {-# SPECIALISE f :: Int -> Int #-} | SpecSig (Located name) -- Specialise a function or datatype ... (LHsType name) -- ... to these types - InlineSpec + InlinePragma -- The pragma on SPECIALISE_INLINE form + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE -- A specialisation pragma for instance declarations only -- {-# SPECIALISE instance Eq [Int] #-} @@ -470,23 +472,11 @@ type LFixitySig name = Located (FixitySig name) data FixitySig name = FixitySig (Located name) Fixity -- A Prag conveys pragmas from the type checker to the desugarer -type LPrag = Located Prag -data Prag - = InlinePrag - InlineSpec - - | SpecPrag - (HsExpr Id) -- An expression, of the given specialised type, which - PostTcType -- specialises the polymorphic function - InlineSpec -- Inlining spec for the specialised function - -isInlinePrag :: Prag -> Bool -isInlinePrag (InlinePrag _) = True -isInlinePrag _ = False - -isSpecPrag :: Prag -> Bool -isSpecPrag (SpecPrag {}) = True -isSpecPrag _ = False +type LSpecPrag = Located SpecPrag +data SpecPrag + = SpecPrag + HsWrapper -- An wrapper, that specialises the polymorphic function + InlinePragma -- Inlining spec for the specialised function \end{code} \begin{code} @@ -585,10 +575,10 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) ty -ppr_sig (IdSig id) = pprVarSig id (varType id) +ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) +ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig -ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var ty inl) +ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) ppr_sig (SpecInstSig ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) @@ -598,14 +588,16 @@ instance Outputable name => Outputable (FixitySig name) where pragBrackets :: SDoc -> SDoc pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") -pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc -pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)] +pprVarSig :: (Outputable id) => id -> SDoc -> SDoc +pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty] -pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc -pprSpec var ty inl = sep [ptext (sLit "SPECIALIZE") <+> ppr inl <+> pprVarSig var ty] +pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty + where + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = ppr inl -pprPrag :: Outputable id => id -> LPrag -> SDoc -pprPrag var (L _ (InlinePrag inl)) = ppr inl <+> ppr var -pprPrag var (L _ (SpecPrag _expr ty inl)) = pprSpec var ty inl +pprPrag :: Outputable id => id -> LSpecPrag -> SDoc +pprPrag var (L _ (SpecPrag _expr inl)) = pprSpec var (ptext (sLit "<type>")) inl \end{code} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 66d9ed34c5..d629bae6ba 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,3 +1,4 @@ + % % (c) The University of Glasgow, 1992-2006 % @@ -319,8 +320,12 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc fun_tick = Nothing } -mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id -mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs +mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id +mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs + +mkVarBind :: id -> LHsExpr id -> LHsBind id +mkVarBind var rhs = L (getLoc rhs) $ + VarBind { var_id = var, var_rhs = rhs, var_inline = False } ------------ mk_easy_FunBind :: SrcSpan -> id -> [LPat id] diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index b04e6e104e..323e2692c2 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -600,14 +600,16 @@ instance Binary RuleMatchInfo where else return FunLike instance Binary InlinePragma where - put_ bh (InlinePragma activation match_info) = do - put_ bh activation - put_ bh match_info + put_ bh (InlinePragma a b c) = do + put_ bh a + put_ bh b + put_ bh c get bh = do - act <- get bh - info <- get bh - return (InlinePragma act info) + a <- get bh + b <- get bh + c <- get bh + return (InlinePragma a b c) instance Binary StrictnessMark where put_ bh MarkedStrict = putByte bh 0 @@ -1167,10 +1169,6 @@ instance Binary IfaceInfoItem where put_ bh ad put_ bh HsNoCafRefs = do putByte bh 4 - put_ bh (HsWorker ae af) = do - putByte bh 5 - put_ bh ae - put_ bh af get bh = do h <- getByte bh case h of @@ -1182,17 +1180,43 @@ instance Binary IfaceInfoItem where return (HsUnfold ad) 3 -> do ad <- get bh return (HsInline ad) - 4 -> do return HsNoCafRefs - _ -> do ae <- get bh - af <- get bh - return (HsWorker ae af) + _ -> do return HsNoCafRefs + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold e) = do + putByte bh 0 + put_ bh e + put_ bh (IfInlineRule a b e) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh e + put_ bh (IfWrapper a n) = do + putByte bh 2 + put_ bh a + put_ bh n + put_ bh (IfDFunUnfold as) = do + putByte bh 3 + put_ bh as + get bh = do + h <- getByte bh + case h of + 0 -> do e <- get bh + return (IfCoreUnfold e) + 1 -> do a <- get bh + b <- get bh + e <- get bh + return (IfInlineRule a b e) + 2 -> do a <- get bh + n <- get bh + return (IfWrapper a n) + _ -> do as <- get bh + return (IfDFunUnfold as) instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do putByte bh 0 put_ bh aa - put_ bh IfaceInlineMe = do - putByte bh 3 put_ bh (IfaceCoreNote s) = do putByte bh 4 put_ bh s @@ -1201,7 +1225,6 @@ instance Binary IfaceNote where case h of 0 -> do aa <- get bh return (IfaceSCC aa) - 3 -> do return IfaceInlineMe 4 -> do ac <- get bh return (IfaceCoreNote ac) _ -> panic ("get IfaceNote " ++ show h) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 129ebd0719..2e2967d89b 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -9,7 +9,8 @@ module IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, IfaceInst(..), IfaceFamInst(..), @@ -201,15 +202,21 @@ data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma - | HsUnfold IfaceExpr + | HsUnfold IfaceUnfolding | HsNoCafRefs - | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo - -- for why we want arity here. - -- NB: we need IfaceExtName (not just OccName) because the worker - -- can simplify to a function in another module. + -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. +data IfaceUnfolding + = IfCoreUnfold IfaceExpr + | IfInlineRule Arity + Bool -- Sat/UnSat + IfaceExpr + | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker + -- can simplify to a function in another module. + | IfDFunUnfold [IfaceExpr] + -------------------------------- data IfaceExpr = IfaceLcl FastString @@ -227,7 +234,6 @@ data IfaceExpr | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre - | IfaceInlineMe | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) @@ -504,10 +510,10 @@ pprIfaceConDecl tc = sep [main_payload, if is_infix then ptext (sLit "Infix") else empty, if has_wrap then ptext (sLit "HasWrapper") else empty, - if null strs then empty - else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), - if null fields then empty - else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + ppUnless (null strs) $ + nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where main_payload = ppr name <+> dcolon <+> pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau @@ -632,7 +638,6 @@ pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args) ------------------ instance Outputable IfaceNote where ppr (IfaceSCC cc) = pprCostCentreCore cc - ppr IfaceInlineMe = ptext (sLit "__inline_me") ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s) @@ -652,16 +657,22 @@ instance Outputable IfaceIdDetails where instance Outputable IfaceIdInfo where ppr NoInfo = empty - ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}") + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> - parens (pprIfaceExpr noParens unf) + ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> ppr unf ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") - ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a + +instance Outputable IfaceUnfolding where + ppr (IfCoreUnfold e) = parens (ppr e) + ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:") + <+> parens (ptext (sLit "arity") <+> int a <+> ppr b) + <+> parens (ppr e) + ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns) -- ----------------------------------------------------------------------------- @@ -775,10 +786,15 @@ freeNamesIfIdInfo NoInfo = emptyNameSet freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet -freeNamesItem (HsUnfold u) = freeNamesIfExpr u -freeNamesItem (HsWorker wkr _) = unitNameSet wkr +freeNamesItem (HsUnfold u) = freeNamesIfUnfold u freeNamesItem _ = emptyNameSet +freeNamesIfUnfold :: IfaceUnfolding -> NameSet +freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs + freeNamesIfExpr :: IfaceExpr -> NameSet freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 15fa778478..549fce6165 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1390,12 +1390,12 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag, is_local name = nameIsLocalOrFrom mod name -- Compute orphanhood. See Note [Orphans] in IfaceSyn - (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id) + (_, cls, tys) = tcSplitDFunTy (idType dfun_id) -- Slightly awkward: we need the Class to get the fundeps (tvs, fds) = classTvsFds cls arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys] orph | is_local cls_name = Just (nameOccName cls_name) - | all isJust mb_ns = head mb_ns + | all isJust mb_ns = ASSERT( not (null mb_ns) ) head mb_ns | otherwise = Nothing mb_ns :: [Maybe OccName] -- One for each fundep; a locally-defined name @@ -1442,7 +1442,7 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -------------------------- toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails DFunId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) @@ -1451,7 +1451,7 @@ toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, - inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] + inline_hsinfo, unfold_hsinfo] where ------------ Arity -------------- arity_info = arityInfo id_info @@ -1470,35 +1470,32 @@ toIfaceIdInfo id_info Just sig | not (isTopSig sig) -> Just (HsStrictness sig) _other -> Nothing - ------------ Worker -------------- - work_info = workerInfo id_info - has_worker = workerExists work_info - wrkr_hsinfo = case work_info of - HasWorker work_id wrap_arity -> - Just (HsWorker ((idName work_id)) wrap_arity) - NoWorker -> Nothing - ------------ Unfolding -------------- - -- The unfolding is redundant if there is a worker - unfold_info = unfoldingInfo id_info - rhs = unfoldingTemplate unfold_info - no_unfolding = neverUnfold unfold_info - -- The CoreTidy phase retains unfolding info iff - -- we want to expose the unfolding, taking into account - -- unconditional NOINLINE, etc. See TidyPgm.addExternal - unfold_hsinfo | no_unfolding = Nothing - | has_worker = Nothing -- Unfolding is implicit - | otherwise = Just (HsUnfold (toIfaceExpr rhs)) + unfold_hsinfo = toIfUnfolding (unfoldingInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing - | no_unfolding && not has_worker - && isFunLike (inlinePragmaRuleMatchInfo inline_prag) - = Nothing - -- If the iface file give no unfolding info, we - -- don't need to say when inlining is OK! - | otherwise = Just (HsInline inline_prag) + | otherwise = Just (HsInline inline_prag) + +-------------------------- +toIfUnfolding :: Unfolding -> Maybe IfaceInfoItem +toIfUnfolding (CoreUnfolding { uf_tmpl = rhs, uf_arity = arity, uf_guidance = guidance }) + = case guidance of + InlineRule { ug_ir_info = InlSat } -> Just (HsUnfold (IfInlineRule arity True (toIfaceExpr rhs))) + InlineRule { ug_ir_info = InlUnSat } -> Just (HsUnfold (IfInlineRule arity False (toIfaceExpr rhs))) + InlineRule { ug_ir_info = InlWrapper w } -> Just (HsUnfold (IfWrapper arity (idName w))) + UnfoldNever -> Nothing + UnfoldIfGoodArgs {} -> Just (HsUnfold (IfCoreUnfold (toIfaceExpr rhs))) + UnfoldAlways -> panic "toIfUnfolding:UnfoldAlways" + -- Never happens because we never have + -- bindings for unfold-always things +toIfUnfolding (DFunUnfolding _con ops) + = Just (HsUnfold (IfDFunUnfold (map toIfaceExpr ops))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun +toIfUnfolding _ + = Nothing -------------------------- coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule @@ -1555,7 +1552,6 @@ toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- toIfaceNote :: Note -> IfaceNote toIfaceNote (SCC cc) = IfaceSCC cc -toIfaceNote InlineMe = IfaceInlineMe toIfaceNote (CoreNote s) = IfaceCoreNote s --------------------- diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 6a5595719d..689dd4b1e8 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,6 +19,7 @@ import LoadIface import IfaceEnv import BuildTyCl import TcRnMonad +import TcType import Type import TypeRep import HscTypes @@ -43,6 +44,7 @@ import qualified Var import VarEnv import Name import NameEnv +import OccurAnal ( occurAnalyseExpr ) import Module import LazyUniqFM import UniqSupply @@ -53,7 +55,6 @@ import SrcLoc import DynFlags import Util import FastString -import BasicTypes (Arity) import Control.Monad import Data.List @@ -416,7 +417,7 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdDetails = details, ifIdInfo = info}) = do { name <- lookupIfaceTop occ_name ; ty <- tcIfaceType iface_type - ; details <- tcIdDetails details + ; details <- tcIdDetails ty details ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } @@ -631,7 +632,7 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd ; let mb_tcs = map ifTopFreeName args ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', - ru_rhs = rhs', + ru_rhs = occurAnalyseExpr rhs', ru_rough = mb_tcs, ru_local = False }) } -- An imported RULE is never for a local Id -- or, even if it is (module loop, perhaps) @@ -885,7 +886,6 @@ tcIfaceExpr (IfaceCast expr co) = do tcIfaceExpr (IfaceNote note expr) = do expr' <- tcIfaceExpr expr case note of - IfaceInlineMe -> return (Note InlineMe expr') IfaceSCC cc -> return (Note (SCC cc) expr') IfaceCoreNote n -> return (Note (CoreNote n) expr') @@ -964,10 +964,14 @@ do_one (IfaceRec pairs) thing_inside %************************************************************************ \begin{code} -tcIdDetails :: IfaceIdDetails -> IfL IdDetails -tcIdDetails IfVanillaId = return VanillaId -tcIdDetails IfDFunId = return DFunId -tcIdDetails (IfRecSelId tc naughty) +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails ty IfDFunId + = return (DFunId (isNewTyCon (classTyCon cls))) + where + (_, cls, _) = tcSplitDFunTy ty + +tcIdDetails _ (IfRecSelId tc naughty) = do { tc' <- tcIfaceTyCon tc ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } @@ -983,52 +987,62 @@ tcIdInfo ignore_prags name ty info init_info = vanillaIdInfo tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo - tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) - tcPrag info (HsArity arity) = return (info `setArityInfo` arity) - tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = return (info `setAllStrictnessInfo` Just str) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) -- The next two are lazy, so they don't transitively suck stuff in - tcPrag info (HsWorker nm arity) = tcWorkerInfo ty info nm arity - tcPrag info (HsInline inline_prag) = return (info `setInlinePragInfo` inline_prag) - tcPrag info (HsUnfold expr) = do - maybe_expr' <- tcPragExpr name expr - let - -- maybe_expr' doesn't get looked at if the unfolding - -- is never inspected; so the typecheck doesn't even happen - unfold_info = case maybe_expr' of - Nothing -> noUnfolding - Just expr' -> mkTopUnfolding expr' - return (info `setUnfoldingInfoLazily` unfold_info) + tcPrag info (HsUnfold if_unf) = do { unf <- tcUnfolding name ty info if_unf + ; return (info `setUnfoldingInfoLazily` unf) } \end{code} \begin{code} -tcWorkerInfo :: Type -> IdInfo -> Name -> Arity -> IfL IdInfo -tcWorkerInfo ty info wkr arity - = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) +tcUnfolding :: Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +tcUnfolding name _ _ (IfCoreUnfold if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkTopUnfolding expr) } + +tcUnfolding name _ _ (IfInlineRule arity sat if_expr) + = do { mb_expr <- tcPragExpr name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkInlineRule inl_info expr arity) } + where + inl_info | sat = InlSat + | otherwise = InlUnSat - -- We return without testing maybe_wkr_id, but as soon as info is - -- looked at we will test it. That's ok, because its outside the - -- knot; and there seems no big reason to further defer the - -- tcIfaceId lookup. (Contrast with tcPragExpr, where postponing walking - -- over the unfolding until it's actually used does seem worth while.) +tcUnfolding name ty info (IfWrapper arity wkr) + = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr) ; us <- newUniqueSupply - ; return (case mb_wkr_id of - Nothing -> info - Just wkr_id -> add_wkr_info us wkr_id info) } + Nothing -> noUnfolding + Just wkr_id -> make_inline_rule wkr_id us) } where - doc = text "Worker for" <+> ppr wkr - add_wkr_info us wkr_id info - = info `setUnfoldingInfoLazily` mk_unfolding us wkr_id - `setWorkerInfo` HasWorker wkr_id arity + doc = text "Worker for" <+> ppr name - mk_unfolding us wkr_id = mkTopUnfolding (initUs_ us (mkWrapper ty strict_sig) wkr_id) + make_inline_rule wkr_id us + = mkWwInlineRule wkr_id + (initUs_ us (mkWrapper ty strict_sig) wkr_id) + arity -- We are relying here on strictness info always appearing -- before worker info, fingers crossed .... strict_sig = case newStrictnessInfo info of Just sig -> sig Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr) + +tcUnfolding name dfun_ty _ (IfDFunUnfold ops) + = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + ; return (case mb_ops1 of + Nothing -> noUnfolding + Just ops1 -> DFunUnfolding data_con ops1) } + where + doc = text "Class ops for dfun" <+> ppr name + (_, cls, _) = tcSplitDFunTy dfun_ty + data_con = classDataCon cls \end{code} For unfoldings we try to do the job lazily, so that we never type check diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 88a3059601..2918875393 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -16,8 +16,7 @@ import CoreSyn import CoreUnfold import CoreFVs import CoreTidy -import PprCore -import CoreLint +import CoreMonad import CoreUtils import CoreArity ( exprArity ) import Class ( classSelIds ) @@ -297,28 +296,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, mg_hpc_info = hpc_info, mg_modBreaks = modBreaks }) - = do { let dflags = hsc_dflags hsc_env - ; showPass dflags "Tidy Core" - - ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags + = do { let { dflags = hsc_dflags hsc_env + ; omit_prags = dopt Opt_OmitInterfacePragmas dflags ; th = dopt Opt_TemplateHaskell dflags } + ; showPass dflags "Tidy Core" ; let { implicit_binds = getImplicitBinds type_env } ; (unfold_env, tidy_occ_env) - <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds - - ; let { ext_rules - | omit_prags = [] - | otherwise = findExternalRules binds imp_rules unfold_env - -- findExternalRules filters imp_rules to avoid binders that - -- aren't externally visible; but the externally-visible binders - -- are computed (by findExternalIds) assuming that all orphan - -- rules are exported (they get their Exported flag set in the desugarer) - -- So in fact we may export more than we need. - -- (It's a sort of mutual recursion.) - } + <- chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_rules + + ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env } + -- See Note [Which rules to expose] ; let { (tidy_env, tidy_binds) = tidyTopBinds hsc_env unfold_env tidy_occ_env binds } @@ -348,11 +338,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds - ; dumpIfSet_core dflags Opt_D_dump_simpl - "Tidy Core Rules" - (pprRules tidy_rules) - + ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules ; let dir_imp_mods = moduleEnvKeys dir_imps ; return (CgGuts { cg_module = mod, @@ -578,8 +564,8 @@ Sete Note [choosing external names]. \begin{code} type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) - -- maps each top-level Id to its new Name (the Id is tidied in step 2) - -- The Unique is unchanged. If the new Id is external, it will be + -- Maps each top-level Id to its new Name (the Id is tidied in step 2) + -- The Unique is unchanged. If the new Name is external, it will be -- visible in the interface file. -- -- Bool => expose unfolding or not. @@ -589,34 +575,38 @@ chooseExternalIds :: HscEnv -> Bool -> [CoreBind] -> [CoreBind] + -> [CoreRule] -> IO (UnfoldEnv, TidyOccEnv) -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags binds implicit_binds - = do - (unfold_env1,occ_env1) - <- search (zip sorted_exports sorted_exports) emptyVarEnv init_occ_env - let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders - tidy_internal internal_ids unfold_env1 occ_env1 +chooseExternalIds hsc_env mod omit_prags binds implicit_binds imp_id_rules + = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env + ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders + ; tidy_internal internal_ids unfold_env1 occ_env1 } where nc_var = hsc_NC hsc_env - -- the exports, sorted by OccName. This is a deterministic list of - -- Ids (i.e. it's the same list every time this module is compiled), - -- in contrast to the bindings, which are ordered - -- non-deterministically. - -- - -- This list will serve as a starting point for finding a + -- init_ext_ids is the intial list of Ids that should be + -- externalised. It serves as the starting point for finding a -- deterministic, tidy, renaming for all external Ids in this -- module. - sorted_exports = sortBy (compare `on` getOccName) $ - filter isExportedId binders - - binders = bindersOfBinds binds + -- + -- It is sorted, so that it has adeterministic order (i.e. it's the + -- same list every time this module is compiled), in contrast to the + -- bindings, which are ordered non-deterministically. + init_work_list = zip init_ext_ids init_ext_ids + init_ext_ids = sortBy (compare `on` getOccName) $ + filter is_external binders + + -- An Id should be external if either (a) it is exported or + -- (b) it appears in the RHS of a local rule for an imported Id. + -- See Note [Which rules to expose] + is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars + rule_rhs_vars = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules + + binders = bindersOfBinds binds implicit_binders = bindersOfBinds implicit_binds - - bind_env :: IdEnv (Id,CoreExpr) - bind_env = mkVarEnv (zip (map fst bs) bs) where bs = flattenBinds binds + binder_set = mkVarSet binders avoids = [getOccName name | bndr <- binders ++ implicit_binders, let name = idName bndr, @@ -641,7 +631,12 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds init_occ_env = initTidyOccEnv avoids - search :: [(Id,Id)] -- (external id, referrring id) + search :: [(Id,Id)] -- The work-list: (external id, referrring id) + -- Make a tidy, external Name for the external id, + -- add it to the UnfoldEnv, and do the same for the + -- transitive closure of Ids it refers to + -- The referring id is used to generate a tidy + --- name for the external id -> UnfoldEnv -- id -> (new Name, show_unfold) -> TidyOccEnv -- occ env for choosing new Names -> IO (UnfoldEnv, TidyOccEnv) @@ -653,19 +648,19 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds | otherwise = do (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc let - (id, rhs) = expectJust (showSDoc (text "chooseExternalIds: " <> - ppr idocc)) $ - lookupVarEnv bind_env idocc - -- NB. idocc might be an *occurrence* of an Id, whereas we want - -- the Id from the binding site, because only the latter is - -- guaranteed to have the unfolding attached. This is why we - -- keep binding site Ids in the bind_env. (new_ids, show_unfold) | omit_prags = ([], False) - | otherwise = addExternal id rhs - unfold_env' = extendVarEnv unfold_env id (name',show_unfold) - referrer' | isExportedId id = id - | otherwise = referrer + | otherwise = addExternal refined_id + + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set + refined_id = case lookupVarSet binder_set idocc of + Just id -> id + Nothing -> WARN( True, ppr idocc ) idocc + + unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) + referrer' | isExportedId refined_id = refined_id + | otherwise = referrer -- search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' @@ -677,45 +672,36 @@ chooseExternalIds hsc_env mod omit_prags binds implicit_binds let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env' -addExternal :: Id -> CoreExpr -> ([Id],Bool) -addExternal id rhs = (new_needed_ids, show_unfold) +addExternal :: Id -> ([Id],Bool) +addExternal id = (new_needed_ids, show_unfold) where new_needed_ids = unfold_ids ++ filter (\id -> isLocalId id && not (id `elemVarSet` unfold_set)) - (varSetElems worker_ids ++ - varSetElems spec_ids) -- XXX non-det ordering + (varSetElems spec_ids) -- XXX non-det ordering idinfo = idInfo id dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) - worker_info = workerInfo idinfo -- Stuff to do with the Id's unfolding - -- The simplifier has put an up-to-date unfolding - -- in the IdInfo, but the RHS will do just as well - unfolding = unfoldingInfo idinfo - rhs_is_small = not (neverUnfold unfolding) - -- We leave the unfolding there even if there is a worker -- In GHCI the unfolding is used by importers - -- When writing an interface file, we omit the unfolding - -- if there is a worker - show_unfold = not bottoming_fn && -- Not necessary - not dont_inline && - not loop_breaker && - rhs_is_small -- Small enough - - (unfold_set, unfold_ids) - | show_unfold = freeVarsInDepthFirstOrder rhs - | otherwise = (emptyVarSet, []) - - worker_ids = case worker_info of - HasWorker work_id _ -> unitVarSet work_id - _otherwise -> emptyVarSet - + show_unfold = isJust mb_unfold_ids + (unfold_set, unfold_ids) = mb_unfold_ids `orElse` (emptyVarSet, []) + + mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold + mb_unfold_ids = case unfoldingInfo idinfo of + CoreUnfolding { uf_tmpl = unf_rhs, uf_guidance = guide } + | not bottoming_fn -- Not necessary + , not dont_inline + , not loop_breaker + , not (neverUnfoldGuidance guide) + -> Just (exprFvsInOrder unf_rhs) + DFunUnfolding _ ops -> Just (exprsFvsInOrder ops) + _ -> Nothing -- We want a deterministic free-variable list. exprFreeVars gives us -- a VarSet, which is in a non-deterministic order when converted to a @@ -724,11 +710,15 @@ addExternal id rhs = (new_needed_ids, show_unfold) -- -- Note [choosing external names] -freeVarsInDepthFirstOrder :: CoreExpr -> (VarSet, [Id]) -freeVarsInDepthFirstOrder e = - case dffvExpr e of - DFFV m -> case m emptyVarSet [] of - (set,ids,_) -> (set,ids) +exprFvsInOrder :: CoreExpr -> (VarSet, [Id]) +exprFvsInOrder e = run (dffvExpr e) + +exprsFvsInOrder :: [CoreExpr] -> (VarSet, [Id]) +exprsFvsInOrder es = run (mapM_ dffvExpr es) + +run :: DFFV () -> (VarSet, [Id]) +run (DFFV m) = case m emptyVarSet [] of + (set,ids,_) -> (set,ids) newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a)) @@ -848,15 +838,17 @@ tidyTopName mod nc_var maybe_ref occ_env id \end{code} \begin{code} -findExternalRules :: [CoreBind] - -> [CoreRule] -- Non-local rules (i.e. ones for imported fns) +findExternalRules :: Bool -- Omit pragmas + -> [CoreBind] + -> [CoreRule] -- Local rules for imported fns -> UnfoldEnv -- Ids that are exported, so we need their rules -> [CoreRule] -- The complete rules are gotten by combining - -- a) the non-local rules + -- a) local rules for imported Ids -- b) rules embedded in the top-level Ids -findExternalRules binds non_local_rules unfold_env - = filter (not . internal_rule) (non_local_rules ++ local_rules) +findExternalRules omit_prags binds imp_id_rules unfold_env + | omit_prags = [] + | otherwise = filterOut internal_rule (imp_id_rules ++ local_rules) where local_rules = [ rule | id <- bindersOfBinds binds, @@ -875,7 +867,14 @@ findExternalRules binds non_local_rules unfold_env | otherwise = False \end{code} - +Note [Which rules to expose] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +findExternalRules filters imp_rules to avoid binders that +aren't externally visible; but the externally-visible binders +are computed (by findExternalIds) assuming that all orphan +rules are externalised (see init_ext_ids in function +'search'). So in fact we may export more than we need. +(It's a sort of mutual recursion.) %************************************************************************ %* * @@ -978,12 +977,24 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) rhs' = tidyExpr rhs_tidy_env rhs idinfo = idInfo bndr idinfo' = tidyTopIdInfo (isExternalName name') - idinfo unfold_info worker_info + idinfo unfold_info arity caf_info - unfold_info | show_unfold = mkTopUnfolding rhs' + unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs' (unfoldingInfo idinfo) | otherwise = noUnfolding - worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo) + -- NB: do *not* expose the worker if show_unfold is off, + -- because that means this thing is a loop breaker or + -- marked NOINLINE or something like that + -- This is important: if you expose the worker for a loop-breaker + -- then you can make the simplifier go into an infinite loop, because + -- in effect the unfolding is exposed. See Trac #1709 + -- + -- You might think that if show_unfold is False, then the thing should + -- not be w/w'd in the first place. But a legitimate reason is this: + -- the function returns bottom + -- In this case, show_unfold will be false (we don't expose unfoldings + -- for bottoming functions), but we might still have a worker/wrapper + -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs -- Usually the Id will have an accurate arity on it, because -- the simplifier has just run, but not always. @@ -1007,9 +1018,9 @@ tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs) -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. tidyTopIdInfo :: Bool -> IdInfo -> Unfolding - -> WorkerInfo -> ArityInfo -> CafInfo + -> ArityInfo -> CafInfo -> IdInfo -tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info +tidyTopIdInfo is_external idinfo unfold_info arity caf_info | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; @@ -1025,32 +1036,26 @@ tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info `setAllStrictnessInfo` newStrictnessInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` unfold_info - `setWorkerInfo` worker_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules ------------- Worker -------------- -tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo -tidyWorker _tidy_env _show_unfold NoWorker - = NoWorker -tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity) - | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity - | otherwise = NoWorker - -- NB: do *not* expose the worker if show_unfold is off, - -- because that means this thing is a loop breaker or - -- marked NOINLINE or something like that - -- This is important: if you expose the worker for a loop-breaker - -- then you can make the simplifier go into an infinite loop, because - -- in effect the unfolding is exposed. See Trac #1709 - -- - -- You might think that if show_unfold is False, then the thing should - -- not be w/w'd in the first place. But a legitimate reason is this: - -- the function returns bottom - -- In this case, show_unfold will be false (we don't expose unfoldings - -- for bottoming functions), but we might still have a worker/wrapper - -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding +tidyUnfolding tidy_env _ unf@(CoreUnfolding { uf_tmpl = rhs + , uf_guidance = guide@(InlineRule {}) }) + = unf { uf_tmpl = tidyExpr tidy_env rhs, -- Preserves OccInfo + uf_guidance = guide { ug_ir_info = tidyInl tidy_env (ug_ir_info guide) } } +tidyUnfolding tidy_env _ (DFunUnfolding con ids) + = DFunUnfolding con (map (tidyExpr tidy_env) ids) +tidyUnfolding _ tidy_rhs (CoreUnfolding {}) + = mkTopUnfolding tidy_rhs +tidyUnfolding _ _ unf = unf + +tidyInl :: TidyEnv -> InlineRuleInfo -> InlineRuleInfo +tidyInl tidy_env (InlWrapper w) = InlWrapper (tidyVarOcc tidy_env w) +tidyInl _ inl_info = inl_info \end{code} %************************************************************************ diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 3aec9e3d70..9068502f88 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -48,7 +48,7 @@ import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, mkArrowKind, liftedTypeKind, unliftedTypeKind ) import Class ( FunDep ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - Activation(..), RuleMatchInfo(..), defaultInlineSpec ) + Activation(..), RuleMatchInfo(..), defaultInlinePragma ) import DynFlags import OrdList import HaddockUtils @@ -559,8 +559,8 @@ topdecl :: { OrdList (LHsDecl RdrName) } | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } | 'foreign' fdecl { unitOL (LL (unLoc $2)) } - | '{-# DEPRECATED' deprecations '#-}' { $2 } - | '{-# WARNING' warnings '#-}' { $2 } + | '{-# DEPRECATED' deprecations '#-}' { $2 } + | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } | annotation { unitOL $1 } | decl { unLoc $1 } @@ -1228,17 +1228,17 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 FunLike (getINLINE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 FunLike (getINLINE $1)))) } | '{-# INLINE_CONLIKE' activation qvar '#-}' - { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlineSpec $2 ConLike (getINLINE_CONLIKE $1)))) } + { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma $2 ConLike (getINLINE_CONLIKE $1)))) } | '{-# SPECIALISE' qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec) + { LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlinePragma) | t <- $4] } | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}' - { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlineSpec $2 FunLike (getSPEC_INLINE $1))) + { LL $ toOL [ LL $ SigD (SpecSig $3 t (mkInlinePragma $2 FunLike (getSPEC_INLINE $1))) | t <- $5] } | '{-# SPECIALISE' 'instance' inst_type '#-}' - { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } + { LL $ unitOL (LL $ SigD (SpecInstSig $3)) } ----------------------------------------------------------------------------- -- Expressions diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 8ae9030e06..6839fa2d45 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -269,11 +269,12 @@ exp :: { IfaceExpr } | '%case' '(' ty ')' aexp '%of' id_bndr '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 } | '%cast' aexp aty { IfaceCast $2 $3 } - | '%note' STRING exp - { case $2 of - --"SCC" -> IfaceNote (IfaceSCC "scc") $3 - "InlineMe" -> IfaceNote IfaceInlineMe $3 - } +-- No InlineMe any more +-- | '%note' STRING exp +-- { case $2 of +-- --"SCC" -> IfaceNote (IfaceSCC "scc") $3 +-- "InlineMe" -> IfaceNote IfaceInlineMe $3 +-- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString $2)) CCallConv (PlaySafe False))) diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 03ca542149..92c74150b5 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -12,7 +12,7 @@ module RdrHsSyn ( mkHsIntegral, mkHsFractional, mkHsIsString, mkHsDo, mkHsSplice, mkTopSpliceDecl, mkClassDecl, mkTyData, mkTyFamily, mkTySynonym, - splitCon, mkInlineSpec, + splitCon, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp cvBindGroup, @@ -54,9 +54,8 @@ import Class ( FunDep ) import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) -import BasicTypes ( maxPrecedence, Activation, RuleMatchInfo, - InlinePragma(..), InlineSpec(..), - alwaysInlineSpec, neverInlineSpec ) +import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, + InlinePragma(..) ) import Lexer import TysWiredIn ( unitTyCon ) import ForeignCall @@ -960,13 +959,20 @@ mk_rec_fields :: [HsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } -mkInlineSpec :: Maybe Activation -> RuleMatchInfo -> Bool -> InlineSpec --- The Maybe is becuase the user can omit the activation spec (and usually does) -mkInlineSpec Nothing match_info True = alwaysInlineSpec match_info - -- INLINE -mkInlineSpec Nothing match_info False = neverInlineSpec match_info - -- NOINLINE -mkInlineSpec (Just act) match_info inl = Inline (InlinePragma act match_info) inl +mkInlinePragma :: Maybe Activation -> RuleMatchInfo -> Bool -> InlinePragma +-- The Maybe is because the user can omit the activation spec (and usually does) +mkInlinePragma mb_act match_info inl + = InlinePragma { inl_inline = inl + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing | inl -> AlwaysActive + | otherwise -> NeverActive + -- If no specific phase is given then: + -- NOINLINE => NeverActive + -- INLINE => Active ----------------------------------------------------------------------------- -- utilities for foreign declarations diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index e35d8dbcce..236cee6074 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -35,7 +35,8 @@ import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) +import CoreUtils ( cheapEqExpr ) +import CoreUnfold ( exprIsConApp_maybe ) import Type ( tyConAppTyCon, coreEqType ) import OccName ( occNameFS ) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, @@ -457,7 +458,7 @@ dataToTagRule [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] = Just tag -- dataToTag (tagToEnum x) ==> x dataToTagRule [_, val_arg] - | Just (dc,_) <- exprIsConApp_maybe val_arg + | Just (dc,_,_) <- exprIsConApp_maybe val_arg = ASSERT( not (isNewTyCon (dataConTyCon dc)) ) Just (mkIntVal (toInteger (dataConTag dc - fIRST_TAG))) diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 54490f4aff..8c386614c6 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -114,7 +114,7 @@ Note [CSE for INLINE and NOINLINE] We are careful to do no CSE inside functions that the user has marked as INLINE or NOINLINE. In terms of Core, that means - a) we do not do CSE inside (Note InlineMe e) + a) we do not do CSE inside an InlineRule b) we do not do CSE on the RHS of a binding b=e unless b's InlinePragma is AlwaysActive @@ -218,7 +218,6 @@ cseExpr _ (Type t) = Type t cseExpr _ (Lit lit) = Lit lit cseExpr env (Var v) = Var (lookupSubst env v) cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) -cseExpr _ (Note InlineMe e) = Note InlineMe e -- See Note [CSE for INLINE and NOINLINE] cseExpr env (Note n e) = Note n (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) co cseExpr env (Lam b e) = let (env', b') = addBinder env b diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index c49ac17674..f806089562 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -24,6 +24,9 @@ module CoreMonad ( -- ** Dealing with annotations findAnnotations, deserializeAnnotations, addAnnotation, + -- ** Debug output + endPass, endPassIf, + -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, fatalErrorMsg, fatalErrorMsgS, @@ -39,6 +42,10 @@ module CoreMonad ( #ifdef GHCI import Name( Name ) #endif +import CoreSyn +import PprCore +import CoreUtils +import CoreLint ( lintCoreBindings ) import PrelNames ( iNTERACTIVE ) import HscTypes import Module ( Module ) @@ -54,6 +61,7 @@ import TcEnv ( tcLookupGlobal ) import TcRnMonad ( TcM, initTc ) import Outputable +import FastString import qualified ErrUtils as Err import Maybes import UniqSupply @@ -72,7 +80,50 @@ import qualified Language.Haskell.TH as TH #endif \end{code} -\subsection{Monad and carried data structure definitions} +%************************************************************************ +%* * + Debug output +%* * +%************************************************************************ + +These functions are not CoreM monad stuff, but they probably ought to +be, and it makes a conveneint place. place for them. They print out +stuff before and after core passes, and do Core Lint when necessary. + +\begin{code} +endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endPass = dumpAndLint Err.dumpIfSet_core + +endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO () +endPassIf cond = dumpAndLint (Err.dumpIf_core cond) + +dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ()) + -> DynFlags -> String -> DynFlag + -> [CoreBind] -> [CoreRule] -> IO () +dumpAndLint dump dflags pass_name dump_flag binds rules + = do { -- Report result size if required + -- This has the side effect of forcing the intermediate to be evaluated + ; Err.debugTraceMsg dflags 2 $ + (text " Result size =" <+> int (coreBindsSize binds)) + + -- Report verbosely, if required + ; dump dflags dump_flag pass_name + (pprCoreBindings binds $$ ppUnless (null rules) pp_rules) + + -- Type check + ; lintCoreBindings dflags pass_name binds } + where + pp_rules = vcat [ blankLine + , ptext (sLit "------ Local rules for imported ids --------") + , pprRules rules ] +\end{code} + + +%************************************************************************ +%* * + Monad and carried data structure definitions +%* * +%************************************************************************ \begin{code} data CoreState = CoreState { @@ -160,7 +211,12 @@ runCoreM hsc_env ann_env rule_base us mod m = \end{code} -\subsection{Core combinators, not exported} + +%************************************************************************ +%* * + Core combinators, not exported +%* * +%************************************************************************ \begin{code} @@ -200,7 +256,12 @@ liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> re \end{code} -\subsection{Reader, writer and state accessors} + +%************************************************************************ +%* * + Reader, writer and state accessors +%* * +%************************************************************************ \begin{code} @@ -233,7 +294,12 @@ getOrigNameCache = do \end{code} -\subsection{Dealing with annotations} + +%************************************************************************ +%* * + Dealing with annotations +%* * +%************************************************************************ \begin{code} @@ -268,7 +334,12 @@ addAnnotationToEnv annotation = modifyS (\state -> state { cs_ann_env = extendAn \end{code} -\subsection{Direct screen output} + +%************************************************************************ +%* * + Direct screen output +%* * +%************************************************************************ \begin{code} @@ -312,7 +383,6 @@ debugTraceMsg = msg (flip Err.debugTraceMsg 3) -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DynFlag -> String -> SDoc -> CoreM () dumpIfSet_dyn flag str = msg (\dflags -> Err.dumpIfSet_dyn dflags flag str) - \end{code} \begin{code} @@ -322,18 +392,25 @@ initTcForLookup hsc_env = liftM (expectJust "initTcInteractive" . snd) . initTc \end{code} -\subsection{Finding TyThings} -\begin{code} +%************************************************************************ +%* * + Finding TyThings +%* * +%************************************************************************ +\begin{code} instance MonadThings CoreM where lookupThing name = do hsc_env <- getHscEnv liftIO $ initTcForLookup hsc_env (tcLookupGlobal name) - \end{code} -\subsection{Template Haskell interoperability} +%************************************************************************ +%* * + Template Haskell interoperability +%* * +%************************************************************************ \begin{code} #ifdef GHCI diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 36e3d4de70..cf53e91220 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -18,7 +18,7 @@ module FloatIn ( floatInwards ) where import CoreSyn import CoreUtils ( exprIsHNF, exprIsDupable ) -import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) import Id ( isOneShotBndr, idType ) import Var import Type ( isUnLiftedType ) @@ -213,10 +213,6 @@ fiExpr to_drop (_, AnnNote note@(SCC _) expr) = -- Wimp out for now mkCoLets' to_drop (Note note (fiExpr [] expr)) -fiExpr to_drop (_, AnnNote InlineMe expr) - = -- Ditto... don't float anything into an INLINE expression - mkCoLets' to_drop (Note InlineMe (fiExpr [] expr)) - fiExpr to_drop (_, AnnNote note@(CoreNote _) expr) = Note note (fiExpr to_drop expr) \end{code} @@ -263,10 +259,12 @@ arrange to dump bindings that bind extra_fvs before the entire let. Note [extra_fvs (s): free variables of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider let x{rule mentioning y} = rhs in body +Consider + let x{rule mentioning y} = rhs in body Here y is not free in rhs or body; but we still want to dump bindings that bind y outside the let. So we augment extra_fvs with the -idRuleVars of x. +idRuleAndUnfoldingVars of x. No need for type variables, hence not using +idFreeVars. \begin{code} @@ -275,7 +273,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) where body_fvs = freeVarsOf body - rule_fvs = idRuleVars id -- See Note [extra_fvs (2): free variables of rules] + rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] extra_fvs | noFloatIntoRhs ann_rhs || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs | otherwise = rule_fvs @@ -304,7 +302,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) body_fvs = freeVarsOf body -- See Note [extra_fvs (1,2)] - rule_fvs = foldr (unionVarSet . idRuleVars) emptyVarSet ids + rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids extra_fvs = rule_fvs `unionVarSet` unionVarSets [ fvs | (fvs, rhs) <- rhss , noFloatIntoRhs rhs ] @@ -359,8 +357,7 @@ fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool -noFloatIntoRhs (AnnNote InlineMe _) = True -noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) +noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. -- This makes a big difference for things like -- f x# = let x = I# x# diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs index 27a39dfdc2..9dd4d689d0 100644 --- a/compiler/simplCore/FloatOut.lhs +++ b/compiler/simplCore/FloatOut.lhs @@ -297,13 +297,6 @@ floatExpr lvl (Note note@(SCC cc) expr) ann_bind (Rec pairs) = Rec [(binder, mkSCC dupd_cc rhs) | (binder, rhs) <- pairs] -floatExpr _ (Note InlineMe expr) -- Other than SCCs - = (zeroStats, [], Note InlineMe (unTag expr)) - -- Do no floating at all inside INLINE. - -- The SetLevels pass did not clone the bindings, so it's - -- unsafe to do any floating, even if we dump the results - -- inside the Note (which is what we used to do). - floatExpr lvl (Note note expr) -- Other than SCCs = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Note note expr') } @@ -344,22 +337,6 @@ floatList _ [] = (zeroStats, [], []) floatList f (a:as) = case f a of { (fs_a, binds_a, b) -> case floatList f as of { (fs_as, binds_as, bs) -> (fs_a `add_stats` fs_as, binds_a ++ binds_as, b:bs) }} - -unTagBndr :: TaggedBndr tag -> CoreBndr -unTagBndr (TB b _) = b - -unTag :: TaggedExpr tag -> CoreExpr -unTag (Var v) = Var v -unTag (Lit l) = Lit l -unTag (Type ty) = Type ty -unTag (Note n e) = Note n (unTag e) -unTag (App e1 e2) = App (unTag e1) (unTag e2) -unTag (Lam b e) = Lam (unTagBndr b) (unTag e) -unTag (Cast e co) = Cast (unTag e) co -unTag (Let (Rec prs) e) = Let (Rec [(unTagBndr b,unTag r) | (b, r) <- prs]) (unTag e) -unTag (Let (NonRec b r) e) = Let (NonRec (unTagBndr b) (unTag r)) (unTag e) -unTag (Case e b ty alts) = Case (unTag e) (unTagBndr b) ty - [(c, map unTagBndr bs, unTag r) | (c,bs,r) <- alts] \end{code} %************************************************************************ diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index ae5c291ef6..91e34f879e 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -23,7 +23,6 @@ import CoreUtils ( exprIsTrivial, isDefaultAlt ) import Coercion ( mkSymCoercion ) import Id import Name ( localiseName ) -import IdInfo import BasicTypes import VarSet @@ -50,13 +49,16 @@ import Data.List Here's the externally-callable interface: \begin{code} -occurAnalysePgm :: [CoreBind] -> [CoreBind] -occurAnalysePgm binds +occurAnalysePgm :: [CoreBind] -> [CoreRule] -> [CoreBind] +occurAnalysePgm binds rules = snd (go initOccEnv binds) where + initial_details = addIdOccs emptyDetails (rulesFreeVars rules) + -- The RULES keep things alive! + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] - = (emptyDetails, []) + = (initial_details, []) go env (bind:binds) = (final_usage, bind' ++ binds') where @@ -221,13 +223,15 @@ However things are made quite a bit more complicated by RULES. Remember So we must *not* postInlineUnconditionally 'g', even though its RHS turns out to be trivial. (I'm assuming that 'g' is - not choosen as a loop breaker.) + not choosen as a loop breaker.) Why not? Because then we + drop the binding for 'g', which leaves it out of scope in the + RULE! We "solve" this by making g a "weak" or "rules-only" loop breaker, with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker has IAmLoopBreaker False. So - Inline postInlineUnconditinoally + Inline postInlineUnconditionally IAmLoopBreaker False no no IAmLoopBreaker True yes no other yes yes @@ -247,6 +251,14 @@ However things are made quite a bit more complicated by RULES. Remember rule's LHS too, so we'd better ensure the dependency is respected + * Note [Inline rules] + ~~~~~~~~~~~~~~~~~~~ + None of the above stuff about RULES applies to Inline Rules, + stored in a CoreUnfolding. The unfolding, if any, is simplified + at the same time as the regular RHS of the function, so it should + be treated *exactly* like an extra RHS. + + Example [eftInt] ~~~~~~~~~~~~~~~ Example (from GHC.Enum): @@ -299,9 +311,10 @@ occAnalBind env (Rec pairs) body_usage rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs make_node (bndr, rhs) - = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges) + = (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges) where (rhs_usage, rhs') = occAnalRhs env bndr rhs + all_rhs_usage = addRuleUsage rhs_usage bndr -- Note [Rules are extra RHSs] rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr) -- (a -> b) means a mentions b @@ -324,7 +337,7 @@ occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds) = (body_usage, binds) | otherwise -- It's mentioned in the body - = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs] + = (body_usage' +++ rhs_usage, NonRec tagged_bndr rhs : binds) where (body_usage', tagged_bndr) = tagBinder body_usage bndr @@ -346,8 +359,7 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) ---------------------------- -- Tag the binders with their occurrence info total_usage = foldl add_usage body_usage nodes - add_usage body_usage (ND bndr _ rhs_usage _, _, _) - = body_usage +++ addRuleUsage rhs_usage bndr + add_usage usage_so_far (ND _ _ rhs_usage _, _, _) = usage_so_far +++ rhs_usage (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details) @@ -371,7 +383,7 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) | otherwise = foldr (reOrderRec 0) [] $ stronglyConnCompFromEdgedVerticesR loop_breaker_edges - -- See Note [Choosing loop breakers] for looop_breaker_edges + -- See Note [Choosing loop breakers] for loop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks) where @@ -401,11 +413,6 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds) where new_fvs = extendFvs env emptyVarSet fvs -idRuleRhsVars :: Id -> VarSet --- Just the variables free on the *rhs* of a rule --- See Note [Choosing loop breakers] -idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id) - extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet -- (extendFVs env fvs s) returns (fvs `union` env(s)) extendFvs env fvs id_set @@ -456,9 +463,14 @@ type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the -- which is gotten from the Id. data Details = ND Id -- Binder CoreExpr -- RHS - UsageDetails -- Full usage from RHS (*not* including rules) - IdSet -- Other binders from this Rec group mentioned on RHS - -- (derivable from UsageDetails but cached here) + + UsageDetails -- Full usage from RHS, + -- including *both* RULES *and* InlineRule unfolding + + IdSet -- Other binders *from this Rec group* mentioned in + -- * the RHS + -- * any InlineRule unfolding + -- but *excluding* any RULES reOrderRec :: Int -> SCC (Node Details) -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] @@ -514,17 +526,21 @@ reOrderCycle depth (bind : binds) pairs score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker score (ND bndr rhs _ _, _, _) - | workerExists (idWorkerInfo bndr) = 10 - -- Note [Worker inline loop] - - | exprIsTrivial rhs = 5 -- Practically certain to be inlined + | exprIsTrivial rhs = 10 -- Practically certain to be inlined -- Used to have also: && not (isExportedId bndr) -- But I found this sometimes cost an extra iteration when we have -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } -- where df is the exported dictionary. Then df makes a really -- bad choice for loop breaker - | is_con_app rhs = 3 -- Data types help with cases + | Just inl_rule_info <- isInlineRule_maybe (idUnfolding bndr) + = case inl_rule_info of + InlWrapper {} -> 10 -- Note [INLINE pragmas] + _other -> 3 -- Data structures are more important than this + -- so that dictionary/method recursion unravels + + | is_con_app rhs = 5 -- Data types help with cases + -- Includes dict funs -- Note [Constructor applictions] -- If an Id is marked "never inline" then it makes a great loop breaker @@ -533,34 +549,16 @@ reOrderCycle depth (bind : binds) pairs -- so it probably isn't worth the time to test on every binder -- | isNeverActive (idInlinePragma bndr) = -10 - | inlineCandidate bndr rhs = 2 -- Likely to be inlined - -- Note [Inline candidates] + | isOneOcc (idOccInfo bndr) = 2 -- Likely to be inlined - | not (neverUnfold (idUnfolding bndr)) = 1 + | canUnfold (idUnfolding bndr) = 1 -- the Id has some kind of unfolding | otherwise = 0 + where + - inlineCandidate :: Id -> CoreExpr -> Bool - inlineCandidate _ (Note InlineMe _) = True - inlineCandidate id _ = isOneOcc (idOccInfo id) - - -- Note [conapp] - -- - -- It's really really important to inline dictionaries. Real - -- example (the Enum Ordering instance from GHC.Base): - -- - -- rec f = \ x -> case d of (p,q,r) -> p x - -- g = \ x -> case d of (p,q,r) -> q x - -- d = (v, f, g) - -- - -- Here, f and g occur just once; but we can't inline them into d. - -- On the other hand we *could* simplify those case expressions if - -- we didn't stupidly choose d as the loop breaker. - -- But we won't because constructor args are marked "Many". - -- Inlining dictionaries is really essential to unravelling - -- the loops in static numeric dictionaries, see GHC.Float. - + -- Checking for a constructor application -- Cheap and cheerful; the simplifer moves casts out of the way -- The lambda case is important to spot x = /\a. C (f a) -- which comes up when C is a dictionary constructor and @@ -569,7 +567,7 @@ reOrderCycle depth (bind : binds) pairs -- -- However we *also* treat (\x. C p q) as a con-app-like thing, -- Note [Closure conversion] - is_con_app (Var v) = isDataConWorkId v + is_con_app (Var v) = isConLikeId v is_con_app (App f _) = is_con_app f is_con_app (Lam _ e) = is_con_app e is_con_app (Note _ e) = is_con_app e @@ -634,8 +632,18 @@ strict (and hence it gets an auto-generated wrapper). Result: an infinite inlining in the importing scope. So be a bit careful if you change this. A good example is Tree.repTree in nofib/spectral/minimax. If the repTree wrapper is chosen as the loop -breaker then compiling Game.hs goes into an infinite loop (this -happened when we gave is_con_app a lower score than inline candidates). +breaker then compiling Game.hs goes into an infinite loop. This +happened when we gave is_con_app a lower score than inline candidates: + + Tree.repTree + = __inline_me (/\a. \w w1 w2 -> + case Tree.$wrepTree @ a w w1 w2 of + { (# ww1, ww2 #) -> Branch @ a ww1 ww2 }) + Tree.$wrepTree + = /\a w w1 w2 -> + (# w2_smP, map a (Tree a) (Tree.repTree a w1 w) (w w2) #) + +Here we do *not* want to choose 'repTree' as the loop breaker. Note [Constructor applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -693,10 +701,13 @@ occAnalRhs :: OccEnv -- For non-recs the binder is alrady tagged -- with occurrence info -> (UsageDetails, CoreExpr) + -- Returned usage details includes any INLINE rhs occAnalRhs env id rhs - = occAnal ctxt rhs + = (addIdOccs rhs_usage (idUnfoldingVars id), rhs') + -- Include occurrences for the "extra RHS" from a CoreUnfolding where + (rhs_usage, rhs') = occAnal ctxt rhs ctxt | certainly_inline id = env | otherwise = rhsCtxt env -- Note that we generally use an rhsCtxt. This tells the occ anal n @@ -724,12 +735,15 @@ occAnalRhs env id rhs \begin{code} addRuleUsage :: UsageDetails -> Id -> UsageDetails -- Add the usage from RULES in Id to the usage -addRuleUsage usage id - = foldVarSet add usage (idRuleVars id) +addRuleUsage usage id = addIdOccs usage (idRuleVars id) -- idRuleVars here: see Note [Rule dependency info] + +addIdOccs :: UsageDetails -> VarSet -> UsageDetails +addIdOccs usage id_set = foldVarSet add usage id_set where - add v u = addOneOcc u v NoOccInfo - -- Give a non-committal binder info (i.e manyOcc) because + add v u | isId v = addOneOcc u v NoOccInfo + | otherwise = u + -- Give a non-committal binder info (i.e NoOccInfo) because -- a) Many copies of the specialised thing can appear -- b) We don't want to substitute a BIG expression inside a RULE -- even if that's the only occurrence of the thing @@ -774,11 +788,6 @@ occAnal _ expr@(Lit _) = (emptyDetails, expr) \end{code} \begin{code} -occAnal env (Note InlineMe body) - = case occAnal env body of { (usage, body') -> - (mapVarEnv markMany usage, Note InlineMe body') - } - occAnal env (Note note@(SCC _) body) = case occAnal env body of { (usage, body') -> (mapVarEnv markInsideSCC usage, Note note body') @@ -823,7 +832,9 @@ occAnal env (Lam x body) | isTyVar x occAnal env expr@(Lam _ _) = case occAnal env_body body of { (body_usage, body') -> let - (final_usage, tagged_binders) = tagBinders body_usage binders + (final_usage, tagged_binders) = tagLamBinders body_usage binders' + -- Use binders' to put one-shot info on the lambdas + -- URGH! Sept 99: we don't seem to be able to use binders' here, because -- we get linear-typed things in the resulting program that we can't handle yet. -- (e.g. PrelShow) TODO @@ -847,8 +858,7 @@ occAnal env (Case scrut bndr ty alts) case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s - alts_usage' = addCaseBndrUsage alts_usage - (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr + (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr total_usage = scrut_usage +++ alts_usage1 in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} @@ -862,9 +872,10 @@ occAnal env (Case scrut bndr ty alts) -- case x of w { (p,q) -> f w } -- into -- case x of w { (p,q) -> f (p,q) } - addCaseBndrUsage usage = case lookupVarEnv usage bndr of - Nothing -> usage - Just _ -> extendVarEnv usage bndr NoOccInfo + tag_case_bndr usage bndr + = case lookupVarEnv usage bndr of + Nothing -> (usage, setIdOccInfo bndr IAmDead) + Just _ -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo) alt_env = mkAltEnv env bndr_swap -- Consider x = case v of { True -> (p,q); ... } @@ -915,6 +926,7 @@ occAnalApp env (Var fun, args) fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) is_pap = isConLikeId fun || valArgCount args < idArity fun + -- See Note [CONLIKE pragma] in BasicTypes -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args @@ -1128,9 +1140,9 @@ Consider case x of y { (a,b) -> f y } We treat 'a', 'b' as dead, because they don't physically occur in the case alternative. (Indeed, a variable is dead iff it doesn't occur in -its scope in the output of OccAnal.) This invariant is It really -helpe to know when binders are unused. See esp the call to -isDeadBinder in Simplify.mkDupableAlt +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt In this example, though, the Simplifier will bring 'a' and 'b' back to life, beause it binds 'y' to (a,b) (imagine got inlined and @@ -1145,7 +1157,7 @@ occAnalAlt :: OccEnv occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs) = case occAnal env rhs of { (rhs_usage, rhs') -> let - (alt_usg, tagged_bndrs) = tagBinders rhs_usage bndrs + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage bndrs bndrs' = tagged_bndrs -- See Note [Binders in case alternatives] in case mb_scrut_var of @@ -1213,7 +1225,7 @@ type CtxtTy = [Bool] -- the CtxtTy inside applies initOccEnv :: OccEnv -initOccEnv = OccEnv { occ_encl = OccRhs +initOccEnv = OccEnv { occ_encl = OccVanilla , occ_ctxt = [] , occ_scrut_ids = emptyVarSet } @@ -1302,17 +1314,21 @@ v `usedIn` details = isExportedId v || v `localUsedIn` details type IdWithOccInfo = Id -tagBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [IdWithOccInfo]) -- Tagged binders - -tagBinders usage binders - = let - usage' = usage `delVarEnvList` binders - uss = map (setBinderOcc usage) binders - in - usage' `seq` (usage', uss) +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [IdWithOccInfo]) -- Tagged binders +-- Used for lambda and case binders +-- It copes with the fact that lambda bindings can have InlineRule +-- unfoldings, used for join points +tagLamBinders usage binders = usage' `seq` (usage', bndrs') + where + (usage', bndrs') = mapAccumR tag_lam usage binders + tag_lam usage bndr = (usage2, setBinderOcc usage bndr) + where + usage1 = usage `delVarEnv` bndr + usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr) + | otherwise = usage1 tagBinder :: UsageDetails -- Of scope -> Id -- Binders diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 0797ad7727..c9b0601be0 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -48,7 +48,7 @@ module SetLevels ( Level(..), tOP_LEVEL, LevelledBind, LevelledExpr, - incMinorLvl, ltMajLvl, ltLvl, isTopLvl, isInlineCtxt + incMinorLvl, ltMajLvl, ltLvl, isTopLvl ) where #include "HsVersions.h" @@ -57,12 +57,14 @@ import CoreSyn import DynFlags ( FloatOutSwitches(..) ) import CoreUtils ( exprType, exprIsTrivial, mkPiTypes ) +import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it -import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst, - cloneIdBndr, cloneRecIdBndrs ) +import CoreSubst ( Subst, emptySubst, extendInScope, extendInScopeList, + extendIdSubst, cloneIdBndr, cloneRecIdBndrs ) import Id ( idType, mkSysLocal, isOneShotLambda, zapDemandIdInfo, transferPolyIdInfo, - idSpecialisation, idWorkerInfo, setIdInfo + idSpecialisation, idUnfolding, setIdInfo, + setIdNewStrictness, setIdArity ) import IdInfo import Var @@ -85,9 +87,7 @@ import FastString %************************************************************************ \begin{code} -data Level = InlineCtxt -- A level that's used only for - -- the context parameter ctxt_lvl - | Level Int -- Level number of enclosing lambdas +data Level = Level Int -- Level number of enclosing lambdas Int -- Number of big-lambda and/or case expressions between -- here and the nearest enclosing lambda \end{code} @@ -150,55 +150,37 @@ the worker at all. type LevelledExpr = TaggedExpr Level type LevelledBind = TaggedBind Level -tOP_LEVEL, iNLINE_CTXT :: Level +tOP_LEVEL :: Level tOP_LEVEL = Level 0 0 -iNLINE_CTXT = InlineCtxt incMajorLvl :: Level -> Level --- For InlineCtxt we ignore any inc's; we don't want --- to do any floating at all; see notes above -incMajorLvl InlineCtxt = InlineCtxt incMajorLvl (Level major _) = Level (major + 1) 0 incMinorLvl :: Level -> Level -incMinorLvl InlineCtxt = InlineCtxt incMinorLvl (Level major minor) = Level major (minor+1) maxLvl :: Level -> Level -> Level -maxLvl InlineCtxt l2 = l2 -maxLvl l1 InlineCtxt = l1 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 | otherwise = l2 ltLvl :: Level -> Level -> Bool -ltLvl _ InlineCtxt = False -ltLvl InlineCtxt (Level _ _) = True ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft *lambda* level to another -ltMajLvl _ InlineCtxt = False -ltMajLvl InlineCtxt (Level maj2 _) = 0 < maj2 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 isTopLvl :: Level -> Bool isTopLvl (Level 0 0) = True isTopLvl _ = False -isInlineCtxt :: Level -> Bool -isInlineCtxt InlineCtxt = True -isInlineCtxt _ = False - instance Outputable Level where - ppr InlineCtxt = text "<INLINE>" ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] instance Eq Level where - InlineCtxt == InlineCtxt = True (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2 - _ == _ = False \end{code} @@ -215,21 +197,17 @@ setLevels :: FloatOutSwitches -> [LevelledBind] setLevels float_lams binds us - = initLvl us (do_them binds) + = initLvl us (do_them init_env binds) where - -- "do_them"'s main business is to thread the monad along - -- It gives each top binding the same empty envt, because - -- things unbound in the envt have level number zero implicitly - do_them :: [CoreBind] -> LvlM [LevelledBind] - - do_them [] = return [] - do_them (b:bs) = do - (lvld_bind, _) <- lvlTopBind init_env b - lvld_binds <- do_them bs - return (lvld_bind : lvld_binds) - init_env = initialEnv float_lams + do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind] + do_them _ [] = return [] + do_them env (b:bs) + = do { (lvld_bind, env') <- lvlTopBind env b + ; lvld_binds <- do_them env' bs + ; return (lvld_bind : lvld_binds) } + lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) lvlTopBind env (NonRec binder rhs) = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs)) @@ -283,11 +261,6 @@ lvlExpr ctxt_lvl env (_, AnnApp fun arg) = do -- We don't do MFE on partial applications generally, -- but we do if the function is big and hairy, like a case -lvlExpr _ env (_, AnnNote InlineMe expr) = do --- Don't float anything out of an InlineMe; hence the iNLINE_CTXT - expr' <- lvlExpr iNLINE_CTXT env expr - return (Note InlineMe expr') - lvlExpr ctxt_lvl env (_, AnnNote note expr) = do expr' <- lvlExpr ctxt_lvl env expr return (Note note expr') @@ -359,13 +332,25 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do the expression, so that it can itself be floated. Note [Unlifted MFEs] -~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~ We don't float unlifted MFEs, which potentially loses big opportunites. For example: \x -> f (h y) where h :: Int -> Int# is expensive. We'd like to float the (h y) outside the \x, but we don't because it's unboxed. Possible solution: box it. +Note [Bottoming floats] +~~~~~~~~~~~~~~~~~~~~~~~ +If we see + f = \x. g (error "urk") +we'd like to float the call to error, to get + lvl = error "urk" + f = \x. g lvl +But, it's very helpful for lvl to get a strictness signature, so that, +for example, its unfolding is not exposed in interface files (unnecessary). +But this float-out might occur after strictness analysis. So we use the +cheap-and-cheerful exprBotStrictness_maybe function. + Note [Case MFEs] ~~~~~~~~~~~~~~~~ We don't float a case expression as an MFE from a strict context. Why not? @@ -384,13 +369,17 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let] lvlMFE _ _ _ (_, AnnType ty) = return (Type ty) --- No point in floating out an expression wrapped in a coercion; +-- No point in floating out an expression wrapped in a coercion or note -- If we do we'll transform lvl = e |> co -- to lvl' = e; lvl = lvl' |> co -- and then inline lvl. Better just to float out the payload. +lvlMFE strict_ctxt ctxt_lvl env (_, AnnNote n e) + = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e + ; return (Note n e') } + lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co) - = do { expr' <- lvlMFE strict_ctxt ctxt_lvl env e - ; return (Cast expr' co) } + = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e + ; return (Cast e' co) } -- Note [Case MFEs] lvlMFE True ctxt_lvl env e@(_, AnnCase {}) @@ -398,7 +387,6 @@ lvlMFE True ctxt_lvl env e@(_, AnnCase {}) lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] - || isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context || exprIsTrivial expr -- Never float if it's trivial || not good_destination = -- Don't float it out @@ -407,8 +395,13 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) | otherwise -- Float it out! = do expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr var <- newLvlVar "lvl" abs_vars ty - return (Let (NonRec (TB var dest_lvl) expr') - (mkVarApps (Var var) abs_vars)) + -- Note [Bottoming floats] + let var_w_str = case exprBotStrictness_maybe expr of + Just (arity,str) -> var `setIdArity` arity + `setIdNewStrictness` str + Nothing -> var + return (Let (NonRec (TB var_w_str dest_lvl) expr') + (mkVarApps (Var var_w_str) abs_vars)) where expr = deAnnotate ann_expr ty = exprType expr @@ -503,7 +496,6 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) | isTyVar bndr -- Don't do anything for TyVar binders -- (simplifier gets rid of them pronto) - || isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe = do rhs' <- lvlExpr ctxt_lvl env rhs return (NonRec (TB bndr ctxt_lvl) rhs', env) @@ -528,10 +520,6 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) \begin{code} lvlBind top_lvl ctxt_lvl env (AnnRec pairs) - | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe - = do rhss' <- mapM (lvlExpr ctxt_lvl env) rhss - return (Rec ([TB b ctxt_lvl | b <- bndrs] `zip` rhss'), env) - | null abs_vars = do (new_env, new_bndrs) <- cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss @@ -733,6 +721,12 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs -- incorrectly, because the SubstEnv was still lying around. Ouch! -- KSW 2000-07. +extendInScopeEnv :: LevelEnv -> Var -> LevelEnv +extendInScopeEnv (fl, le, subst, ids) v = (fl, le, extendInScope subst v, ids) + +extendInScopeEnvList :: LevelEnv -> [Var] -> LevelEnv +extendInScopeEnvList (fl, le, subst, ids) vs = (fl, le, extendInScopeList subst vs, ids) + -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can -- (see point 4 of the module overview comment) extendCaseBndrLvlEnv :: LevelEnv -> Expr (TaggedBndr Level) -> Var -> Level @@ -820,7 +814,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( workerExists (idWorkerInfo v) || + zap v | isId v = WARN( isInlineRule (idUnfolding v) || not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo @@ -881,7 +875,9 @@ newLvlVar str vars body_ty = do cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id) cloneVar TopLevel env v _ _ - = return (env, v) -- Don't clone top level things + = return (extendInScopeEnv env v, v) -- Don't clone top level things + -- But do extend the in-scope env, to satisfy the in-scope invariant + cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl = ASSERT( isId v ) do us <- getUniqueSupplyM @@ -893,7 +889,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id]) cloneRecVars TopLevel env vs _ _ - = return (env, vs) -- Don't clone top level things + = return (extendInScopeEnvList env vs, vs) -- Don't clone top level things cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl = ASSERT( all isId vs ) do us <- getUniqueSupplyM diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index bb832837ea..62c3c35f34 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -19,6 +19,7 @@ import DynFlags ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..), DynFlags, DynFlag(..), dopt, getCoreToDo, shouldDumpSimplPhase ) import CoreSyn +import CoreSubst import HscTypes import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, @@ -30,11 +31,12 @@ import OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) import IdInfo import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) -import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet ) +import SimplEnv import SimplMonad import CoreMonad -import qualified ErrUtils as Err ( dumpIfSet_dyn, dumpIfSet, showPass ) -import CoreLint ( showPass, endPass, endPassIf, endIteration ) +import qualified ErrUtils as Err +import CoreLint +import CoreMonad ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv @@ -89,7 +91,7 @@ core2core hsc_env guts = do ann_env <- prepareAnnotations hsc_env (Just guts) -- COMPUTE THE RULE BASE TO USE - (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us + (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us -- Get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to @@ -97,7 +99,7 @@ core2core hsc_env guts = do -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. let mod = mg_module guts - (guts2, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do + (guts2, stats) <- runCoreM hsc_env ann_env hpt_rule_base cp_us mod $ do -- FIND BUILT-IN PASSES let builtin_core_todos = getCoreToDo dflags @@ -223,10 +225,10 @@ describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> Co describePass name dflag pass guts = do dflags <- getDynFlags - liftIO $ showPass dflags name + liftIO $ Err.showPass dflags name guts' <- pass guts - liftIO $ endPass dflags name dflag (mg_binds guts') - + liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts') + return guts' describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts @@ -319,64 +321,74 @@ prepareRules :: HscEnv ModGuts) -- Modified fields are -- (a) Bindings have rules attached, + -- and INLINE rules simplified -- (b) Rules are now just orphan rules prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) guts@(ModGuts { mg_binds = binds, mg_deps = deps , mg_rules = local_rules, mg_rdr_env = rdr_env }) us - = do { let -- Simplify the local rules; boringly, we need to make an in-scope set + = do { us <- mkSplitUniqSupply 'w' + + ; let -- Simplify the local rules; boringly, we need to make an in-scope set -- from the local binders, to avoid warnings from Simplify.simplVar local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds)) env = setInScopeSet gentleSimplEnv local_ids - (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - (mapM (simplRule env) local_rules) - home_pkg_rules = hptRules hsc_env (dep_mods deps) - - -- Find the rules for locally-defined Ids; then we can attach them - -- to the binders in the top-level bindings - -- - -- Reason - -- - It makes the rules easier to look up - -- - It means that transformation rules and specialisations for - -- locally defined Ids are handled uniformly - -- - It keeps alive things that are referred to only from a rule - -- (the occurrence analyser knows about rules attached to Ids) - -- - It makes sure that, when we apply a rule, the free vars - -- of the RHS are more likely to be in scope - -- - The imported rules are carried in the in-scope set - -- which is extended on each iteration by the new wave of - -- local binders; any rules which aren't on the binding will - -- thereby get dropped - (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules - local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals - binds_w_rules = updateBinders local_rule_base binds - - hpt_rule_base = mkRuleBase home_pkg_rules - imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps + (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ + mapM (simplRule env) local_rules + + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules + + home_pkg_rules = hptRules hsc_env (dep_mods deps) + hpt_rule_base = mkRuleBase home_pkg_rules + binds_w_rules = updateBinders rules_for_locals binds + ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $ - vcat [text "Local rules", pprRules better_rules, - text "", - text "Imported rules", pprRuleBase imp_rule_base]) + vcat [text "Local rules", pprRules simpl_rules, + blankLine, + text "Imported rules", pprRuleBase hpt_rule_base]) - ; return (imp_rule_base, guts { mg_binds = binds_w_rules, + ; return (hpt_rule_base, guts { mg_binds = binds_w_rules, mg_rules = rules_for_imps }) } -updateBinders :: RuleBase -> [CoreBind] -> [CoreBind] -updateBinders local_rules binds - = map update_bndrs binds +-- Note [Attach rules to local ids] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Find the rules for locally-defined Ids; then we can attach them +-- to the binders in the top-level bindings +-- +-- Reason +-- - It makes the rules easier to look up +-- - It means that transformation rules and specialisations for +-- locally defined Ids are handled uniformly +-- - It keeps alive things that are referred to only from a rule +-- (the occurrence analyser knows about rules attached to Ids) +-- - It makes sure that, when we apply a rule, the free vars +-- of the RHS are more likely to be in scope +-- - The imported rules are carried in the in-scope set +-- which is extended on each iteration by the new wave of +-- local binders; any rules which aren't on the binding will +-- thereby get dropped + +updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind] +updateBinders rules_for_locals binds + = map update_bind binds where - update_bndrs (NonRec b r) = NonRec (update_bndr b) r - update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] - - update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of - Nothing -> bndr - Just rules -> bndr `addIdSpecialisations` rules - -- The binder might have some existing rules, - -- arising from specialisation pragmas + local_rules = extendRuleBaseList emptyRuleBase rules_for_locals + + update_bind (NonRec b r) = NonRec (add_rules b) r + update_bind (Rec prs) = Rec (mapFst add_rules prs) + + -- See Note [Attach rules to local ids] + -- NB: the binder might have some existing rules, + -- arising from specialisation pragmas + add_rules bndr + | Just rules <- lookupNameEnv local_rules (idName bndr) + = bndr `addIdSpecialisations` rules + | otherwise + = bndr \end{code} Note [Simplifying the left-hand side of a RULE] @@ -393,6 +405,9 @@ we do not want to get otherwise we don't match when given an argument like augment (\a. h a a) (build h) +The simplifier does indeed do eta reduction (it's in +Simplify.completeLam) but only if -O is on. + \begin{code} simplRule env rule@(BuiltinRule {}) = return rule @@ -400,18 +415,8 @@ simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) = do (env, bndrs') <- simplBinders env bndrs args' <- mapM (simplExprGently env) args rhs' <- simplExprGently env rhs - return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' }) - --- It's important that simplExprGently does eta reduction. --- For example, in a rule like: --- augment g (build h) --- we do not want to get --- augment (\a. g a) (build h) --- otherwise we don't match when given an argument like --- (\a. h a a) --- --- The simplifier does indeed do eta reduction (it's in --- Simplify.completeLam) but only if -O is on. + return (rule { ru_bndrs = bndrs', ru_args = args' + , ru_rhs = occurAnalyseExpr rhs' }) \end{code} \begin{code} @@ -494,45 +499,49 @@ simplifyPgm mode switches do { hsc_env <- getHscEnv ; us <- getUniqueSupplyM ; rb <- getRuleBase - ; let fam_inst_env = mg_fam_inst_env guts - dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode - simplify_pgm = simplifyPgmIO dump_phase mode switches - hsc_env us rb fam_inst_env - - ; doPassM (liftIOWithCount . simplify_pgm) guts } + ; liftIOWithCount $ + simplifyPgmIO mode switches hsc_env us rb guts } where doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode) -simplifyPgmIO :: Bool - -> SimplifierMode - -> [SimplifierSwitch] - -> HscEnv - -> UniqSupply - -> RuleBase - -> FamInstEnv - -> [CoreBind] - -> IO (SimplCount, [CoreBind]) -- New bindings - -simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds +simplifyPgmIO :: SimplifierMode + -> [SimplifierSwitch] + -> HscEnv + -> UniqSupply + -> RuleBase + -> ModGuts + -> IO (SimplCount, ModGuts) -- New bindings + +simplifyPgmIO mode switches hsc_env us hpt_rule_base + guts@(ModGuts { mg_binds = binds, mg_rules = rules + , mg_fam_inst_env = fam_inst_env }) = do { - (termination_msg, it_count, counts_out, binds') - <- do_iteration us 1 (zeroSimplCount dflags) binds ; + (termination_msg, it_count, counts_out, guts') + <- do_iteration us 1 (zeroSimplCount dflags) binds rules ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations", - text "", + blankLine, pprSimplCount counts_out]); - return (counts_out, binds') + return (counts_out, guts') } where - dflags = hsc_dflags hsc_env + dflags = hsc_dflags hsc_env + dump_phase = shouldDumpSimplPhase dflags mode sw_chkr = isAmongSimpl switches max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - do_iteration us iteration_no counts binds + do_iteration :: UniqSupply + -> Int -- Counts iterations + -> SimplCount -- Logs optimisations performed + -> [CoreBind] -- Bindings in + -> [CoreRule] -- and orphan rules + -> IO (String, Int, SimplCount, ModGuts) + + do_iteration us iteration_no counts binds rules -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations @@ -542,14 +551,15 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )) -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed - return ("Simplifier bailed out", iteration_no - 1, counts, binds) + return ("Simplifier bailed out", iteration_no - 1, counts, + guts { mg_binds = binds, mg_rules = rules }) -- Try and force thunks off the binds; significantly reduces -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds in sz == sz = do { -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ; + let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" (pprCoreBindings tagged_binds); @@ -559,7 +569,8 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin -- behind the scenes. Otherwise there's a danger we'll simply -- miss the rules for Ids hidden inside imported inlinings eps <- hscEPS hsc_env ; - let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps) + let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps) + ; rule_base2 = extendRuleBaseList rule_base1 rules ; simpl_env = mkSimplEnv mode sw_chkr ; simpl_binds = {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds @@ -576,19 +587,18 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin -- case t of {(_,counts') -> if counts'=0 then ... } -- So the conditional didn't force counts', because the -- selection got duplicated. Sigh! - case initSmpl dflags rule_base' fam_envs us1 simpl_binds of { - (binds', counts') -> do { + case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of { + (env1, counts1) -> do { - let { all_counts = counts `plusSimplCount` counts' - ; herald = "Simplifier mode " ++ showPpr mode ++ - ", iteration " ++ show iteration_no ++ - " out of " ++ show max_iterations + let { all_counts = counts `plusSimplCount` counts1 + ; binds1 = getFloats env1 + ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules } ; -- Stop if nothing happened; don't dump output - if isZeroSimplCount counts' then - return ("Simplifier reached fixed point", iteration_no, - all_counts, binds') + if isZeroSimplCount counts1 then + return ("Simplifier reached fixed point", iteration_no, all_counts, + guts { mg_binds = binds1, mg_rules = rules1 }) else do { -- Short out indirections -- We do this *after* at least one run of the simplifier @@ -598,18 +608,30 @@ simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env bin -- -- ToDo: alas, this means that indirection-shorting does not happen at all -- if the simplifier does nothing (not common, I know, but unsavoury) - let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ; + let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald - (pprSimplCount counts') ; - endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ; + endIteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ; -- Loop - do_iteration us2 (iteration_no + 1) all_counts binds'' + do_iteration us2 (iteration_no + 1) all_counts binds2 rules1 } } } } where (us1, us2) = splitUniqSupply us + +------------------- +endIteration :: DynFlags -> SimplifierMode -> Int -> Int + -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () +-- Same as endPass but with simplifier counts +endIteration dflags mode iteration_no max_iterations counts binds rules + = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name + (pprSimplCount counts) ; + + ; endPass dflags pass_name Opt_D_dump_simpl_iterations binds rules } + where + pass_name = "Simplifier mode " ++ showPpr mode ++ + ", iteration " ++ show iteration_no ++ + " out of " ++ show max_iterations \end{code} @@ -822,7 +844,7 @@ transferIdInfo exported_id local_id where local_info = idInfo local_id transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info - `setWorkerInfo` workerInfo local_info + `setUnfoldingInfo` unfoldingInfo local_info `setInlinePragInfo` inlinePragInfo local_info `setSpecInfo` addSpecInfo (specInfo exp_info) new_info new_info = setSpecInfoHead (idName exported_id) diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 0a7575a890..c10ad907b6 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -23,13 +23,13 @@ module SimplEnv ( mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, - getSimplRules, + getSimplRules, inGentleMode, SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, simplBinder, simplBinders, addBndrRules, - substExpr, substWorker, substTy, + substExpr, substTy, mkCoreSubst, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -49,7 +49,7 @@ import VarEnv import VarSet import OrdList import Id -import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) +import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substUnfolding ) import qualified Type ( substTy, substTyVarBndr ) import Type hiding ( substTy, substTyVarBndr ) import Coercion @@ -225,6 +225,11 @@ getMode env = seMode env setMode :: SimplifierMode -> SimplEnv -> SimplEnv setMode mode env = env { seMode = mode } +inGentleMode :: SimplEnv -> Bool +inGentleMode env = case seMode env of + SimplGently -> True + _other -> False + --------------------- getEnclosingCC :: SimplEnv -> CostCentreStack getEnclosingCC env = seCC env @@ -660,29 +665,6 @@ addBndrRules env in_id out_id old_rules = idSpecialisation in_id new_rules = CoreSubst.substSpec subst out_id old_rules final_id = out_id `setIdSpecialisation` new_rules - ------------------- -substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id - | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id - | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) - -- The tyVarsOfType is cheaper than it looks - -- because we cache the free tyvars of the type - -- in a Note in the id's type itself - where - old_ty = idType id - ------------------- -substUnfolding :: SimplEnv -> Unfolding -> Unfolding -substUnfolding _ NoUnfolding = NoUnfolding -substUnfolding _ (OtherCon cons) = OtherCon cons -substUnfolding env (CompulsoryUnfolding rhs) = CompulsoryUnfolding (substExpr env rhs) -substUnfolding env (CoreUnfolding rhs t u v w g) = CoreUnfolding (substExpr env rhs) t u v w g - ------------------- -substWorker :: SimplEnv -> WorkerInfo -> WorkerInfo -substWorker _ NoWorker = NoWorker -substWorker env wkr_info = CoreSubst.substWorker (mkCoreSubst env) wkr_info \end{code} @@ -718,9 +700,24 @@ mkCoreSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id fiddle (DoneId v) = Var v fiddle (ContEx tv id e) = CoreSubst.substExpr (mk_subst tv id) e +------------------ +substIdType :: SimplEnv -> Id -> Id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id + | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id + | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) + -- The tyVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + +------------------ substExpr :: SimplEnv -> CoreExpr -> CoreExpr substExpr env expr = CoreSubst.substExpr (mkCoreSubst env) expr -- Do *not* short-cut in the case of an empty substitution -- See CoreSubst: Note [Extending the Subst] + +substUnfolding :: SimplEnv -> Unfolding -> Unfolding +substUnfolding env unf = CoreSubst.substUnfolding (mkCoreSubst env) unf \end{code} diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 663f543b2c..c541096c40 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -10,14 +10,14 @@ module SimplUtils ( -- Inlining, preInlineUnconditionally, postInlineUnconditionally, - activeInline, activeRule, inlineMode, + activeInline, activeRule, -- The continuation type SimplCont(..), DupFlag(..), ArgInfo(..), contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, - countValArgs, countArgs, splitInlineCont, + countValArgs, countArgs, mkBoringStop, mkLazyArgStop, contIsRhsOrArg, - interestingCallContext, interestingArgContext, + interestingCallContext, interestingArg, mkArgInfo, @@ -215,34 +215,6 @@ dropArgs :: Int -> SimplCont -> SimplCont dropArgs 0 cont = cont dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont dropArgs n other = pprPanic "dropArgs" (ppr n <+> ppr other) - --------------------- -splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont) --- Returns Nothing if the continuation should dissolve an InlineMe Note --- Return Just (c1,c2) otherwise, --- where c1 is the continuation to put inside the InlineMe --- and c2 outside - --- Example: (__inline_me__ (/\a. e)) ty --- Here we want to do the beta-redex without dissolving the InlineMe --- See test simpl017 (and Trac #1627) for a good example of why this is important - -splitInlineCont (ApplyTo dup (Type ty) se c) - | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2) -splitInlineCont cont@(Stop {}) = Just (mkBoringStop, cont) -splitInlineCont cont@(StrictBind {}) = Just (mkBoringStop, cont) -splitInlineCont _ = Nothing - -- NB: we dissolve an InlineMe in any strict context, - -- not just function aplication. - -- E.g. foldr k z (__inline_me (case x of p -> build ...)) - -- Here we want to get rid of the __inline_me__ so we - -- can float the case, and see foldr/build - -- - -- However *not* in a strict RHS, else we get - -- let f = __inline_me__ (\x. e) in ...f... - -- Now if f is guaranteed to be called, hence a strict binding - -- we don't thereby want to dissolve the __inline_me__; for - -- example, 'f' might be a wrapper, so we'd inline the worker \end{code} @@ -320,24 +292,25 @@ interestingCallContext cont ------------------- mkArgInfo :: Id + -> [CoreRule] -- Rules for function -> Int -- Number of value args -> SimplCont -- Context of the call -> ArgInfo -mkArgInfo fun n_val_args call_cont +mkArgInfo fun rules n_val_args call_cont | n_val_args < idArity fun -- Note [Unsaturated functions] = ArgInfo { ai_rules = False , ai_strs = vanilla_stricts , ai_discs = vanilla_discounts } | otherwise - = ArgInfo { ai_rules = interestingArgContext fun call_cont + = ArgInfo { ai_rules = interestingArgContext rules call_cont , ai_strs = add_type_str (idType fun) arg_stricts , ai_discs = arg_discounts } where vanilla_discounts, arg_discounts :: [Int] vanilla_discounts = repeat 0 arg_discounts = case idUnfolding fun of - CoreUnfolding _ _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _) + CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_args = discounts}} -> discounts ++ vanilla_discounts _ -> vanilla_discounts @@ -391,7 +364,7 @@ it'll just be floated out again. Even if f has lots of discounts on its first argument -- it must be saturated for these to kick in -} -interestingArgContext :: Id -> SimplCont -> Bool +interestingArgContext :: [CoreRule] -> SimplCont -> Bool -- If the argument has form (f x y), where x,y are boring, -- and f is marked INLINE, then we don't want to inline f. -- But if the context of the argument is @@ -402,16 +375,18 @@ interestingArgContext :: Id -> SimplCont -> Bool -- where h has rules, then we do want to inline f; hence the -- call_cont argument to interestingArgContext -- --- The interesting_arg_ctxt flag makes this happen; if it's +-- The ai-rules flag makes this happen; if it's -- set, the inliner gets just enough keener to inline f -- regardless of how boring f's arguments are, if it's marked INLINE -- -- The alternative would be to *always* inline an INLINE function, -- regardless of how boring its context is; but that seems overkill -- For example, it'd mean that wrapper functions were always inlined -interestingArgContext fn call_cont - = idHasRules fn || go call_cont +interestingArgContext rules call_cont + = notNull rules || enclosing_fn_has_rules where + enclosing_fn_has_rules = go call_cont + go (Select {}) = False go (ApplyTo {}) = False go (StrictArg _ cci _ _) = interesting cci @@ -458,13 +433,7 @@ unboxed tuples and suchlike. INLINE pragmas ~~~~~~~~~~~~~~ -SimplGently is also used as the mode to simplify inside an InlineMe note. - -\begin{code} -inlineMode :: SimplifierMode -inlineMode = SimplGently -\end{code} - +We don't simplify inside InlineRules (which come from INLINE pragmas). It really is important to switch off inlinings inside such expressions. Consider the following example @@ -589,7 +558,7 @@ preInlineUnconditionally env top_lvl bndr rhs where phase = getMode env active = case phase of - SimplGently -> isAlwaysActive act + SimplGently -> isEarlyActive act SimplPhase n _ -> isActive n act act = idInlineActivation bndr @@ -674,7 +643,7 @@ story for now. \begin{code} postInlineUnconditionally :: SimplEnv -> TopLevelFlag - -> InId -- The binder (an OutId would be fine too) + -> OutId -- The binder (an InId would be fine too) -> OccInfo -- From the InId -> OutExpr -> Unfolding @@ -684,6 +653,7 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" | isExportedId bndr = False + | isInlineRule unfolding = False -- Note [InlineRule and postInlineUnconditionally] | exprIsTrivial rhs = True | otherwise = case occ_info of @@ -788,6 +758,23 @@ activeRule dflags env SimplPhase n _ -> Just (isActive n) \end{code} +Note [InlineRule and postInlineUnconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do not do postInlineUnconditionally if the Id has an InlineRule, otherwise +we lose the unfolding. Example + + -- f has InlineRule with rhs (e |> co) + -- where 'e' is big + f = e |> co + +Then there's a danger we'll optimise to + + f' = e + f = f' |> co + +and now postInlineUnconditionally, losing the InlineRule on f. Now f' +won't inline because 'e' is too big. + %************************************************************************ %* * @@ -803,7 +790,7 @@ mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam _b [] body = return body -mkLam _env bndrs body +mkLam env bndrs body = do { dflags <- getDOptsSmpl ; mkLam' dflags bndrs body } where @@ -824,7 +811,9 @@ mkLam _env bndrs body ; return etad_lam } | dopt Opt_DoLambdaEtaExpansion dflags, - any isRuntimeVar bndrs + not (inGentleMode env), -- In gentle mode don't eta-expansion + any isRuntimeVar bndrs -- because it can clutter up the code + -- with casts etc that may not be removed = do { let body' = tryEtaExpansion dflags body ; return (mkLams bndrs body') } diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 18b3fc66b2..1b46aa9fe2 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -20,12 +20,14 @@ import Var import IdInfo import Coercion import FamInstEnv ( topNormaliseType ) -import DataCon ( dataConRepStrictness, dataConUnivTyVars ) +import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) import CoreSyn import NewDemand ( isStrictDmd, splitStrictSig ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) +import CoreUnfold ( mkUnfolding, mkCoreUnfolding, mkInlineRule, + exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) import CoreUtils +import qualified CoreSubst import CoreArity ( exprArity ) import Rules ( lookupRule, getRules ) import BasicTypes ( isMarkedStrict, Arity ) @@ -34,6 +36,7 @@ import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRuleLoopBreaker ) +import MonadUtils ( foldlM ) import Maybes ( orElse ) import Data.List ( mapAccumL ) import Outputable @@ -201,7 +204,7 @@ expansion at a let RHS can concentrate solely on the PAP case. %************************************************************************ \begin{code} -simplTopBinds :: SimplEnv -> [InBind] -> SimplM [OutBind] +simplTopBinds :: SimplEnv -> [InBind] -> SimplM SimplEnv simplTopBinds env0 binds0 = do { -- Put all the top-level binders into scope at the start @@ -214,7 +217,7 @@ simplTopBinds env0 binds0 dopt Opt_D_dump_rule_firings dflags ; env2 <- simpl_binds dump_flag env1 binds0 ; freeTick SimplifierDone - ; return (getFloats env2) } + ; return env2 } where -- We need to track the zapped top-level binders, because -- they should have their fragile IdInfo zapped (notably occurrence info) @@ -351,7 +354,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se do { tick LetFloatFromLet ; (poly_binds, body3) <- abstractFloats tvs' body_env2 body2 ; rhs' <- mkLam env tvs' body3 - ; let env' = foldl (addPolyBind top_lvl) env poly_binds + ; env' <- foldlM (addPolyBind top_lvl) env poly_binds ; return (env', rhs') } ; completeBind env' top_lvl bndr bndr1 rhs' } @@ -462,6 +465,7 @@ prepareRhs env0 rhs0 is_val = n_val_args > 0 -- There is at least one arg -- ...and the fun a constructor or PAP && (isConLikeId fun || n_val_args < idArity fun) + -- See Note [CONLIKE pragma] in BasicTypes go _ env other = return (False, env, other) \end{code} @@ -566,29 +570,23 @@ completeBind :: SimplEnv -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs - | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding - -- Inline and discard the binding - = do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $ - return (extendIdSubst env old_bndr (DoneEx new_rhs)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding + = do { let old_info = idInfo old_bndr + old_unf = unfoldingInfo old_info + occ_info = occInfo old_info - | otherwise - = return (addNonRecWithUnf env new_bndr new_rhs unfolding wkr) - where - unfolding | omit_unfolding = NoUnfolding - | otherwise = mkUnfolding (isTopLevel top_lvl) new_rhs - old_info = idInfo old_bndr - occ_info = occInfo old_info - wkr = substWorker env (workerInfo old_info) - omit_unfolding = isNonRuleLoopBreaker occ_info - -- or not (activeInline env old_bndr) - -- Do *not* trim the unfolding in SimplGently, else - -- the specialiser can't see it! - ------------------ -addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv + ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info new_rhs old_unf + + ; if postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs new_unfolding + -- Inline and discard the binding + then do { tick (PostInlineUnconditionally old_bndr) + ; return (extendIdSubst env old_bndr (DoneEx new_rhs)) } + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding + + else return (addNonRecWithUnf env new_bndr new_rhs new_unfolding) } + +------------------------------ +addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplM SimplEnv -- Add a new binding to the environment, complete with its unfolding -- but *do not* do postInlineUnconditionally, because we have already -- processed some of the scope of the binding @@ -601,71 +599,73 @@ addPolyBind :: TopLevelFlag -> SimplEnv -> OutBind -> SimplEnv -- opportunity to inline 'y' too. addPolyBind top_lvl env (NonRec poly_id rhs) - = addNonRecWithUnf env poly_id rhs unfolding NoWorker - where - unfolding | not (activeInline env poly_id) = NoUnfolding - | otherwise = mkUnfolding (isTopLevel top_lvl) rhs - -- addNonRecWithInfo adds the new binding in the - -- proper way (ie complete with unfolding etc), - -- and extends the in-scope set + = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding + -- Assumes that poly_id did not have an INLINE prag + -- which is perhaps wrong. ToDo: think about this + ; return (addNonRecWithUnf env poly_id rhs unfolding) } -addPolyBind _ env bind@(Rec _) = extendFloats env bind +addPolyBind _ env bind@(Rec _) = return (extendFloats env bind) -- Hack: letrecs are more awkward, so we extend "by steam" -- without adding unfoldings etc. At worst this leads to -- more simplifier iterations ------------------ +------------------------------ addNonRecWithUnf :: SimplEnv - -> OutId -> OutExpr -- New binder and RHS - -> Unfolding -> WorkerInfo -- and unfolding - -> SimplEnv --- Add suitable IdInfo to the Id, add the binding to the floats, and extend the in-scope set -addNonRecWithUnf env new_bndr rhs unfolding wkr - = ASSERT( isId new_bndr ) + -> OutId -> OutExpr -- New binder and RHS + -> Unfolding -- New unfolding + -> SimplEnv +addNonRecWithUnf env new_bndr new_rhs new_unfolding + = let new_arity = exprArity new_rhs + old_arity = idArity new_bndr + info1 = idInfo new_bndr `setArityInfo` new_arity + + -- Unfolding info: Note [Setting the new unfolding] + info2 = info1 `setUnfoldingInfo` new_unfolding + + -- Demand info: Note [Setting the demand info] + info3 | isEvaldUnfolding new_unfolding = zapDemandInfo info2 `orElse` info2 + | otherwise = info2 + + final_id = new_bndr `setIdInfo` info3 + dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr + in + ASSERT( isId new_bndr ) WARN( new_arity < old_arity || new_arity < dmd_arity, (ptext (sLit "Arity decrease:") <+> ppr final_id <+> ppr old_arity - <+> ppr new_arity <+> ppr dmd_arity) $$ ppr rhs ) + <+> ppr new_arity <+> ppr dmd_arity) $$ ppr new_rhs ) -- Note [Arity decrease] - final_id `seq` -- This seq forces the Id, and hence its IdInfo, - -- and hence any inner substitutions - addNonRec env final_id rhs - -- The addNonRec adds it to the in-scope set too - where - dmd_arity = length $ fst $ splitStrictSig $ idNewStrictness new_bndr - old_arity = idArity new_bndr - -- Arity info - new_arity = exprArity rhs - new_bndr_info = idInfo new_bndr `setArityInfo` new_arity - - -- Unfolding info - -- Add the unfolding *only* for non-loop-breakers - -- Making loop breakers not have an unfolding at all - -- means that we can avoid tests in exprIsConApp, for example. - -- This is important: if exprIsConApp says 'yes' for a recursive - -- thing, then we can get into an infinite loop - - -- Demand info - -- If the unfolding is a value, the demand info may - -- go pear-shaped, so we nuke it. Example: - -- let x = (a,b) in - -- case x of (p,q) -> h p q x - -- Here x is certainly demanded. But after we've nuked - -- the case, we'll get just - -- let x = (a,b) in h a b x - -- and now x is not demanded (I'm assuming h is lazy) - -- This really happens. Similarly - -- let f = \x -> e in ...f..f... - -- After inlining f at some of its call sites the original binding may - -- (for example) be no longer strictly demanded. - -- The solution here is a bit ad hoc... - info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding - `setWorkerInfo` wkr - - final_info | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf - | otherwise = info_w_unf - - final_id = new_bndr `setIdInfo` final_info + final_id `seq` -- This seq forces the Id, and hence its IdInfo, + -- and hence any inner substitutions + -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + addNonRec env final_id new_rhs + -- The addNonRec adds it to the in-scope set too + +------------------------------ +simplUnfolding :: SimplEnv-> TopLevelFlag + -> Id -- Debug output only + -> OccInfo -> OutExpr + -> Unfolding -> SimplM Unfolding +-- Note [Setting the new unfolding] +simplUnfolding env _ _ _ _ (DFunUnfolding con ops) + = return (DFunUnfolding con ops') + where + ops' = map (CoreSubst.substExpr (mkCoreSubst env)) ops + +simplUnfolding env top_lvl _ _ _ + (CoreUnfolding { uf_tmpl = expr, uf_arity = arity + , uf_guidance = guide@(InlineRule {}) }) + = do { expr' <- simplExpr (setMode SimplGently env) expr + ; let mb_wkr' = CoreSubst.substInlineRuleGuidance (mkCoreSubst env) (ug_ir_info guide) + ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity + (guide { ug_ir_info = mb_wkr' })) } + -- See Note [Top-level flag on inline rules] in CoreUnfold + +simplUnfolding _ top_lvl _ occ_info new_rhs _ + | omit_unfolding = return NoUnfolding + | otherwise = return (mkUnfolding (isTopLevel top_lvl) new_rhs) + where + omit_unfolding = isNonRuleLoopBreaker occ_info \end{code} Note [Arity decrease] @@ -691,6 +691,38 @@ Here opInt has arity 1; but when we apply the rule its arity drops to 0. That's why Specialise goes to a little trouble to pin the right arity on specialised functions too. +Note [Setting the new unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* If there's an INLINE pragma, we simplify the RHS gently. Maybe we + should do nothing at all, but simplifying gently might get rid of + more crap. + +* If not, we make an unfolding from the new RHS. But *only* for + non-loop-breakers. Making loop breakers not have an unfolding at all + means that we can avoid tests in exprIsConApp, for example. This is + important: if exprIsConApp says 'yes' for a recursive thing, then we + can get into an infinite loop + +If there's an InlineRule on a loop breaker, we hang on to the inlining. +It's pretty dodgy, but the user did say 'INLINE'. May need to revisit +this choice. + +Note [Setting the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the unfolding is a value, the demand info may +go pear-shaped, so we nuke it. Example: + let x = (a,b) in + case x of (p,q) -> h p q x +Here x is certainly demanded. But after we've nuked +the case, we'll get just + let x = (a,b) in h a b x +and now x is not demanded (I'm assuming h is lazy) +This really happens. Similarly + let f = \x -> e in ...f..f... +After inlining f at some of its call sites the original binding may +(for example) be no longer strictly demanded. +The solution here is a bit ad hoc... + %************************************************************************ %* * @@ -954,7 +986,7 @@ simplLam env bndrs body cont ------------------ simplNonRecE :: SimplEnv - -> InId -- The binder + -> InBndr -- The binder -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) -> ([InBndr], InExpr) -- Body of the let/lambda -- \xs.e @@ -1016,21 +1048,9 @@ simplNote env (SCC cc) e cont = do { e' <- simplExpr (setEnclosingCC env currentCCS) e ; rebuild env (mkSCC cc e') cont } --- See notes with SimplMonad.inlineMode -simplNote env InlineMe e cont - | Just (inside, outside) <- splitInlineCont cont -- Boring boring continuation; see notes above - = do { -- Don't inline inside an INLINE expression - e' <- simplExprC (setMode inlineMode env) e inside - ; rebuild env (mkInlineMe e') outside } - - | otherwise -- Dissolve the InlineMe note if there's - -- an interesting context of any kind to combine with - -- (even a type application -- anything except Stop) - = simplExprF env e cont - -simplNote env (CoreNote s) e cont = do - e' <- simplExpr env e - rebuild env (Note (CoreNote s) e') cont +simplNote env (CoreNote s) e cont + = do { e' <- simplExpr env e + ; rebuild env (Note (CoreNote s) e') cont } \end{code} @@ -1080,7 +1100,9 @@ completeCall env var cont -- later phase, so but now we just try RULES first -- -- See also Note [Rules for recursive functions] - ; mb_rule <- tryRules env var args call_cont + ; rule_base <- getSimplRules + ; let rules = getRules rule_base var + ; mb_rule <- tryRules env var rules args call_cont ; case mb_rule of { Just (n_args, rule_rhs) -> simplExprF env rule_rhs (dropArgs n_args cont) ; -- The ruleArity says how many args the rule consumed @@ -1113,7 +1135,8 @@ completeCall env var cont -- Next, look for rules or specialisations that match -- rebuildCall env (Var var) - (mkArgInfo var n_val_args call_cont) cont + (mkArgInfo var rules n_val_args call_cont) + cont }}}} rebuildCall :: SimplEnv @@ -1203,33 +1226,33 @@ all this at once is TOO HARD! %************************************************************************ \begin{code} -tryRules :: SimplEnv -> Id -> [OutExpr] -> SimplCont +tryRules :: SimplEnv + -> Id -> [CoreRule] -> [OutExpr] -> SimplCont -> SimplM (Maybe (Arity, CoreExpr)) -- The arity is the number of -- args consumed by the rule -tryRules env fn args call_cont - = do { dflags <- getDOptsSmpl - ; rule_base <- getSimplRules - ; let in_scope = getInScope env - rules = getRules rule_base fn - maybe_rule = case activeRule dflags env of - Nothing -> Nothing -- No rules apply - Just act_fn -> lookupRule act_fn in_scope - fn args rules - ; case (rules, maybe_rule) of { - ([], _) -> return Nothing ; - (_, Nothing) -> return Nothing ; - (_, Just (rule, rule_rhs)) -> do - - { tick (RuleFired (ru_name rule)) - ; (if dopt Opt_D_dump_rule_firings dflags then - pprTrace "Rule fired" (vcat [ +tryRules env fn rules args call_cont + | null rules + = return Nothing + | otherwise + = do { dflags <- getDOptsSmpl + ; case activeRule dflags env of { + Nothing -> return Nothing ; -- No rules apply + Just act_fn -> + + case lookupRule act_fn (getInScope env) fn args rules of { + Nothing -> return Nothing ; -- No rule matches + Just (rule, rule_rhs) -> + + do { tick (RuleFired (ru_name rule)) + ; (if dopt Opt_D_dump_rule_firings dflags then + pprTrace "Rule fired" (vcat [ text "Rule:" <+> ftext (ru_name rule), text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) - else + else id) $ - return (Just (ruleArity rule, rule_rhs)) }}} + return (Just (ruleArity rule, rule_rhs)) }}}} \end{code} Note [Rules for recursive functions] @@ -1356,14 +1379,27 @@ rebuildCase, reallyRebuildCase -------------------------------------------------- rebuildCase env scrut case_bndr alts cont - | Just (con,args) <- exprIsConApp_maybe scrut - -- Works when the scrutinee is a variable with a known unfolding - -- as well as when it's an explicit constructor application - = knownCon env scrut (DataAlt con) args case_bndr alts cont - | Lit lit <- scrut -- No need for same treatment as constructors -- because literals are inlined more vigorously - = knownCon env scrut (LitAlt lit) [] case_bndr alts cont + = do { tick (KnownBranch case_bndr) + ; case findAlt (LitAlt lit) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (_, bs, rhs) -> simple_rhs bs rhs } + + | Just (con, ty_args, other_args) <- exprIsConApp_maybe scrut + -- Works when the scrutinee is a variable with a known unfolding + -- as well as when it's an explicit constructor application + = do { tick (KnownBranch case_bndr) + ; case findAlt (DataAlt con) alts of + Nothing -> missingAlt env case_bndr alts cont + Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs + Just (_, bs, rhs) -> knownCon env scrut con ty_args other_args + case_bndr bs rhs cont + } + where + simple_rhs bs rhs = ASSERT( null bs ) + do { env' <- simplNonRecX env case_bndr scrut + ; simplExprF env' rhs cont } -------------------------------------------------- @@ -1417,7 +1453,10 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont out_args = [Type (substTy env (idType case_bndr)), Type (exprType rhs'), scrut, rhs'] -- Lazily evaluated, so we don't do most of this - ; mb_rule <- tryRules env seqId out_args cont + + ; rule_base <- getSimplRules + ; let rules = getRules rule_base seqId + ; mb_rule <- tryRules env seqId rules out_args cont ; case mb_rule of Just (n_args, res) -> simplExprF (zapSubstEnv env) (mkApps res (drop n_args out_args)) @@ -1471,6 +1510,19 @@ The point is that we bring into the envt a binding after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. +In practice, the scrutinee is almost always a variable, so we pretty +much always zap the OccInfo of the binders. It doesn't matter much though. + + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (v `cast` co) of x { I# -> + ... (case (v `cast` co) of {...}) ... +We'd like to eliminate the inner case. We can get this neatly by +arranging that inside the outer case we add the unfolding + v |-> x `cast` (sym co) +to v. Then we should inline v at the inner case, cancel the casts, and away we go + Note [Improving seq] ~~~~~~~~~~~~~~~~~~~ Consider @@ -1720,26 +1772,15 @@ and then All this should happen in one sweep. \begin{code} -knownCon :: SimplEnv -> OutExpr -> AltCon - -> [OutExpr] -- Args *including* the universal args - -> InId -> [InAlt] -> SimplCont - -> SimplM (SimplEnv, OutExpr) - -knownCon env scrut con args bndr alts cont - = do { tick (KnownBranch bndr) - ; case findAlt con alts of - Nothing -> missingAlt env bndr alts cont - Just alt -> knownAlt env scrut args bndr alt cont - } - -------------------- -knownAlt :: SimplEnv -> OutExpr -> [OutExpr] - -> InId -> InAlt -> SimplCont +knownCon :: SimplEnv + -> OutExpr -- The scrutinee + -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces) + -> InId -> [InBndr] -> InExpr -- The alternative + -> SimplCont -> SimplM (SimplEnv, OutExpr) -knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont - = do { let n_drop_tys = length (dataConUnivTyVars dc) - ; env' <- bind_args env bs (drop n_drop_tys the_args) +knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont + = do { env' <- bind_args env bs dc_args ; let -- It's useful to bind bndr to scrut, rather than to a fresh -- binding x = Con arg1 .. argn @@ -1748,12 +1789,12 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont -- BUT, if scrut is a not a variable, we must be careful -- about duplicating the arg redexes; in that case, make -- a new con-app from the args - bndr_rhs = case scrut of - Var _ -> scrut - _ -> con_app - con_app = mkConApp dc (take n_drop_tys the_args ++ con_args) - con_args = [substExpr env' (varToCoreExpr b) | b <- bs] - -- args are aready OutExprs, but bs are InIds + bndr_rhs | exprIsTrivial scrut = scrut + | otherwise = con_app + con_app = Var (dataConWorkId dc) + `mkTyApps` dc_ty_args + `mkApps` [substExpr env' (varToCoreExpr b) | b <- bs] + -- dc_ty_args are aready OutTypes, but bs are InBndrs ; env'' <- simplNonRecX env' bndr bndr_rhs ; simplExprF env'' rhs cont } @@ -1779,15 +1820,9 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont ; bind_args env'' bs' args } bind_args _ _ _ = - pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr the_args $$ + pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$ text "scrut:" <+> ppr scrut -knownAlt env scrut _ bndr (_, bs, rhs) cont - = ASSERT( null bs ) -- Works for LitAlt and DEFAULT - do { env' <- simplNonRecX env bndr scrut - ; simplExprF env' rhs cont } - - ------------------- missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExpr) -- This isn't strictly an error, although it is unusual. @@ -1920,12 +1955,31 @@ mkDupableAlts env case_bndr' the_alts mkDupableAlt :: SimplEnv -> OutId -> (AltCon, [CoreBndr], CoreExpr) -> SimplM (SimplEnv, (AltCon, [CoreBndr], CoreExpr)) -mkDupableAlt env case_bndr' (con, bndrs', rhs') +mkDupableAlt env case_bndr (con, bndrs', rhs') | exprIsDupable rhs' -- Note [Small alternative rhs] = return (env, (con, bndrs', rhs')) | otherwise - = do { let rhs_ty' = exprType rhs' - used_bndrs' = filter abstract_over (case_bndr' : bndrs') + = do { let rhs_ty' = exprType rhs' + scrut_ty = idType case_bndr + case_bndr_w_unf + = case con of + DEFAULT -> case_bndr + DataAlt dc -> setIdUnfolding case_bndr unf + where + -- See Note [Case binders and join points] + unf = mkInlineRule InlSat rhs 0 + rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty) + ++ varsToCoreExprs bndrs') + + LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt") + <+> ppr case_bndr <+> ppr con ) + case_bndr + -- The case binder is alive but trivial, so why has + -- it not been substituted away? + + used_bndrs' | isDeadBinder case_bndr = filter abstract_over bndrs' + | otherwise = bndrs' ++ [case_bndr_w_unf] + abstract_over bndr | isTyVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) @@ -1950,10 +2004,42 @@ mkDupableAlt env case_bndr' (con, bndrs', rhs') join_rhs = mkLams really_final_bndrs rhs' join_call = mkApps (Var join_bndr) final_args - ; return (addPolyBind NotTopLevel env (NonRec join_bndr join_rhs), (con, bndrs', join_call)) } + ; env' <- addPolyBind NotTopLevel env (NonRec join_bndr join_rhs) + ; return (env', (con, bndrs', join_call)) } -- See Note [Duplicated env] \end{code} +Note [Case binders and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + case (case .. ) of c { + I# c# -> ....c.... + +If we make a join point with c but not c# we get + $j = \c -> ....c.... + +But if later inlining scrutines the c, thus + + $j = \c -> ... case c of { I# y -> ... } ... + +we won't see that 'c' has already been scrutinised. This actually +happens in the 'tabulate' function in wave4main, and makes a significant +difference to allocation. + +An alternative plan is this: + + $j = \c# -> let c = I# c# in ...c.... + +but that is bad if 'c' is *not* later scrutinised. + +So instead we do both: we pass 'c' and 'c#' , and record in c's inlining +that it's really I# c#, thus + + $j = \c# -> \c[=I# c#] -> ...c.... + +Absence analysis may later discard 'c'. + + Note [Duplicated env] ~~~~~~~~~~~~~~~~~~~~~ Some of the alternatives are simplified, but have not been turned into a join point diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs index 028ec836d1..cc5054a10c 100644 --- a/compiler/specialise/Rules.lhs +++ b/compiler/specialise/Rules.lhs @@ -22,9 +22,9 @@ module Rules ( addIdSpecialisations, -- * Misc. CoreRule helpers - rulesOfBinds, getRules, pprRulesForUser, + rulesOfBinds, getRules, pprRulesForUser, expandId, - lookupRule, mkLocalRule, roughTopNames + lookupRule, mkRule, mkLocalRule, roughTopNames ) where #include "HsVersions.h" @@ -96,11 +96,18 @@ mkLocalRule :: RuleName -> Activation -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'CoreSyn.CoreRule' -mkLocalRule name act fn bndrs args rhs +mkLocalRule = mkRule True + +mkRule :: Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'CoreSyn.CoreRule' +mkRule is_local name act fn bndrs args rhs = Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, ru_args = args, - ru_rhs = rhs, ru_rough = roughTopNames args, - ru_local = True } + ru_rhs = occurAnalyseExpr rhs, + ru_rough = roughTopNames args, + ru_local = is_local } -------------- roughTopNames :: [CoreExpr] -> [Maybe Name] @@ -192,18 +199,32 @@ rulesOfBinds :: [CoreBind] -> [CoreRule] rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds getRules :: RuleBase -> Id -> [CoreRule] - -- The rules for an Id come from two places: - -- (a) the ones it is born with (idCoreRules fn) - -- (b) rules added in subsequent modules (extra_rules) - -- PrimOps, for example, are born with a bunch of rules under (a) +-- See Note [Where rules are found] getRules rule_base fn - | isLocalId fn = idCoreRules fn - | otherwise = WARN( not (isPrimOpId fn) && notNull (idCoreRules fn), - ppr fn <+> ppr (idCoreRules fn) ) - idCoreRules fn ++ (lookupNameEnv rule_base (idName fn) `orElse` []) - -- Only PrimOpIds have rules inside themselves, and perhaps more besides + = idCoreRules fn ++ imp_rules + where + imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] \end{code} +Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in PrelRules.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + %************************************************************************ %* * @@ -355,6 +376,7 @@ matchRule :: (Activation -> Bool) -> InScopeSet matchRule _is_active _in_scope args _rough_args (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems = case match_fn args of Just expr -> Just expr Nothing -> Nothing @@ -828,7 +850,6 @@ eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && eqExpr (rnBndrs2 env vs1 vs2) r1 eq_note :: RnEnv2 -> Note -> Note -> Bool eq_note _ (SCC cc1) (SCC cc2) = cc1 == cc2 eq_note _ (CoreNote s1) (CoreNote s2) = s1 == s2 -eq_note _ (InlineMe) (InlineMe) = True eq_note _ _ _ = False \end{code} diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index 590e689f4a..c51b27de3f 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -17,7 +17,7 @@ module Specialise ( specProgram ) where import Id import TcType import CoreSubst -import CoreUnfold ( mkUnfolding ) +import CoreUnfold ( mkUnfolding, mkInlineRule ) import VarSet import VarEnv import CoreSyn @@ -29,6 +29,7 @@ import Name import MkId ( voidArgId, realWorldPrimId ) import FiniteMap import Maybes ( catMaybes, isJust ) +import BasicTypes ( Arity ) import Bag import Util import Outputable @@ -800,17 +801,27 @@ specDefn subst body_uds fn rhs where fn_type = idType fn fn_arity = idArity fn + fn_unf = idUnfolding fn (tyvars, theta, _) = tcSplitSigmaTy fn_type n_tyvars = length tyvars n_dicts = length theta inline_act = idInlineActivation fn - (body_uds_without_me, calls_for_me) = callsForMe fn body_uds + -- Figure out whether the function has an INLINE pragma + -- See Note [Inline specialisations] + fn_has_inline_rule :: Maybe (InlineRuleInfo, Arity) -- Gives arity of the *specialised* inline rule + fn_has_inline_rule + | Just inl <- isInlineRule_maybe fn_unf + = case inl of + InlWrapper _ -> Just (InlUnSat, spec_arity) + _ -> Just (inl, spec_arity) + | otherwise = Nothing + where + spec_arity = unfoldingArity fn_unf - n_dicts - -- It's important that we "see past" any INLINE pragma - -- else we'll fail to specialise an INLINE thing - (inline_rhs, rhs_inside) = dropInline rhs - (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs_inside + (rhs_tyvars, rhs_ids, rhs_body) = collectTyAndValBinders rhs + + (body_uds_without_me, calls_for_me) = callsForMe fn body_uds rhs_dict_ids = take n_dicts rhs_ids body = mkLams (drop n_dicts rhs_ids) rhs_body @@ -898,10 +909,14 @@ specDefn subst body_uds fn rhs -- Add the { d1' = dx1; d2' = dx2 } usage stuff final_uds = foldr consDictBind rhs_uds dx_binds - spec_pr | inline_rhs = (spec_f_w_arity `setInlineActivation` inline_act, Note InlineMe spec_rhs) - | otherwise = (spec_f_w_arity, spec_rhs) - - ; return (Just (spec_pr, final_uds, spec_env_rule)) } } + -- See Note [Inline specialisations] + final_spec_f | Just (inl, spec_arity) <- fn_has_inline_rule + = spec_f_w_arity `setInlineActivation` inline_act + `setIdUnfolding` mkInlineRule inl spec_rhs spec_arity + -- I'm not sure this should be unconditionally InlSat + | otherwise + = spec_f_w_arity + ; return (Just ((final_spec_f, spec_rhs), final_uds, spec_env_rule)) } } where my_zipEqual xs ys zs | debugIsOn && not (equalLength xs ys && equalLength ys zs) @@ -1157,11 +1172,6 @@ specialised version. A case in point is dictionary functions, which are current marked INLINE, but which are worth specialising. -\begin{code} -dropInline :: CoreExpr -> (Bool, CoreExpr) -dropInline (Note InlineMe rhs) = (True, rhs) -dropInline rhs = (False, rhs) -\end{code} %************************************************************************ %* * diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs index 6dc0fb7118..789e77aa5d 100644 --- a/compiler/stranal/DmdAnal.lhs +++ b/compiler/stranal/DmdAnal.lhs @@ -50,11 +50,11 @@ import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, keysUFM, minusUFM, ufmToList, filterUFM ) import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) -import CoreLint ( showPass, endPass ) import Util ( mapAndUnzip, lengthIs ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec ) import Maybes ( orElse, expectJust ) +import ErrUtils ( showPass ) import Outputable import Data.List diff --git a/compiler/stranal/StrictAnal.lhs b/compiler/stranal/StrictAnal.lhs index a5efe30d39..920f8415ef 100644 --- a/compiler/stranal/StrictAnal.lhs +++ b/compiler/stranal/StrictAnal.lhs @@ -29,7 +29,6 @@ import Id ( setIdStrictness, setInlinePragma, idDemandInfo, setIdDemandInfo, isBottomingId, Id ) -import CoreLint ( showPass, endPass ) import ErrUtils ( dumpIfSet_dyn ) import SaAbsInt import SaLib diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs index 7b124f303f..d23e83ece2 100644 --- a/compiler/stranal/WorkWrap.lhs +++ b/compiler/stranal/WorkWrap.lhs @@ -7,11 +7,14 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn -import CoreUnfold ( certainlyWillInline ) -import CoreUtils ( exprType, exprIsHNF, mkInlineMe ) +import CoreUnfold ( certainlyWillInline, mkInlineRule, mkWwInlineRule ) +import CoreUtils ( exprType, exprIsHNF ) import CoreArity ( exprArity ) import Var -import Id +import Id ( idType, isOneShotLambda, idUnfolding, + setIdNewStrictness, mkWorkerId, + setInlineActivation, setIdUnfolding, + setIdArity ) import Type ( Type ) import IdInfo import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), @@ -102,11 +105,9 @@ matching by looking for strict arguments of the correct type. \begin{code} wwExpr :: CoreExpr -> UniqSM CoreExpr -wwExpr e@(Type {}) = return e -wwExpr e@(Lit {}) = return e -wwExpr e@(Var {}) = return e -wwExpr e@(Note InlineMe _) = return e - -- Don't w/w inside InlineMe's +wwExpr e@(Type {}) = return e +wwExpr e@(Lit {}) = return e +wwExpr e@(Var {}) = return e wwExpr (Lam binder expr) = Lam binder <$> wwExpr expr @@ -155,7 +156,10 @@ The only reason this is monadised is for the unique supply. Note [Don't w/w inline things (a)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's very important to refrain from w/w-ing an INLINE function -If we do so by mistake we transform +because the wrapepr will then overwrite the InlineRule unfolding. + +It was wrong with the old InlineMe Note too: if we do so by mistake +we transform f = __inline (\x -> E) into f = __inline (\x -> case x of (a,b) -> fw E) @@ -242,14 +246,22 @@ tryWW is_rec fn_id rhs is_thunk = not is_fun && not (exprIsHNF rhs) --------------------- -checkSize :: Id -> CoreExpr -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)] +checkSize :: Id -> CoreExpr + -> UniqSM [(Id,CoreExpr)] -> UniqSM [(Id,CoreExpr)] -- See Note [Don't w/w inline things (a) and (b)] checkSize fn_id rhs thing_inside - | certainlyWillInline unfolding = return [ (fn_id, mkInlineMe rhs) ] + | isStableUnfolding unfolding -- For DFuns and INLINE things, leave their + = return [ (fn_id, rhs) ] -- unfolding unchanged; but still attach + -- strictness info to the Id + + | certainlyWillInline unfolding + = return [ (fn_id `setIdUnfolding` inline_rule, rhs) ] -- Note [Don't w/w inline things (b)] + | otherwise = thing_inside where unfolding = idUnfolding fn_id + inline_rule = mkInlineRule InlUnSat rhs (unfoldingArity unfolding) --------------------- splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Activation -> Expr Var @@ -279,7 +291,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_act rhs -- arity is consistent with the demand type goes through wrap_rhs = wrap_fn work_id - wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule work_id wrap_rhs arity ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) }) -- Worker first, because wrapper mentions it diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs index bceb453487..2c3581c64c 100644 --- a/compiler/stranal/WwLib.lhs +++ b/compiler/stranal/WwLib.lhs @@ -134,7 +134,7 @@ mkWwBodies fun_ty demands res_info one_shots ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty ; return ([idNewDemandInfo v | v <- work_call_args, isId v], - Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, + wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var, mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args) } -- We use an INLINE unconditionally, even if the wrapper turns out to be -- something trivial like diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a45422adb3..b237778d07 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -246,7 +246,9 @@ tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie) -------------------------- instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds instToDictBind inst rhs - = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs)) + = unitBag (L (instSpan inst) (VarBind { var_id = instToId inst + , var_rhs = rhs + , var_inline = False })) addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 7a7edb42cf..f21bbe609d 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -45,6 +45,7 @@ import BasicTypes import Outputable import FastString +import Data.List( partition ) import Control.Monad \end{code} @@ -350,7 +351,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -- BUILD THE POLYMORPHIC RESULT IDs ; let dict_vars = map instToVar dicts -- May include equality constraints - ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars)) + ; exports <- mapM (mkExport top_lvl rec_group (length mono_bind_infos > 1) + prag_fn tyvars_to_gen (map varType dict_vars)) mono_bind_infos ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports] @@ -365,9 +367,12 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds -------------- -mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] +mkExport :: TopLevelFlag -> RecFlag + -> Bool -- More than one variable is bound, so we'll desugar to + -- a tuple, so INLINE pragmas won't work + -> TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo - -> TcM ([TyVar], Id, Id, [LPrag]) + -> TcM ([TyVar], Id, Id, [LSpecPrag]) -- mkExport generates exports with -- zonked type variables, -- zonked poly_ids @@ -379,16 +384,18 @@ mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType] -- Pre-condition: the inferred_tvs are already zonked -mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id) +mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys + (poly_name, mb_sig, mono_id) = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs ; let warn = isTopLevel top_lvl && warn_missing_sigs ; (tvs, poly_id) <- mk_poly_id warn mb_sig -- poly_id has a zonked type - ; prags <- tcPrags poly_id (prag_fn poly_name) + ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull dict_tys) + poly_id (prag_fn poly_name) -- tcPrags requires a zonked poly_id - ; return (tvs, poly_id, mono_id, prags) } + ; return (tvs, poly_id', mono_id, spec_prags) } where poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id)) @@ -411,34 +418,89 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` [] env = foldl add emptyNameEnv prs add env (n,p) = extendNameEnv_Acc (:) singleton env n p -tcPrags :: Id -> [LSig Name] -> TcM [LPrag] -tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags - where - tc_prag prag = addErrCtxt (pragSigCtxt prag) $ - tcPrag poly_id prag - -pragSigCtxt :: Sig Name -> SDoc -pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag) - -tcPrag :: TcId -> Sig Name -> TcM Prag +tcPrags :: RecFlag + -> Bool -- True <=> AbsBinds binds more than one variable + -> Bool -- True <=> function is overloaded + -> Id -> [LSig Name] + -> TcM (Id, [LSpecPrag]) +-- Add INLINE and SPECLIASE pragmas +-- INLINE prags are added to the Id directly +-- SPECIALISE prags are passed to the desugarer via [LSpecPrag] -- Pre-condition: the poly_id is zonked -- Reason: required by tcSubExp --- Most of the work of specialisation is done by --- the desugarer, guided by the SpecPrag -tcPrag poly_id (SpecSig _ hs_ty inl) - = do { let name = idName poly_id +tcPrags _rec_group _multi_bind _is_overloaded_id poly_id prag_sigs + = do { poly_id' <- tc_inl inl_sigs + + ; spec_prags <- mapM (wrapLocM (tcSpecPrag poly_id')) spec_sigs + +-- Commented out until bytestring library removes redundant pragmas +-- for packWith and unpackWith +-- ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec + + ; unless (null bad_sigs) warn_discarded_sigs + + ; return (poly_id', spec_prags) } + where + (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs + (spec_sigs, bad_sigs) = partition isSpecLSig other_sigs + +-- warn_discarded_spec = warnPrags poly_id spec_sigs $ +-- ptext (sLit "SPECIALISE pragmas for non-overloaded function") + warn_dup_inline = warnPrags poly_id inl_sigs $ + ptext (sLit "Duplicate INLINE pragmas for") + warn_discarded_sigs = warnPrags poly_id bad_sigs $ + ptext (sLit "Discarding unexpected pragmas for") + + ----------- + tc_inl [] = return poly_id + tc_inl (L loc (InlineSig _ prag) : other_inls) + = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline) + ; return (poly_id `setInlinePragma` prag) } + tc_inl _ = panic "tc_inl" + +{- Earlier we tried to warn about + (a) INLINE for recursive function + (b) INLINE for function that is part of a multi-binder group + Code fragments below. But we want to allow + {-# INLINE f #-} + f x = x : g y + g y = ....f...f.... + even though they are mutually recursive. + So I'm just omitting the warnings for now + + | multi_bind && isInlinePragma prag + = do { setSrcSpan loc $ addWarnTc multi_bind_warn + ; return poly_id } + | otherwise + ; when (isInlinePragma prag && isRec rec_group) + (setSrcSpan loc (addWarnTc rec_inline_warn)) + + rec_inline_warn = ptext (sLit "INLINE pragma for recursive binder") + <+> quotes (ppr poly_id) <+> ptext (sLit "may be discarded") + + multi_bind_warn = hang (ptext (sLit "Discarding INLINE pragma for") <+> quotes (ppr poly_id)) + 2 (ptext (sLit "because it is bound by a pattern, or mutual recursion") ) +-} + + +warnPrags :: Id -> [LSig Name] -> SDoc -> TcM () +warnPrags id bad_sigs herald + = addWarnTc (hang (herald <+> quotes (ppr id)) + 2 (ppr_sigs bad_sigs)) + where + ppr_sigs sigs = vcat (map (ppr . getLoc) sigs) + +-------------- +tcSpecPrag :: TcId -> Sig Name -> TcM SpecPrag +tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) + = addErrCtxt (spec_ctxt prag) $ + do { let name = idName poly_id ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty - ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) } -tcPrag poly_id (SpecInstSig hs_ty) - = do { let name = idName poly_id - ; (tyvars, theta, tau) <- tcHsInstHead hs_ty - ; let spec_ty = mkSigmaTy tyvars theta tau - ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty - ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) } - -tcPrag _ (InlineSig _ inl) = return (InlinePrag inl) -tcPrag _ sig = pprPanic "tcPrag" (ppr sig) + ; return (SpecPrag co_fn inl) } + where + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) +tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig) -------------- diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 33b02dec5d..23ee423667 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -7,7 +7,7 @@ Typechecking class declarations \begin{code} module TcClassDcl ( tcClassSigs, tcClassDecl2, - findMethodBind, tcInstanceMethodBody, + findMethodBind, instantiateMethod, tcInstanceMethodBody, mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName, tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn ) where @@ -160,11 +160,11 @@ tcClassSig _ s = pprPanic "tcClassSig" (ppr s) \begin{code} tcClassDecl2 :: LTyClDecl Name -- The class declaration - -> TcM (LHsBinds Id, [Id]) + -> TcM ([Id], LHsBinds Id) tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) - = recoverM (return (emptyLHsBinds, [])) $ + = recoverM (return ([], emptyLHsBinds)) $ setSrcSpan loc $ do { clas <- tcLookupLocatedClass class_name @@ -186,7 +186,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, ; inst_loc <- getInstLoc (SigOrigin rigid_info) ; this_dict <- newDictBndr inst_loc pred - ; let tc_dm = tcDefMeth rigid_info clas clas_tyvars [pred] + ; let tc_dm = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn -- tc_dm is called only for a sel_id @@ -200,39 +200,110 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- the programmer supplied an explicit default decl for the class. -- (If necessary we can fix that, but we don't have a convenient Id to hand.) - ; (defm_binds, dm_ids) <- tcExtendTyVarEnv clas_tyvars $ + ; (dm_ids, defm_binds) <- tcExtendTyVarEnv clas_tyvars $ mapAndUnzipM tc_dm dm_sel_ids - ; return (unionManyBags defm_binds, dm_ids) } + ; return (dm_ids, listToBag defm_binds) } tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) -tcDefMeth :: SkolemInfo -> Class -> [TyVar] -> ThetaType -> Inst -> LHsBinds Name +tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name -> TcSigFun -> TcPragFun -> Id - -> TcM (LHsBinds Id, Id) -tcDefMeth rigid_info clas tyvars theta this_dict binds_in sig_fn prag_fn sel_id + -> TcM (Id, LHsBind Id) +tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id = do { let sel_name = idName sel_id - ; local_dm_name <- newLocalName sel_name + ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name) + ; local_dm_name <- newLocalName sel_name + -- Base the local_dm_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here + + -- See Note [Silly default-method bind] + -- (possibly out of date) + ; let meth_bind = findMethodBind sel_name local_dm_name binds_in `orElse` pprPanic "tcDefMeth" (ppr sel_id) -- We only call tcDefMeth on selectors for which -- there is a binding in binds_in - meth_sig_fn _ = sig_fn sel_name - meth_prag_fn _ = prag_fn sel_name + dm_sig_fn _ = sig_fn sel_name + dm_ty = idType sel_id + dm_id = mkDefaultMethodId dm_name dm_ty + local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars) + local_dm_id = mkLocalId local_dm_name local_dm_type + + ; (dm_id_w_inline, spec_prags) + <- tcPrags NonRecursive False True dm_id (prag_fn sel_name) + + ; tcInstanceMethodBody (instLoc this_dict) + tyvars [this_dict] + ([], emptyBag) + dm_id_w_inline local_dm_id + dm_sig_fn spec_prags meth_bind } + +--------------- +tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst] + -> ([Inst], LHsBinds Id) -> Id -> Id + -> TcSigFun -> [LSpecPrag] -> LHsBind Name + -> TcM (Id, LHsBind Id) +tcInstanceMethodBody inst_loc tyvars dfun_dicts + (this_dict, this_bind) meth_id local_meth_id + meth_sig_fn spec_prags bind@(L loc _) + = do { -- Typecheck the binding, first extending the envt + -- so that when tcInstSig looks up the local_meth_id to find + -- its signature, we'll find it in the environment + ; ((tc_bind, _), lie) <- getLIE $ + tcExtendIdEnv [local_meth_id] $ + tcPolyBinds TopLevel meth_sig_fn no_prag_fn + NonRecursive NonRecursive + (unitBag bind) + + ; let avails = this_dict ++ dfun_dicts + -- Only need the this_dict stuff if there are type + -- variables involved; otherwise overlap is not possible + -- See Note [Subtle interaction of recursion and overlap] + -- in TcInstDcls + ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie + + ; let full_bind = AbsBinds tyvars dfun_lam_vars + [(tyvars, meth_id, local_meth_id, spec_prags)] + (this_bind `unionBags` lie_binds + `unionBags` tc_bind) - ; (top_dm_id, bind) <- tcInstanceMethodBody rigid_info - clas tyvars [this_dict] theta (mkTyVarTys tyvars) - Nothing sel_id - local_dm_name - meth_sig_fn meth_prag_fn - meth_bind + dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - ; return (bind, top_dm_id) } + ; return (meth_id, L loc full_bind) } + where + no_prag_fn _ = [] -- No pragmas for local_meth_id; + -- they are all for meth_id +\end{code} +\begin{code} mkDefMethRdrName :: Name -> RdrName mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc +instantiateMethod :: Class -> Id -> [TcType] -> TcType +-- Take a class operation, say +-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a +-- Instantiate it at [ty1,ty2] +-- Return the "local method type": +-- forall c. Ix x => (ty2,c) -> ty1 +instantiateMethod clas sel_id inst_tys + = ASSERT( ok_first_pred ) local_meth_ty + where + (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length sel_tyvars == length inst_tys ) + substTyWith sel_tyvars inst_tys sel_rho + + (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + ok_first_pred = case getClassPredTys_maybe first_pred of + Just (clas1, _tys) -> clas == clas1 + Nothing -> False + -- The first predicate should be of form (C a b) + -- where C is the class in question + + --------------------------- -- The renamer just puts the selector ID as the binder in the method binding -- but we must use the method name; so we substitute it here. Crude but simple. @@ -246,65 +317,6 @@ findMethodBind sel_name meth_name binds | op_name == sel_name = Just (L loc1 (bind { fun_id = L loc2 meth_name })) f _other = Nothing - ---------------- -tcInstanceMethodBody :: SkolemInfo -> Class -> [TcTyVar] -> [Inst] - -> TcThetaType -> [TcType] - -> Maybe (Inst, LHsBind Id) -> Id - -> Name -- The local method name - -> TcSigFun -> TcPragFun -> LHsBind Name - -> TcM (Id, LHsBinds Id) -tcInstanceMethodBody rigid_info clas tyvars dfun_dicts theta inst_tys - mb_this_bind sel_id local_meth_name - sig_fn prag_fn bind@(L loc _) - = do { let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) - rho_ty = ASSERT( length sel_tyvars == length inst_tys ) - substTyWith sel_tyvars inst_tys sel_rho - - (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - local_meth_id = mkLocalId local_meth_name local_meth_ty - meth_ty = mkSigmaTy tyvars theta local_meth_ty - sel_name = idName sel_id - - -- The first predicate should be of form (C a b) - -- where C is the class in question - ; MASSERT( case getClassPredTys_maybe first_pred of - { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } ) - - -- Typecheck the binding, first extending the envt - -- so that when tcInstSig looks up the local_meth_id to find - -- its signature, we'll find it in the environment - ; ((tc_bind, _), lie) <- getLIE $ - tcExtendIdEnv [local_meth_id] $ - tcPolyBinds TopLevel sig_fn prag_fn - NonRecursive NonRecursive - (unitBag bind) - - ; meth_id <- case rigid_info of - ClsSkol _ -> do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name) - ; return (mkDefaultMethodId dm_name meth_ty) } - _other -> do { meth_name <- newLocalName sel_name - ; return (mkLocalId meth_name meth_ty) } - - ; let (avails, this_dict_bind) - = case mb_this_bind of - Nothing -> (dfun_dicts, emptyBag) - Just (this, bind) -> (this : dfun_dicts, unitBag bind) - - ; inst_loc <- getInstLoc (SigOrigin rigid_info) - ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie - - ; let full_bind = L loc $ - AbsBinds tyvars dfun_lam_vars - [(tyvars, meth_id, local_meth_id, [])] - (this_dict_bind `unionBags` lie_binds - `unionBags` tc_bind) - - dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - - ; return (meth_id, unitBag full_bind) } \end{code} Note [Polymorphic methods] @@ -363,7 +375,6 @@ gives rise to the instance declarations instance C 1 where op Unit = ... - \begin{code} mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) mkGenericDefMethBind clas inst_tys sel_id meth_name diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index d7c80c4016..3cfaaa944b 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -362,8 +362,8 @@ renameDeriv is_boot gen_binds insts ; let binds' = VanillaInst rn_binds [] standalone_deriv ; return (InstInfo { iSpec = inst, iBinds = binds' }, fvs) } where - (tyvars,_,clas,_) = instanceHead inst - clas_nm = className clas + (tyvars,_, clas,_) = instanceHead inst + clas_nm = className clas ----------------------------------------- mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName) @@ -1147,9 +1147,9 @@ mkNewTypeEqn orig dflags tvs cant_derive_err = vcat [ ptext (sLit "even with cunning newtype deriving:") - , if arity_ok then empty else arity_msg - , if eta_ok then empty else eta_msg - , if ats_ok then empty else ats_msg ] + , ppUnless arity_ok arity_msg + , ppUnless eta_ok eta_msg + , ppUnless ats_ok ats_msg ] arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1") eta_msg = ptext (sLit "cannot eta-reduce the representation type enough") ats_msg = ptext (sLit "the class has associated types") diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 073ca251f7..83f719b399 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -235,7 +235,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = -- is *stable* (i.e. the compiler won't change it later), -- because this name will be referred to by the C code stub. id <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc - return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec) + return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec) tcFExport d = pprPanic "tcFExport" (ppr d) \end{code} diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index 2192531d3d..8bbc27a64a 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -566,8 +566,8 @@ gen_Bounded_binds loc tycon data_cons = tyConDataCons tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) - max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) + min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -577,9 +577,9 @@ gen_Bounded_binds loc tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarBind loc minBound_RDR $ + min_bound_1con = mkHsVarBind loc minBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarBind loc maxBound_RDR $ + max_bound_1con = mkHsVarBind loc maxBound_RDR $ nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} @@ -808,16 +808,16 @@ gen_Read_binds get_fixity loc tycon where ----------------------------------------------------------------------- default_readlist - = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR) default_readlistprec - = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) + = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons - read_prec = mkVarBind loc readPrec_RDR + read_prec = mkHsVarBind loc readPrec_RDR (nlHsApp (nlHsVar parens_RDR) read_cons) read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) @@ -961,7 +961,7 @@ gen_Show_binds get_fixity loc tycon = (listToBag [shows_prec, show_list], []) where ----------------------------------------------------------------------- - show_list = mkVarBind loc showList_RDR + show_list = mkHsVarBind loc showList_RDR (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) @@ -1616,7 +1616,7 @@ genAuxBind loc (GenTag2Con tycon) rdr_name = tag2con_RDR tycon genAuxBind loc (GenMaxTag tycon) - = mkVarBind loc rdr_name + = mkHsVarBind loc rdr_name (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where rdr_name = maxtag_RDR tycon @@ -1624,16 +1624,16 @@ genAuxBind loc (GenMaxTag tycon) data_cons -> toInteger ((length data_cons) - fIRST_TAG) genAuxBind loc (MkTyCon tycon) -- $dT - = mkVarBind loc (mk_data_type_name tycon) - ( nlHsVar mkDataType_RDR + = mkHsVarBind loc (mk_data_type_name tycon) + ( nlHsVar mkDataType_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) `nlHsApp` nlList constrs ) where constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] genAuxBind loc (MkDataCon dc) -- $cT1 etc - = mkVarBind loc (mk_constr_name dc) - (nlHsApps mkConstr_RDR constr_args) + = mkHsVarBind loc (mk_constr_name dc) + (nlHsApps mkConstr_RDR constr_args) where constr_args = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index fbe3c9fff3..ee6de3357b 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -333,10 +333,10 @@ zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty}) ; new_ty <- zonkTcTypeToType env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss, pat_rhs_ty = new_ty }) } -zonk_bind env (VarBind { var_id = var, var_rhs = expr }) +zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl }) = zonkIdBndr env var `thenM` \ new_var -> zonkLExpr env expr `thenM` \ new_expr -> - returnM (VarBind { var_id = new_var, var_rhs = new_expr }) + returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl }) zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn }) = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> @@ -365,11 +365,9 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, = zonkIdBndr env global `thenM` \ new_global -> mapM zonk_prag prags `thenM` \ new_prags -> returnM (tyvars, new_global, zonkIdOcc env local, new_prags) - zonk_prag prag@(L _ (InlinePrag {})) = return prag - zonk_prag (L loc (SpecPrag expr ty inl)) - = do { expr' <- zonkExpr env expr - ; ty' <- zonkTcTypeToType env ty - ; return (L loc (SpecPrag expr' ty' inl)) } + zonk_prag (L loc (SpecPrag co_fn inl)) + = do { (_, co_fn') <- zonkCoFn env co_fn + ; return (L loc (SpecPrag co_fn' inl)) } \end{code} %************************************************************************ @@ -600,7 +598,6 @@ zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) ------------------------------------------------------------------------- zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper) zonkCoFn env WpHole = return (env, WpHole) -zonkCoFn env WpInline = return (env, WpInline) zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 479bd670be..426da52201 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -32,6 +32,8 @@ import TyCon import DataCon import Class import Var +import CoreUnfold ( mkDFunUnfolding ) +import PrelNames ( inlineIdName ) import Id import MkId import Name @@ -91,6 +93,7 @@ Running example: -- A top-level definition for each instance method -- Here op1_i, op2_i are the "instance method Ids" + -- The INLINE pragma comes from the user pragma {-# INLINE [2] op1_i #-} -- From the instance decl bindings op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b op1_i = /\a. \(d:C a). @@ -109,14 +112,16 @@ Running example: op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) -- The dictionary function itself - {-# INLINE df_i #-} -- Always inline dictionary functions + {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. letrec d' = MkC (op1_i a d) - ($dmop2 [a] d') - in d' + df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) -- But see Note [Default methods in instances] -- We can't apply the type checker to the default-method call + -- Use a RULE to short-circuit applications of the class ops + {-# RULE "op1@C[a]" forall a, d:C a. + op1 [a] (df_i d) = op1_i a d #-} + * The dictionary function itself is inlined as vigorously as we possibly can, so that we expose that dictionary constructor to selectors as much as poss. That is why the op_i stuff is in @@ -180,7 +185,7 @@ to have C [a] available. That is why we have the strange local definition for 'this' in the definition of op1_i in the example above. We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck we supply 'this' as a given dictionary. Only needed, though, if there -are some type variales involved; otherwise there can be no overlap and +are some type variables involved; otherwise there can be no overlap and none of this arises. Note [Tricky type variable scoping] @@ -551,18 +556,19 @@ tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] tcInstDecls2 tycl_decls inst_decls = do { -- (a) Default methods from class decls - (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $ - filter (isClassDecl.unLoc) tycl_decls - ; tcExtendIdEnv (concat dm_ids_s) $ do + let class_decls = filter (isClassDecl . unLoc) tycl_decls + ; (dm_ids_s, dm_binds_s) <- mapAndUnzipM tcClassDecl2 class_decls + + ; tcExtendIdEnv (concat dm_ids_s) $ do -- (b) instance declarations - ; inst_binds_s <- mapM tcInstDecl2 inst_decls + { inst_binds_s <- mapM tcInstDecl2 inst_decls -- Done ; let binds = unionManyBags dm_binds_s `unionBags` unionManyBags inst_binds_s ; tcl_env <- getLclEnv -- Default method Ids in here - ; return (binds, tcl_env) } + ; return (binds, tcl_env) } } tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) @@ -571,8 +577,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ tc_inst_decl2 dfun_id ibinds where - dfun_id = instanceDFunId ispec - loc = getSrcSpan dfun_id + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id \end{code} @@ -661,7 +667,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict) ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict - ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) + ; let dict_bind = mkVarBind (instToId this_dict) (noLoc body) ; return (unitBag $ noLoc $ AbsBinds inst_tvs' (map instToVar dfun_dicts) @@ -708,6 +714,7 @@ tc_inst_decl2 dfun_id (NewTypeDerived coi) tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) = do { let rigid_info = InstSkol inst_ty = idType dfun_id + loc = getSrcSpan dfun_id -- Instantiate the instance decl with skolem constants ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty @@ -716,69 +723,67 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) -- bizarre, but OK so long as you realise it! ; let (clas, inst_tys') = tcSplitDFunHead inst_head' - (class_tyvars, sc_theta, _, op_items) = classBigSig clas + (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas -- Instantiate the super-class context with inst_tys sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta origin = SigOrigin rigid_info -- Create dictionary Ids from the specified instance contexts. - ; sc_loc <- getInstLoc InstScOrigin - ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted ; inst_loc <- getInstLoc origin ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') - -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. - -- Typecheck the methods - ; let this_dict_id = instToId this_dict + + -- Cook up a binding for "this = df d1 .. dn", + -- to use in each method binding + -- Need to clone the dict in case it is floated out, and + -- then clashes with its friends + ; cloned_this <- cloneDict this_dict + ; let cloned_this_bind = mkVarBind (instToId cloned_this) $ + L loc $ wrapId app_wrapper dfun_id + app_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars') dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - prag_fn = mkPragFun uprags - loc = getSrcSpan dfun_id - tc_meth = tcInstanceMethod loc standalone_deriv - clas inst_tyvars' dfun_dicts - dfun_theta' inst_tys' - this_dict dfun_id - prag_fn monobinds - ; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ - mapAndUnzipM tc_meth op_items + nested_this_pair + | null inst_tyvars' && null dfun_theta' = (this_dict, emptyBag) + | otherwise = (cloned_this, unitBag cloned_this_bind) + + -- Deal with 'SPECIALISE instance' pragmas + -- See Note [SPECIALISE instance pragmas] + ; let spec_inst_sigs = filter isSpecInstLSig uprags + -- The filter removes the pragmas for methods + ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs + + -- Typecheck the methods + ; let prag_fn = mkPragFun uprags + tc_meth = tcInstanceMethod loc standalone_deriv + clas inst_tyvars' + dfun_dicts inst_tys' + nested_this_pair + prag_fn spec_inst_prags monobinds + + ; (meth_ids, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ + mapAndUnzipM tc_meth op_items -- Figure out bindings for the superclass context - -- Don't include this_dict in the 'givens', else - -- sc_dicts get bound by just selecting from this_dict!! - ; sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts - -- Note [Recursive superclasses] + ; sc_loc <- getInstLoc InstScOrigin + ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted + ; let tc_sc = tcSuperClass inst_loc inst_tyvars' dfun_dicts nested_this_pair + ; (sc_ids, sc_binds) <- mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts) - -- It's possible that the superclass stuff might unified something - -- in the envt with one of the inst_tyvars' + -- It's possible that the superclass stuff might unified + -- something in the envt with one of the inst_tyvars' ; checkSigTyVars inst_tyvars' - -- Deal with 'SPECIALISE instance' pragmas - ; prags <- tcPrags dfun_id (filter isSpecInstLSig uprags) - -- Create the result bindings ; let dict_constr = classDataCon clas - inline_prag | null dfun_dicts = [] - | otherwise = [L loc (InlinePrag (alwaysInlineSpec FunLike))] - -- Always inline the dfun; this is an experimental decision - -- because it makes a big performance difference sometimes. - -- Often it means we can do the method selection, and then - -- inline the method as well. Marcin's idea; see comments below. - -- - -- BUT: don't inline it if it's a constant dictionary; - -- we'll get all the benefit without inlining, and we get - -- a **lot** of code duplication if we inline it - -- - -- See Note [Inline dfuns] below - - sc_dict_vars = map instToVar sc_dicts - dict_bind = L loc (VarBind this_dict_id dict_rhs) - dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs - inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys') - (dataConWrapId dict_constr) + this_dict_id = instToId this_dict + dict_bind = mkVarBind this_dict_id dict_rhs + dict_rhs = foldl mk_app inst_constr (sc_ids ++ meth_ids) + inst_constr = L loc $ wrapId (mkWpTyApps inst_tys') + (dataConWrapId dict_constr) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because @@ -786,15 +791,57 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv) -- member) are dealt with by the common MkId.mkDataConWrapId code rather -- than needing to be repeated here. + mk_app :: LHsExpr Id -> Id -> LHsExpr Id + mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id))) + arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars') + + dfun_id_w_fun = dfun_id + `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids) + `setInlinePragma` dfunInlinePragma main_bind = noLoc $ AbsBinds inst_tyvars' dfun_lam_vars - [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)] - (dict_bind `consBag` sc_binds) + [(inst_tyvars', dfun_id_w_fun, this_dict_id, spec_inst_prags)] + (unitBag dict_bind) ; showLIE (text "instance") - ; return (main_bind `consBag` unionManyBags meth_binds) } + ; return (unitBag main_bind `unionBags` + listToBag meth_binds `unionBags` + listToBag sc_binds) } + + +------------------------------ +tcSuperClass :: InstLoc -> [TyVar] -> [Inst] + -> (Inst, LHsBinds Id) + -> (Id, Inst) -> TcM (Id, LHsBind Id) +-- Build a top level decl like +-- sc_op = /\a \d. let this = ... in +-- let sc = ... in +-- sc +-- The "this" part is just-in-case (discarded if not used) +-- See Note [Recursive superclasses] +tcSuperClass inst_loc tyvars dicts (this_dict, this_bind) + (sc_sel, sc_dict) + = addErrCtxt superClassCtxt $ + do { sc_binds <- tcSimplifySuperClasses inst_loc + this_dict dicts [sc_dict] + -- Don't include this_dict in the 'givens', else + -- sc_dicts get bound by just selecting from this_dict!! + + ; uniq <- newUnique + ; let sc_op_ty = mkSigmaTy tyvars (map dictPred dicts) + (mkPredTy (dictPred sc_dict)) + sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq + (getName sc_sel) + sc_op_id = mkLocalId sc_op_name sc_op_ty + sc_id = instToVar sc_dict + sc_op_bind = AbsBinds tyvars + (map instToVar dicts) + [(tyvars, sc_op_id, sc_id, [])] + (this_bind `unionBags` sc_binds) + + ; return (sc_op_id, noLoc sc_op_bind) } \end{code} Note [Recursive superclasses] @@ -805,6 +852,62 @@ get satisfied by selection from this_dict, and that leads to an immediate loop. What we need is to add this_dict to Avails without adding its superclasses, and we currently have no way to do that. +Note [SPECIALISE instance pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + instance (Ix a, Ix b) => Ix (a,b) where + {-# SPECIALISE instance Ix (Int,Int) #-} + range (x,y) = ... + +We do *not* want to make a specialised version of the dictionary +function. Rather, we want specialised versions of each method. +Thus we should generate something like this: + + $dfIx :: (Ix a, Ix x) => Ix (a,b) + {- DFUN [$crange, ...] -} + $dfIx da db = Ix ($crange da db) (...other methods...) + + $dfIxPair :: (Ix a, Ix x) => Ix (a,b) + {- DFUN [$crangePair, ...] -} + $dfIxPair = Ix ($crangePair da db) (...other methods...) + + $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] + {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} + $crange da db = <blah> + + {-# RULE range ($dfIx da db) = $crange da db #-} + +Note that + + * The RULE is unaffected by the specialisation. We don't want to + specialise $dfIx, because then it would need a specialised RULE + which is a pain. The single RULE works fine at all specialisations. + See Note [How instance declarations are translated] above + + * Instead, we want to specialise the *method*, $crange + +In practice, rather than faking up a SPECIALISE pragama for each +method (which is painful, since we'd have to figure out its +specialised type), we call tcSpecPrag *as if* were going to specialise +$dfIx -- you can see that in the call to tcSpecInst. That generates a +SpecPrag which, as it turns out, can be used unchanged for each method. +The "it turns out" bit is delicate, but it works fine! + +\begin{code} +tcSpecInst :: Id -> Sig Name -> TcM SpecPrag +tcSpecInst dfun_id prag@(SpecInstSig hs_ty) + = addErrCtxt (spec_ctxt prag) $ + do { let name = idName dfun_id + ; (tyvars, theta, tau) <- tcHsInstHead hs_ty + ; let spec_ty = mkSigmaTy tyvars theta tau + ; co_fn <- tcSubExp (SpecPragOrigin name) (idType dfun_id) spec_ty + ; return (SpecPrag co_fn defaultInlinePragma) } + where + spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) + +tcSpecInst _ _ = panic "tcSpecInst" +\end{code} %************************************************************************ %* * @@ -822,93 +925,118 @@ tcInstanceMethod \begin{code} tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst] - -> TcThetaType -> [TcType] - -> Inst -> Id - -> TcPragFun -> LHsBinds Name + -> [TcType] + -> (Inst, LHsBinds Id) -- "This" and its binding + -> TcPragFun -- Local prags + -> [LSpecPrag] -- Arising from 'SPECLALISE instance' + -> LHsBinds Name -> (Id, DefMeth) - -> TcM (HsExpr Id, LHsBinds Id) + -> TcM (Id, LHsBind Id) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts theta inst_tys - this_dict dfun_id prag_fn binds_in (sel_id, dm_info) - = do { cloned_this <- cloneDict this_dict - -- Need to clone the dict in case it is floated out, and - -- then clashes with its friends - ; uniq1 <- newUnique - ; let local_meth_name = mkInternalName uniq1 sel_occ loc -- Same OccName - this_dict_bind = L loc $ VarBind (instToId cloned_this) $ - L loc $ wrapId meth_wrapper dfun_id - mb_this_bind | null tyvars = Nothing - | otherwise = Just (cloned_this, this_dict_bind) - -- Only need the this_dict stuff if there are type variables - -- involved; otherwise overlap is not possible - -- See Note [Subtle interaction of recursion and overlap] - +tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys + (this_dict, this_dict_bind) + prag_fn spec_inst_prags binds_in (sel_id, dm_info) + = do { uniq <- newUnique + ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name + ; local_meth_name <- newLocalName sel_name + -- Base the local_meth_name on the selector name, becuase + -- type errors from tcInstanceMethodBody come from here + + ; let local_meth_ty = instantiateMethod clas sel_id inst_tys + meth_ty = mkSigmaTy tyvars (map dictPred dfun_dicts) local_meth_ty + meth_id = mkLocalId meth_name meth_ty + local_meth_id = mkLocalId local_meth_name local_meth_ty + + -------------- tc_body rn_bind = add_meth_ctxt rn_bind $ - do { (meth_id, tc_binds) <- tcInstanceMethodBody - InstSkol clas tyvars dfun_dicts theta inst_tys - mb_this_bind sel_id - local_meth_name - meth_sig_fn meth_prag_fn rn_bind - ; return (wrapId meth_wrapper meth_id, tc_binds) } - - ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of - -- There is a user-supplied method binding, so use it - (Just user_bind, _) -> tc_body user_bind - + do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True + meth_id (prag_fn sel_name) + ; tcInstanceMethodBody (instLoc this_dict) + tyvars dfun_dicts + ([this_dict], this_dict_bind) + meth_id1 local_meth_id + meth_sig_fn + (spec_inst_prags ++ spec_prags) + rn_bind } + + -------------- + tc_default :: DefMeth -> TcM (Id, LHsBind Id) -- The user didn't supply a method binding, so we have to make -- up a default binding, in a way depending on the default-method info - (Nothing, GenDefMeth) -> do -- Derivable type classes stuff - { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name - ; tc_body meth_bind } - - (Nothing, NoDefMeth) -> do -- No default method in the class - { warn <- doptM Opt_WarnMissingMethods - ; warnTc (warn -- Warn only if -fwarn-missing-methods - && not (startsWithUnderscore (getOccName sel_id))) - -- Don't warn about _foo methods - omitted_meth_warn - ; return (error_rhs, emptyBag) } - - (Nothing, DefMeth) -> do -- An polymorphic default method - { -- Build the typechecked version directly, - -- without calling typecheck_method; - -- see Note [Default methods in instances] - dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name) + tc_default NoDefMeth -- No default method at all + = do { warnMissingMethod sel_id + ; return (meth_id, mkVarBind meth_id $ + mkLHsWrap lam_wrapper error_rhs) } + + tc_default GenDefMeth -- Derivable type classes stuff + = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name + ; tc_body meth_bind } + + tc_default DefMeth -- An polymorphic default method + = do { -- Build the typechecked version directly, + -- without calling typecheck_method; + -- see Note [Default methods in instances] + -- Generate /\as.\ds. let this = df as ds + -- in $dm inst_tys this + -- The 'let' is necessary only because HsSyn doesn't allow + -- you to apply a function to a dictionary *expression*. + dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name) -- Might not be imported, but will be an OrigName - ; dm_id <- tcLookupId dm_name - ; return (wrapId dm_wrapper dm_id, emptyBag) } } + ; dm_id <- tcLookupId dm_name + ; inline_id <- tcLookupId inlineIdName + ; let dm_inline_prag = idInlinePragma dm_id + dm_app = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $ + HsVar dm_id + rhs | isInlinePragma dm_inline_prag -- See Note [INLINE and default methods] + = HsApp (L loc (HsWrap (WpTyApp local_meth_ty) (HsVar inline_id))) + (L loc dm_app) + | otherwise = dm_app + + meth_bind = L loc $ VarBind { var_id = local_meth_id + , var_rhs = L loc rhs + , var_inline = False } + meth_id1 = meth_id `setInlinePragma` dm_inline_prag + -- Copy the inline pragma (if any) from the default + -- method to this version. Note [INLINE and default methods] + + bind = AbsBinds { abs_tvs = tyvars, abs_dicts = dfun_lam_vars + , abs_exports = [( tyvars, meth_id1 + , local_meth_id, spec_inst_prags)] + , abs_binds = this_dict_bind `unionBags` unitBag meth_bind } + -- Default methods in an instance declaration can't have their own + -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but + -- currently they are rejected with + -- "INLINE pragma lacks an accompanying binding" + + ; return (meth_id1, L loc bind) } + + ; case findMethodBind sel_name local_meth_name binds_in of + Just user_bind -> tc_body user_bind -- User-supplied method binding + Nothing -> tc_default dm_info -- None supplied + } where sel_name = idName sel_id - sel_occ = nameOccName sel_name - this_dict_id = instToId this_dict - - meth_prag_fn _ = prag_fn sel_name - meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig" - -- But there are no scoped type variables from local_method_id - -- Only the ones from the instance decl itself, which are already - -- in scope. Example: - -- class C a where { op :: forall b. Eq b => ... } - -- instance C [c] where { op = <rhs> } - -- In <rhs>, 'c' is scope but 'b' is not! - - error_rhs = HsApp error_fun error_msg + + meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig" + -- But there are no scoped type variables from local_method_id + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = <rhs> } + -- In <rhs>, 'c' is scope but 'b' is not! + + error_rhs = L loc $ HsApp error_fun error_msg error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) - dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys - - omitted_meth_warn :: SDoc - omitted_meth_warn = ptext (sLit "No explicit method nor default method for") - <+> quotes (ppr sel_id) - dfun_lam_vars = map instToVar dfun_dicts - meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars) + lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars -- For instance decls that come from standalone deriving clauses -- we want to print out the full source code if there's an error @@ -925,29 +1053,89 @@ derivBindCtxt clas tys bind = vcat [ ptext (sLit "When typechecking a standalone-derived method for") <+> quotes (pprClassPred clas tys) <> colon , nest 2 $ pprSetDepth AllTheWay $ ppr bind ] + +warnMissingMethod :: Id -> TcM () +warnMissingMethod sel_id + = do { warn <- doptM Opt_WarnMissingMethods + ; warnTc (warn -- Warn only if -fwarn-missing-methods + && not (startsWithUnderscore (getOccName sel_id))) + -- Don't warn about _foo methods + (ptext (sLit "No explicit method nor default method for") + <+> quotes (ppr sel_id)) } \end{code} +Note [Export helper functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange to export the "helper functions" of an instance declaration, +so that they are not subject to preInlineUnconditionally, even if their +RHS is trivial. Reason: they are mentioned in the DFunUnfolding of +the dict fun as Ids, not as CoreExprs, so we can't substitute a +non-variable for them. + +We could change this by making DFunUnfoldings have CoreExprs, but it +seems a bit simpler this way. + Note [Default methods in instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this class Baz v x where foo :: x -> x - foo y = y + foo y = <blah> instance Baz Int Int From the class decl we get $dmfoo :: forall v x. Baz v x => x -> x + $dmfoo y = <blah> Notice that the type is ambiguous. That's fine, though. The instance decl generates - $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt) + $dBazIntInt = MkBaz fooIntInt + fooIntInt = $dmfoo Int Int $dBazIntInt + +BUT this does mean we must generate the dictionary translation of +fooIntInt directly, rather than generating source-code and +type-checking it. That was the bug in Trac #1061. In any case it's +less work to generate the translated version! + +Note [INLINE and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *copy* any INLINE pragma from the default method to the instance. +Example: + class Foo a where + op1, op2 :: Bool -> a -> a + + {-# INLINE op1 #-} + op1 b x = op2 (not b) x + + instance Foo Int where + op2 b x = <blah> + +Then we generate: + + {-# INLINE $dmop1 #-} + $dmop1 d b x = op2 d (not b) x + + $fFooInt = MkD $cop1 $cop2 + + {-# INLINE $cop1 #-} + $cop1 = inline $dmop1 $fFooInt + + $cop2 = <blah> + +Note carefully: + a) We copy $dmop1's inline pragma to $cop1. Otherwise + we'll just inline the former in the latter and stop, which + isn't what the user expected + + b) We use the magic 'inline' Id to ensure that $dmop1 really is + inlined in $cop1, even though the latter itself has an INLINE pragma + That is important to allow the mutual recursion between $fooInt and + $cop1 to be broken -BUT this does mean we must generate the dictionary translation directly, rather -than generating source-code and type-checking it. That was the bug ing -Trac #1061. In any case it's less work to generate the translated version! +This is all regrettably delicate. %************************************************************************ @@ -967,7 +1155,7 @@ instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - (_,_,cls,tys) = tcSplitDFunTy dfun_ty + (_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index f7acc1927e..5a669b4b74 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -555,6 +555,15 @@ checkHiBootIface -- Check the exports of the boot module, one by one ; mapM_ check_export boot_exports + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, + tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ @@ -569,7 +578,7 @@ checkHiBootIface final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns dfun_prs = catMaybes mb_dfun_prs boot_dfuns = map fst dfun_prs - dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun) | (boot_dfun, dfun) <- dfun_prs ] ; failIfErrsM @@ -929,7 +938,7 @@ check_main dflags tcg_env (mkTyConApp ioTyCon [res_ty]) ; co = mkWpTyApps [res_ty] ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr - ; main_bind = noLoc (VarBind root_main_id rhs) } + ; main_bind = mkVarBind root_main_id rhs } ; return (tcg_env { tcg_binds = tcg_binds tcg_env `snocBag` main_bind, diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 2ad5b2fefb..af99bc2bef 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1018,16 +1018,17 @@ makeImplicationBind loc all_tvs <.> mkWpTyApps eq_cotvs <.> mkWpTyApps (mkTyVarTys all_tvs) bind | [dict_irred_id] <- dict_irred_ids - = VarBind dict_irred_id rhs + = mkVarBind dict_irred_id rhs | otherwise - = PatBind { pat_lhs = lpat + = L span $ + PatBind { pat_lhs = lpat , pat_rhs = unguardedGRHSs rhs , pat_rhs_ty = hsLPatType lpat , bind_fvs = placeHolderNames } ; traceTc $ text "makeImplicationBind" <+> ppr implic_inst - ; return ([implic_inst], unitBag (L span bind)) + ; return ([implic_inst], unitBag bind) } ----------------------------------------------------------- @@ -2381,11 +2382,7 @@ reduceImplication env eq_cotvs = map instToVar extra_eq_givens dict_ids = map instToId extra_dict_givens - -- Note [Always inline implication constraints] - wrap_inline | null dict_ids = idHsWrapper - | otherwise = WpInline - co = wrap_inline - <.> mkWpTyLams tvs + co = mkWpTyLams tvs <.> mkWpTyLams eq_cotvs <.> mkWpLams dict_ids <.> WpLet (binds `unionBags` bind) @@ -2397,12 +2394,15 @@ reduceImplication env . filter (not . isEqInst) $ wanteds payload = mkBigLHsTup dict_bndrs - ; traceTc (vcat [text "reduceImplication" <+> ppr name, ppr simpler_implic_insts, text "->" <+> ppr rhs]) - ; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)), + ; return (unitBag (L loc (VarBind { var_id= instToId orig_implic + , var_rhs = rhs + , var_inline = notNull dict_ids } + -- See Note [Always inline implication constraints] + )), simpler_implic_insts) } } diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 71fee4c75c..dad167cabd 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -643,7 +643,6 @@ getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) These tcSplit functions are like their non-Tc analogues, but a) they do not look through newtypes b) they do not look through PredTys - c) [future] they ignore usage-type annotations However, they are non-monadic and do not follow through mutable type variables. It's up to you to make sure this doesn't matter. @@ -804,18 +803,29 @@ tcIsTyVarTy :: Type -> Bool tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], Class, [Type]) -- Split the type of a dictionary function +-- We don't use tcSplitSigmaTy, because a DFun may (with NDP) +-- have non-Pred arguments, such as +-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m tcSplitDFunTy ty - = case tcSplitSigmaTy ty of { (tvs, theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, theta, clas, tys) }} + = case tcSplitForAllTys ty of { (tvs, rho) -> + case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> + (tvs, clas, tys) }} + where + -- Discard the context of the dfun. This can be a mix of + -- coercion and class constraints; or (in the general NDP case) + -- some other function argument + drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty' + drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty + drop_pred_tys (FunTy _ ty) = drop_pred_tys ty + drop_pred_tys ty = ty tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau = case tcSplitPredTy_maybe tau of Just (ClassP clas tys) -> (clas, tys) - _ -> panic "tcSplitDFunHead" + _ -> pprPanic "tcSplitDFunHead" (ppr tau) tcInstHeadTyNotSynonym :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index a6ddc3c3ed..b3d8dccc53 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -116,7 +116,7 @@ setInstanceDFunId ispec dfun -- are ok; hence the assert ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys } where - (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, tys) = tcSplitDFunTy (idType dfun) instanceRoughTcs :: Instance -> [Maybe Name] instanceRoughTcs = is_tcs @@ -140,16 +140,20 @@ pprInstanceHdr :: Instance -> SDoc -- Prints the Instance as an instance declaration pprInstanceHdr ispec@(Instance { is_flag = flag }) = ptext (sLit "instance") <+> ppr flag - <+> sep [pprThetaArrow theta, pprClassPred clas tys] + <+> sep [pprThetaArrow theta, ppr res_ty] where - (_, theta, clas, tys) = instanceHead ispec + (_, theta, res_ty) = tcSplitSigmaTy (idType (is_dfun ispec)) -- Print without the for-all, which the programmer doesn't write pprInstances :: [Instance] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) -instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type]) -instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec)) +instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type]) +instanceHead ispec + = (tvs, theta, cls, tys) + where + (tvs, theta, tau) = tcSplitSigmaTy (idType (is_dfun ispec)) + (cls, tys) = tcSplitDFunHead tau mkLocalInstance :: DFunId -> OverlapFlag -> Instance -- Used for local instances, where we can safely pull on the DFunId @@ -158,7 +162,7 @@ mkLocalInstance dfun oflag is_tvs = mkVarSet tvs, is_tys = tys, is_cls = className cls, is_tcs = roughMatchTcs tys } where - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + (tvs, cls, tys) = tcSplitDFunTy (idType dfun) mkImportedInstance :: Name -> [Maybe Name] -> DFunId -> OverlapFlag -> Instance @@ -169,7 +173,7 @@ mkImportedInstance cls mb_tcs dfun oflag is_tvs = mkVarSet tvs, is_tys = tys, is_cls = cls, is_tcs = mb_tcs } where - (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, tys) = tcSplitDFunTy (idType dfun) roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs tys = map rough tys diff --git a/compiler/vectorise/VectCore.hs b/compiler/vectorise/VectCore.hs index c98c03c610..d651526ddf 100644 --- a/compiler/vectorise/VectCore.hs +++ b/compiler/vectorise/VectCore.hs @@ -16,9 +16,9 @@ module VectCore ( #include "HsVersions.h" import CoreSyn -import CoreUtils ( mkInlineMe ) import Type ( Type ) import Var +import Outputable type Vect a = (a,a) type VVar = Vect Var @@ -86,3 +86,5 @@ vCaseDEFAULT (vscrut, lscrut) (vbndr, lbndr) vty lty (vbody, lbody) vInlineMe :: VExpr -> VExpr vInlineMe (vexpr, lexpr) = (mkInlineMe vexpr, mkInlineMe lexpr) +mkInlineMe :: CoreExpr -> CoreExpr +mkInlineMe = pprTrace "VectCore.mkInlineMe" (text "Roman: need to replace mkInlineMe with an InlineRule somehow") diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index 7540e1a14d..7b9ec50e83 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -815,6 +815,13 @@ buildPADict vect_tc prepr_tc arr_tc repr var <- newLocalVar name (exprType body) return (var, mkInlineMe body) +-- The InlineMe note has gone away. Instead, you need to use +-- CoreUnfold.mkInlineRule to make an InlineRule for the thing, and +-- attach *that* as the unfolding for the dictionary binder +mkInlineMe :: CoreExpr -> CoreExpr +mkInlineMe expr = pprTrace "VectType: Roman, you need to use the new InlineRule story" + (ppr expr) expr + paMethods :: [(FastString, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)] paMethods = [(fsLit "dictPRepr", buildPRDict), (fsLit "toPRepr", buildToPRepr), |