import Demand ( Demand )
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
- nameIsLocallyDefined,
getOccName, isIPOcc
)
import OccName ( UserFS )
-- we'd better assume it does
constantIdInfo = mkIdInfo ConstantId MayHaveCafRefs
-mkIdInfo :: IdFlavour -> IdInfo
+mkIdInfo :: IdFlavour -> CafInfo -> IdInfo
mkIdInfo flv caf
= IdInfo {
flavourInfo = flv,
+ cafInfo = caf,
arityInfo = UnknownArity,
demandInfo = wwLazy,
specInfo = emptyCoreRules,
workerInfo = NoWorker,
strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
- cafInfo = caf
cprInfo = NoCPRInfo,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = NoInlinePragInfo,
\begin{code}
mkSpecPragmaId occ uniq ty loc
- = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId)
+ = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId NoCafRefs)
-- Maybe a SysLocal? But then we'd lose the location
mkDefaultMethodId dm_name rec_c ty
mkDataConId work_name data_con
= mkId work_name (dataConRepType data_con) info
where
- info = mkIdInfo (DataConId data_con)
+ info = mkIdInfo (DataConId data_con) NoCafRefs
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
`setCprInfo` cpr_info
wrap_id = mkId (dataConName data_con) wrap_ty info
work_id = dataConId data_con
- info = mkIdInfo (DataConWrapId data_con)
+ info = mkIdInfo (DataConWrapId data_con) NoCafRefs
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
`setCprInfo` cpr_info
-- The Cpr info can be important inside INLINE rhss, where the
`setArityInfo` exactArity arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
- `setCafInfo` NoCafRefs
- -- The wrapper Id ends up in STG code as an argument,
- -- sometimes before its definition, so we want to
- -- signal that it has no CAFs
`setTyGenInfo` TyGenNever
-- No point generalising its type, since it gets eagerly inlined
-- away anyway
selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
mkFunTys dict_tys $ mkFunTy data_ty field_tau
- info = mkIdInfo (RecordSelId field_label)
+ info = mkIdInfo (RecordSelId field_label) NoCafRefs
`setArityInfo` exactArity (1 + length dict_tys)
`setUnfoldingInfo` unfolding
- `setCafInfo` NoCafRefs
`setTyGenInfo` TyGenNever
-- ToDo: consider adding further IdInfo
field_lbl = mkFieldLabel name tycon ty tag
tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
- info = mkIdInfo (RecordSelId field_lbl)
+ info = mkIdInfo (RecordSelId field_lbl) NoCafRefs
`setArityInfo` exactArity 1
`setUnfoldingInfo` unfolding
- `setCafInfo` NoCafRefs
`setTyGenInfo` TyGenNever
-- We no longer use 'must-inline' on record selectors. They'll
name = mkPrimOpIdName prim_op
id = mkId name ty info
- info = mkIdInfo (PrimOpId prim_op)
+ info = mkIdInfo (PrimOpId prim_op) NoCafRefs
`setSpecInfo` rules
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
name = mkCCallName uniq occ_str
prim_op = CCallOp ccall
- info = mkIdInfo (PrimOpId prim_op)
+ info = mkIdInfo (PrimOpId prim_op) NoCafRefs
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
= mkId dfun_name dfun_ty info
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
- info = mkIdInfo DictFunId `setTyGenInfo` TyGenNever
+ info = mkIdInfo DictFunId MayHaveCafRefs
+ `setTyGenInfo` TyGenNever
-- type is wired-in (see comment at TcClassDcl.tcClassSig), so
-- do not generalise it
+ -- An imported dfun may refer to CAFs, so we assume the worst
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't external, or if we don't have -O
- = mkIdInfo new_flavour
+ = mkIdInfo new_flavour caf_info
`setStrictnessInfo` strictnessInfo core_idinfo
`setArityInfo` ArityExactly arity_info
- `setCafInfo` caf_info
-- Keep strictness, arity and CAF info; it's used by the code generator
| otherwise
= let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
in
- mkIdInfo new_flavour
+ mkIdInfo new_flavour caf_info
`setCprInfo` cprInfo core_idinfo
`setStrictnessInfo` strictnessInfo core_idinfo
`setInlinePragInfo` inlinePragInfo core_idinfo
`setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo)
`setSpecInfo` rules'
`setArityInfo` ArityExactly arity_info
- `setCafInfo` caf_info
-- this is the final IdInfo, it must agree with the
-- code finally generated (i.e. NO more transformations
-- after this!).
import CoreUnfold ( couldBeSmallEnoughToInline )
import Var ( Id )
import VarEnv
+import UniqFM ( ufmToList )
import Maybes
+import Outputable
\end{code}
This module walks over @Core@, and looks for @case@ on free variables.
\end{verbatim}
(note the NEED for shadowing)
-=> Run Andr\'e's wonder pass ...
+=> Simplify
+
\begin{verbatim}
f = \ t -> case v of
V a b -> a : (letrec
f = \ t -> a : f t
in f t)
\begin{verbatim}
+
Better code, because 'a' is free inside the inner letrec, rather
than needing projection from v.
initEnv :: Int -> LibCaseEnv
initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv []
+pprEnv :: LibCaseEnv -> SDoc
+pprEnv (LibCaseEnv _ lvl lvl_env _ scruts)
+ = vcat [text "LibCaseEnv" <+> int lvl,
+ fsep (map ppr (ufmToList lvl_env)),
+ fsep (map ppr scruts)]
+
bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size
\end{code}
\begin{code}
libCaseId :: LibCaseEnv -> Id -> CoreExpr
libCaseId env v
- | Just the_bind <- lookupRecId env v, -- It's a use of a recursive thing
- there_are_free_scruts -- with free vars scrutinised in RHS
- = Let the_bind (Var v)
+ | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
+ -- = not (null free_scruts) -- with free vars scrutinised in RHS
+ = if null free_scruts then
+ pprTrace "No:" (ppr v $$ pprEnv env) (Var v)
+ else
+ pprTrace "Yes:" (ppr v) $ Let the_bind (Var v)
| otherwise
= Var v
where
- rec_id_level = lookupLevel env v
- there_are_free_scruts = freeScruts env rec_id_level
+ rec_id_level = lookupLevel env v
+ free_scruts = freeScruts env rec_id_level
\end{code}
lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
-#ifndef DEBUG
= lookupVarEnv rec_env id
-#else
- = case (lookupVarEnv rec_env id) of
- xxx@(Just _) -> xxx
- xxx -> xxx
-#endif
lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
freeScruts :: LibCaseEnv
-> LibCaseLevel -- Level of the recursive Id
- -> Bool -- True <=> there is an enclosing case of a variable
- -- bound outside (ie level <=) the recursive Id.
+ -> [Id] -- Ids that are bound ouside the recursive Id, (level <=)
+ -- but which are scrutinised on the way to this call
freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl
- = not (null free_scruts)
- where
- free_scruts = [v | (v,lvl) <- scruts, lvl <= rec_bind_lvl]
+ = [v | (v,lvl) <- scruts, lvl <= rec_bind_lvl]
\end{code}
projects / ghc-hetmet.git / commitdiff