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
| 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
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)
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
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}
idArity,
idNewDemandInfo, idNewDemandInfo_maybe,
idNewStrictness, idNewStrictness_maybe,
- idWorkerInfo,
idUnfolding,
idSpecialisation, idCoreRules, idHasRules,
idCafInfo,
setIdArity,
setIdNewDemandInfo,
setIdNewStrictness, zapIdNewStrictness,
- setIdWorkerInfo,
setIdSpecialisation,
setIdCafInfo,
setIdOccInfo, zapIdOccInfo,
`setIdArity`,
`setIdNewDemandInfo`,
`setIdNewStrictness`,
- `setIdWorkerInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
`idCafInfo`
-- | 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
_ -> 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
-- 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
(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)
---------------------------------
-- SPECIALISATION
+
+-- See Note [Specialisations and RULES in IdInfo] in IdInfo.lhs
+
idSpecialisation :: Id -> SpecInfo
idSpecialisation id = specInfo (idInfo id)
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)
cprInfoFromNewStrictness,
#endif
- -- ** The WorkerInfo type
- WorkerInfo(..),
- workerExists, wrapperArity, workerId,
- workerInfo, setWorkerInfo, ppWorkerInfo,
-
-- ** Unfolding Info
unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily,
import Class
import PrimOp
import Name
-import Var
import VarSet
import BasicTypes
import DataCon
`setArityInfo`,
`setInlinePragInfo`,
`setUnfoldingInfo`,
- `setWorkerInfo`,
`setLBVarInfo`,
`setOccInfo`,
`setCafInfo`,
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
-- 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}
= 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
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
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
strictnessInfo = NoStrictnessInfo,
#endif
specInfo = emptySpecInfo,
- workerInfo = NoWorker,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = defaultInlinePragma,
%* *
%************************************************************************
+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
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
+instance Outputable CafInfo where
+ ppr = ppCafInfo
+
ppCafInfo :: CafInfo -> SDoc
ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs")
ppCafInfo MayHaveCafRefs = empty
-- ^ 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
-- ...(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
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
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
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}
-> 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}
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
BuiltInSyntax(..),
-- ** Creating 'Name's
- mkInternalName, mkSystemName,
+ mkInternalName, mkSystemName, mkDerivedInternalName,
mkSystemVarName, mkSysTvName,
mkFCallName, mkIPName,
mkTickBoxOpName,
-- * 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
-- ** Derived 'OccName's
isDerivedOccName,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc,
- mkDerivedTyConOcc, mkNewTyCoOcc,
+ mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkInstTyCoOcc, mkEqPredCoOcc,
mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
mkPDataTyConOcc, mkPDataDataConOcc,
- mkPReprTyConOcc,
+ mkPReprTyConOcc,
mkPADFunOcc,
-- ** Deconstruction
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
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
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_"
\begin{code}
-- | Arit and eta expansion
module CoreArity (
- manifestArity, exprArity,
+ manifestArity, exprArity, exprBotStrictness_maybe,
exprEtaExpandArity, etaExpand
) where
= 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]
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@.
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
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)
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
exprFreeNames, exprsFreeNames,
-- * Free variables of Rules, Vars and Ids
- idRuleVars, idFreeVars, varTypeTyVars, varTypeTcTyVars,
+ varTypeTyVars, varTypeTcTyVars,
+ idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+ idRuleVars, idRuleRhsVars,
ruleRhsFreeVars, rulesFreeVars,
ruleLhsFreeNames, ruleLhsFreeIds,
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
---------
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
---------
-- | 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
-- (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.
| 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}
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
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
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"
import VarSet
import Name
import Id
-import IdInfo
import PprCore
import ErrUtils
import SrcLoc
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
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}
import CoreUtils
import CoreArity
import CoreFVs
-import CoreLint
+import CoreMonad ( endPass )
import CoreSyn
import Type
import Coercion
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
-- want to get this:
-- unzip = /\ab \xs. (__inline_me__ ...) a b xs
ignoreNote (CoreNote _) = True
-ignoreNote InlineMe = True
ignoreNote _other = False
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,
-- ** Substituting and cloning binders
substBndr, substBndrs, substRecBndrs,
- cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs
+ cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
+
+ -- ** Simple expression optimiser
+ simpleOptExpr
) where
#include "HsVersions.h"
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
| 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
--
-- (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}
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
| 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}
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,
-- | 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}
-- 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
-- | 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'
-- 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
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
-- | 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
+
%************************************************************************
%* *
-- 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
-- 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
-- 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
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(..),
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
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
-- 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}
%************************************************************************
\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]
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}
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]
| 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
-- 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]
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
%* *
%************************************************************************
-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}
%************************************************************************
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
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
}
\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 ... }
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
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
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'.
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 }
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]
-- 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
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.
+
-- | Commonly useful utilites for manipulating the Core language
module CoreUtils (
-- * Constructing expressions
- mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
+ mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding,
mkAltExpr, mkPiType, mkPiTypes,
exprType, coreAltType, coreAltsType,
exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
exprIsHNF,exprOkForSpeculation, exprIsBig,
- exprIsConApp_maybe, exprIsBottom,
rhsIsStatic,
-- * Expression and bindings size
import PrimOp
import Id
import IdInfo
-import NewDemand
import Type
import Coercion
import TyCon
%* *
%************************************************************************
-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
filters down the matching alternatives in Simplify.rebuildCase.
-
%************************************************************************
%* *
-\subsection{Figuring out things about expressions}
+ Figuring out things about expressions
%* *
%************************************************************************
\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
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
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
exprIsCheap = exprIsCheap' isDataConWorkId
exprIsExpandable :: CoreExpr -> Bool
-exprIsExpandable = exprIsCheap' isConLikeId
+exprIsExpandable = exprIsCheap' isConLikeId -- See Note [CONLIKE pragma] in BasicTypes
\end{code}
\begin{code}
-- 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!
\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
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
+-}
\end{code}
\begin{code}
-- 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)
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
%* *
%************************************************************************
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
noteSize :: Note -> Int
noteSize (SCC cc) = cc `seq` 1
-noteSize InlineMe = 1
noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations
varSize :: Var -> Int
-- 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).
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
import Util
import Outputable
import FastString
+import Data.Maybe
\end{code}
%************************************************************************
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)],
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
-- 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)
-- 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 *)
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
#include "HsVersions.h"
import DynFlags
-import CoreLint
+import CoreMonad
import CoreSyn
import CoreUtils
import Id
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
import Module
import RdrName
import NameSet
-import VarSet
import Rules
-import CoreLint
-import CoreFVs
+import CoreMonad ( endPass )
import ErrUtils
import Outputable
import SrcLoc
{ -- 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#
-- 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)
-- 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
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,
-- 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.
#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
import Id
import MkId ( seqId )
import Var ( Var, TyVar, tyVarKind )
+import IdInfo ( vanillaIdInfo )
import VarSet
import Rules
import VarEnv
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}
------------------------
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)
-> 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]
~~~~~~~~~~~~~~~~~~~~~~~~~
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) }
-- 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
; 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)
| 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 #-}
--
-- 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
, 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
{-# 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
-- 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!
\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}
import CostCentre
import Id
import Var
+import VarSet
import PrelInfo
import DataCon
import TysWiredIn
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
\begin{code}
-
dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr
-- See Note [Desugaring explicit lists]
dsExplicitList elt_ty xs
import HsSyn
import DataCon
import CoreUtils
+import CoreUnfold
import Id
import Literal
import Module
-- 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}
<> 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;")
-- 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
; 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)
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,
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
- foldlM, foldrM, ifOptM,
+ foldlM, foldrM, ifOptM, unsetOptM,
Applicative(..),(<$>),
newLocalName,
\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
-- 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
-- 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
; 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
module HsBinds where
-import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
+import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
MatchGroup, pprFunBind,
GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat )
}
| 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
-- 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
| 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
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
-- 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] #-}
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}
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)
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}
+
%
% (c) The University of Glasgow, 1992-2006
%
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]
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
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
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
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)
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
- IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..),
+ IfaceBinding(..), IfaceConAlt(..),
+ IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceInst(..), IfaceFamInst(..),
= 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
| IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
- | IfaceInlineMe
| IfaceCoreNote String
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
= 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
------------------
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)
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)
-- -----------------------------------------------------------------------------
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
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
--------------------------
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)
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
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
---------------------
toIfaceNote :: Note -> IfaceNote
toIfaceNote (SCC cc) = IfaceSCC cc
-toIfaceNote InlineMe = IfaceInlineMe
toIfaceNote (CoreNote s) = IfaceCoreNote s
---------------------
import IfaceEnv
import BuildTyCl
import TcRnMonad
+import TcType
import Type
import TypeRep
import HscTypes
import VarEnv
import Name
import NameEnv
+import OccurAnal ( occurAnalyseExpr )
import Module
import LazyUniqFM
import UniqSupply
import DynFlags
import Util
import FastString
-import BasicTypes (Arity)
import Control.Monad
import Data.List
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)) }
; 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)
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')
%************************************************************************
\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 }) }
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
import CoreUnfold
import CoreFVs
import CoreTidy
-import PprCore
-import CoreLint
+import CoreMonad
import CoreUtils
import CoreArity ( exprArity )
import Class ( classSelIds )
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 }
; 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,
\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.
-> 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,
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)
| 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'
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
--
-- 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))
\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,
| 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.)
%************************************************************************
%* *
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.
-- 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;
`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}
%************************************************************************
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
| 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 }
| 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
| '%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)))
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice, mkTopSpliceDecl,
mkClassDecl, mkTyData, mkTyFamily, mkTySynonym,
- splitCon, mkInlineSpec,
+ splitCon, mkInlinePragma,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
cvBindGroup,
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
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
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,
= 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)))
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
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
-- ** Dealing with annotations
findAnnotations, deserializeAnnotations, addAnnotation,
+ -- ** Debug output
+ endPass, endPassIf,
+
-- ** Screen output
putMsg, putMsgS, errorMsg, errorMsgS,
fatalErrorMsg, fatalErrorMsgS,
#ifdef GHCI
import Name( Name )
#endif
+import CoreSyn
+import PprCore
+import CoreUtils
+import CoreLint ( lintCoreBindings )
import PrelNames ( iNTERACTIVE )
import HscTypes
import Module ( Module )
import TcRnMonad ( TcM, initTc )
import Outputable
+import FastString
import qualified ErrUtils as Err
import Maybes
import UniqSupply
#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 {
\end{code}
-\subsection{Core combinators, not exported}
+
+%************************************************************************
+%* *
+ Core combinators, not exported
+%* *
+%************************************************************************
\begin{code}
\end{code}
-\subsection{Reader, writer and state accessors}
+
+%************************************************************************
+%* *
+ Reader, writer and state accessors
+%* *
+%************************************************************************
\begin{code}
\end{code}
-\subsection{Dealing with annotations}
+
+%************************************************************************
+%* *
+ Dealing with annotations
+%* *
+%************************************************************************
\begin{code}
\end{code}
-\subsection{Direct screen output}
+
+%************************************************************************
+%* *
+ Direct screen output
+%* *
+%************************************************************************
\begin{code}
-- | 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}
\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
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 )
= -- 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}
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}
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
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 ]
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#
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') }
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}
%************************************************************************
import Coercion ( mkSymCoercion )
import Id
import Name ( localiseName )
-import IdInfo
import BasicTypes
import VarSet
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
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
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):
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
= (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
----------------------------
-- 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)
| 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
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
-- 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)]
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
-- 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
--
-- 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
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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- 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
\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
\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')
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
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') }}
-- 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); ... }
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
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
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
-- the CtxtTy inside applies
initOccEnv :: OccEnv
-initOccEnv = OccEnv { occ_encl = OccRhs
+initOccEnv = OccEnv { occ_encl = OccVanilla
, occ_ctxt = []
, occ_scrut_ids = emptyVarSet }
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
projects / ghc-hetmet.git / commitdiff