X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=d2515c9cb53951579a8a37ede0c0673eb5b110f5;hb=05afb7485eea44d6410139f8a20c94b6f66c46f2;hp=5b18681b5719ee81058b5848270fa88f4fdaba64;hpb=9003a18c4efa4548ae80709aef9963f7b544ded3;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 5b18681..d2515c9 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -15,18 +15,18 @@ import CoreFVs ( exprFreeVars ) import CoreLint ( endPass ) import CoreSyn import Type ( Type, applyTy, splitFunTy_maybe, - isUnLiftedType, isUnboxedTupleType, repType, seqType ) + isUnLiftedType, isUnboxedTupleType, seqType ) +import TcType ( TyThing( AnId ) ) import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) -import PrimOp ( PrimOp(..) ) import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, - setIdType, isPrimOpId_maybe, isFCallId, isGlobalId, + isFCallId, isGlobalId, isImplicitId, isLocalId, hasNoBinding, idNewStrictness, - isDataConId_maybe, idUnfolding + idUnfolding, isDataConWorkId_maybe ) -import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts ) +import HscTypes ( TypeEnv, typeEnvElts ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -64,7 +64,7 @@ The goal of this pass is to prepare for code generation. 4. Ensure that lambdas only occur as the RHS of a binding (The code generator can't deal with anything else.) -5. Do the seq/par munging. See notes with mkCase below. +5. [Not any more; nuked Jun 2002] Do the seq/par munging. 6. Clone all local Ids. This means that all such Ids are unique, rather than the @@ -97,23 +97,23 @@ any trivial or useless bindings. -- ----------------------------------------------------------------------------- \begin{code} -corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails -corePrepPgm dflags mod_details +corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind] +corePrepPgm dflags binds types = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let implicit_binds = mkImplicitBinds (md_types mod_details) + let implicit_binds = mkImplicitBinds types -- NB: we must feed mkImplicitBinds through corePrep too -- so that they are suitably cloned and eta-expanded binds_out = initUs_ us ( - corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 -> - corePrepTopBinds implicit_binds `thenUs` \ floats2 -> + corePrepTopBinds binds `thenUs` \ floats1 -> + corePrepTopBinds implicit_binds `thenUs` \ floats2 -> returnUs (deFloatTop (floats1 `appOL` floats2)) ) endPass dflags "CorePrep" Opt_D_dump_prep binds_out - return (mod_details { md_binds = binds_out }) + return binds_out corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr corePrepExpr dflags expr @@ -155,14 +155,18 @@ partial applications. But it's easier to let them through. \begin{code} mkImplicitBinds type_env = [ NonRec id (get_unfolding id) - | id <- implicitTyThingIds (typeEnvElts type_env) ] + | AnId id <- typeEnvElts type_env, isImplicitId id ] + -- The type environment already contains all the implicit Ids, + -- so we just filter them out + -- -- The etaExpand is so that the manifest arity of the -- binding matches its claimed arity, which is an -- invariant of top level bindings going into the code gen get_unfolding id -- See notes above - | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works - | otherwise = unfoldingTemplate (idUnfolding id) + | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works + -- CorePrep will eta-expand it + | otherwise = unfoldingTemplate (idUnfolding id) \end{code} @@ -228,6 +232,19 @@ corePrepTopBinds binds -- a = g y -- x* = f a -- And then x will actually end up case-bound +-- +-- What happens to the CafInfo on the floated bindings? By +-- default, all the CafInfos will be set to MayHaveCafRefs, +-- which is safe. +-- +-- This might be pessimistic, because eg. s1 & s2 +-- might not refer to any CAFs and the GC will end up doing +-- more traversal than is necessary, but it's still better +-- than not floating the bindings at all, because then +-- the GC would have to traverse the structure in the heap +-- instead. Given this, we decided not to try to get +-- the CafInfo on the floated bindings correct, because +-- it looks difficult. -------------------------------- corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) @@ -341,8 +358,8 @@ corePrepExprFloat env (Let bind body) corePrepExprFloat env (Note n@(SCC _) expr) = corePrepAnExpr env expr `thenUs` \ expr1 -> - deLam expr1 `thenUs` \ expr2 -> - returnUs (nilOL, Note n expr2) + deLamFloat expr1 `thenUs` \ (floats, expr2) -> + returnUs (floats, Note n expr2) corePrepExprFloat env (Note other_note expr) = corePrepExprFloat env expr `thenUs` \ (floats, expr') -> @@ -356,10 +373,11 @@ corePrepExprFloat env expr@(Lam _ _) (bndrs,body) = collectBinders expr corePrepExprFloat env (Case scrut bndr alts) - = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') -> + = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) -> + deLamFloat scrut1 `thenUs` \ (floats2, scrut2) -> cloneBndr env bndr `thenUs` \ (env', bndr') -> mapUs (sat_alt env') alts `thenUs` \ alts' -> - returnUs (floats, mkCase scrut' bndr' alts') + returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts') where sat_alt env (con, bs, rhs) = cloneBndrs env bs `thenUs` \ (env', bs') -> @@ -439,6 +457,8 @@ corePrepExprFloat env expr@(App _ _) returnUs (Note note fun', hd, fun_ty, floats, ss) -- non-variable fun, better let-bind it + -- ToDo: perhaps we can case-bind rather than let-bind this closure, + -- since it is sure to be evaluated. collect_args fun depth = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') -> newVar ty `thenUs` \ fn_id -> @@ -447,10 +467,11 @@ corePrepExprFloat env expr@(App _ _) where ty = exprType fun - ignore_note InlineCall = True - ignore_note InlineMe = True - ignore_note _other = False - -- we don't ignore SCCs, since they require some code generation + ignore_note (CoreNote _) = True + ignore_note InlineCall = True + ignore_note InlineMe = True + ignore_note _other = False + -- We don't ignore SCCs, since they require some code generation ------------------------------------------------------------------------------ -- Building the saturated syntax @@ -524,7 +545,7 @@ mkLocalNonRec bndr dem floats rhs where bndr_ty = idType bndr - bndr_rep_ty = repType bndr_ty + mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr mkBinds binds body @@ -532,7 +553,7 @@ mkBinds binds body | otherwise = deLam body `thenUs` \ body' -> returnUs (foldrOL mk_bind body' binds) where - mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)] + mk_bind (FloatCase bndr rhs _) body = Case rhs bndr [(DEFAULT, [], body)] mk_bind (FloatLet bind) body = Let bind body etaExpandRhs bndr rhs @@ -579,22 +600,29 @@ etaExpandRhs bndr rhs -- We arrange that they only show up as the RHS of a let(rec) -- --------------------------------------------------------------------------- -deLam :: CoreExpr -> UniqSM CoreExpr +deLam :: CoreExpr -> UniqSM CoreExpr +deLam expr = + deLamFloat expr `thenUs` \ (floats, expr) -> + mkBinds floats expr + + +deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) -- Remove top level lambdas by let-bindinig -deLam (Note n expr) +deLamFloat (Note n expr) = -- You can get things like -- case e of { p -> coerce t (\s -> ...) } - deLam expr `thenUs` \ expr' -> - returnUs (Note n expr') + deLamFloat expr `thenUs` \ (floats, expr') -> + returnUs (floats, Note n expr') -deLam expr - | null bndrs = returnUs expr +deLamFloat expr + | null bndrs = returnUs (nilOL, expr) | otherwise = case tryEta bndrs body of - Just no_lam_result -> returnUs no_lam_result + Just no_lam_result -> returnUs (nilOL, no_lam_result) Nothing -> newVar (exprType expr) `thenUs` \ fn -> - returnUs (Let (NonRec fn expr) (Var fn)) + returnUs (unitOL (FloatLet (NonRec fn expr)), + Var fn) where (bndrs,body) = collectBinders expr @@ -617,7 +645,7 @@ tryEta bndrs expr@(App _ _) n_remaining = length args - length bndrs ok bndr (Var arg) = bndr == arg - ok bndr other = False + ok bndr other = False -- we can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) @@ -636,55 +664,6 @@ tryEta bndrs _ = Nothing -- ----------------------------------------------------------------------------- --- Do the seq and par transformation --- ----------------------------------------------------------------------------- - -Here we do two pre-codegen transformations: - -1. case seq# a of { - 0 -> seqError ... - DEFAULT -> rhs } - ==> - case a of { DEFAULT -> rhs } - - -2. case par# a of { - 0 -> parError ... - DEFAULT -> rhs } - ==> - case par# a of { - DEFAULT -> rhs } - -NB: seq# :: a -> Int# -- Evaluate value and return anything - par# :: a -> Int# -- Spark value and return anything - -These transformations can't be done earlier, or else we might -think that the expression was strict in the variables in which -rhs is strict --- but that would defeat the purpose of seq and par. - - -\begin{code} -mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts@(deflt_alt@(DEFAULT,_,rhs) : con_alts) - -- DEFAULT alt is always first - = case isPrimOpId_maybe fn of - Just ParOp -> Case scrut bndr [deflt_alt] - Just SeqOp -> Case arg new_bndr [deflt_alt] - other -> Case scrut bndr alts - where - -- The binder shouldn't be used in the expression! - new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr ) - setIdType bndr (exprType arg) - -- NB: SeqOp :: forall a. a -> Int# - -- So bndr has type Int# - -- But now we are going to scrutinise the SeqOp's argument directly, - -- so we must change the type of the case binder to match that - -- of the argument expression e. - -mkCase scrut bndr alts = Case scrut bndr alts -\end{code} - - --- ----------------------------------------------------------------------------- -- Demands -- ----------------------------------------------------------------------------- @@ -705,8 +684,10 @@ bdrDem :: Id -> RhsDemand bdrDem id = mkDem (idNewDemandInfo id) False {- For now -} -safeDem, onceDem :: RhsDemand -safeDem = RhsDemand False False -- always safe to use this +-- safeDem :: RhsDemand +-- safeDem = RhsDemand False False -- always safe to use this + +onceDem :: RhsDemand onceDem = RhsDemand False True -- used at most once \end{code}