X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=1602a07b8673eec22758ac6560a84dc6e3073a7a;hb=96179bddcb250a1772adc5a86d62c17125637709;hp=8621ae1c2e00ac0b3f2314c053f05c9a25c83339;hpb=a7ae6708217a4c6973be1d0a9965a63cf6a02ff3;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 8621ae1..1602a07 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -21,11 +21,11 @@ import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, - isFCallId, isGlobalId, + isFCallId, isGlobalId, isImplicitId, isLocalId, hasNoBinding, idNewStrictness, - isDataConId_maybe, idUnfolding + idUnfolding, isDataConWorkId_maybe ) -import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts ) +import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -96,23 +96,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 -> - returnUs (deFloatTop (floats1 `appOL` floats2)) + corePrepTopBinds binds `thenUs` \ floats1 -> + corePrepTopBinds implicit_binds `thenUs` \ floats2 -> + returnUs (deFloatTop (floats1 `appendFloats` 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 @@ -154,14 +154,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} @@ -174,45 +178,81 @@ data FloatingBind = FloatLet CoreBind | FloatCase Id CoreExpr Bool -- The bool indicates "ok-for-speculation" +data Floats = Floats OkToSpec (OrdList FloatingBind) + +-- Can we float these binds out of the rhs of a let? We cache this decision +-- to avoid having to recompute it in a non-linear way when there are +-- deeply nested lets. +data OkToSpec + = NotOkToSpec -- definitely not + | OkToSpec -- yes + | IfUnboxedOk -- only if floating an unboxed binding is ok + +emptyFloats :: Floats +emptyFloats = Floats OkToSpec nilOL + +addFloat :: Floats -> FloatingBind -> Floats +addFloat (Floats ok_to_spec floats) new_float + = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) + where + check (FloatLet _) = OkToSpec + check (FloatCase _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level + +unitFloat :: FloatingBind -> Floats +unitFloat = addFloat emptyFloats + +appendFloats :: Floats -> Floats -> Floats +appendFloats (Floats spec1 floats1) (Floats spec2 floats2) + = Floats (combine spec1 spec2) (floats1 `appOL` floats2) + +concatFloats :: [Floats] -> Floats +concatFloats = foldr appendFloats emptyFloats + +combine NotOkToSpec _ = NotOkToSpec +combine _ NotOkToSpec = NotOkToSpec +combine IfUnboxedOk _ = IfUnboxedOk +combine _ IfUnboxedOk = IfUnboxedOk +combine _ _ = OkToSpec + instance Outputable FloatingBind where ppr (FloatLet bind) = text "FloatLet" <+> ppr bind ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs type CloneEnv = IdEnv Id -- Clone local Ids -deFloatTop :: OrdList FloatingBind -> [CoreBind] +deFloatTop :: Floats -> [CoreBind] -- For top level only; we don't expect any FloatCases -deFloatTop floats +deFloatTop (Floats _ floats) = foldrOL get [] floats where get (FloatLet b) bs = b:bs get b bs = pprPanic "corePrepPgm" (ppr b) -allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool -allLazy top_lvl is_rec floats - = foldrOL check True floats - where - unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec - - check (FloatLet _) y = y - check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level +allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool +allLazy top_lvl is_rec (Floats ok_to_spec _) + = case ok_to_spec of + OkToSpec -> True + NotOkToSpec -> False + IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec -- --------------------------------------------------------------------------- -- Bindings -- --------------------------------------------------------------------------- -corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind) +corePrepTopBinds :: [CoreBind] -> UniqSM Floats corePrepTopBinds binds = go emptyVarEnv binds where - go env [] = returnUs nilOL + go env [] = returnUs emptyFloats go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') -> go env' binds `thenUs` \ binds' -> - returnUs (bind' `appOL` binds') + returnUs (bind' `appendFloats` binds') -- NB: we do need to float out of top-level bindings -- Consider x = length [True,False] @@ -227,18 +267,31 @@ 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) +corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats) corePrepTopBind env (NonRec bndr rhs) = cloneBndr env bndr `thenUs` \ (env', bndr') -> corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') -> - returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs')) + returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs'))) corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs -------------------------------- -corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) +corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats) -- This one is used for *local* bindings corePrepBind env (NonRec bndr rhs) = etaExpandRhs bndr rhs `thenUs` \ rhs1 -> @@ -252,16 +305,16 @@ corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs -------------------------------- corePrepRecPairs :: TopLevelFlag -> CloneEnv -> [(Id,CoreExpr)] -- Recursive bindings - -> UniqSM (CloneEnv, OrdList FloatingBind) + -> UniqSM (CloneEnv, Floats) -- Used for all recursive bindings, top level and otherwise corePrepRecPairs lvl env pairs = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') -> mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs `thenUs` \ (floats_s, rhss') -> - returnUs (env', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss')))) + returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss')))) where -- Flatten all the floats, and the currrent -- group into a single giant Rec - flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats + flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 @@ -269,7 +322,7 @@ corePrepRecPairs lvl env pairs -------------------------------- corePrepRhs :: TopLevelFlag -> RecFlag -> CloneEnv -> (Id, CoreExpr) - -> UniqSM (OrdList FloatingBind, CoreExpr) + -> UniqSM (Floats, CoreExpr) -- Used for top-level bindings, and local recursive bindings corePrepRhs top_lvl is_rec env (bndr, rhs) = etaExpandRhs bndr rhs `thenUs` \ rhs' -> @@ -283,7 +336,7 @@ corePrepRhs top_lvl is_rec env (bndr, rhs) -- This is where we arrange that a non-trivial argument is let-bound corePrepArg :: CloneEnv -> CoreArg -> RhsDemand - -> UniqSM (OrdList FloatingBind, CoreArg) + -> UniqSM (Floats, CoreArg) corePrepArg env arg dem = corePrepExprFloat env arg `thenUs` \ (floats, arg') -> if exprIsTrivial arg' @@ -312,7 +365,7 @@ corePrepAnExpr env expr mkBinds floats expr -corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) +corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) -- If -- e ===> (bs, e') -- then @@ -325,18 +378,18 @@ corePrepExprFloat env (Var v) = fiddleCCall v `thenUs` \ v1 -> let v2 = lookupVarEnv env v1 `orElse` v1 in maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app -> - returnUs (nilOL, app) + returnUs (emptyFloats, app) corePrepExprFloat env expr@(Type _) - = returnUs (nilOL, expr) + = returnUs (emptyFloats, expr) corePrepExprFloat env expr@(Lit lit) - = returnUs (nilOL, expr) + = returnUs (emptyFloats, expr) corePrepExprFloat env (Let bind body) = corePrepBind env bind `thenUs` \ (env', new_binds) -> corePrepExprFloat env' body `thenUs` \ (floats, new_body) -> - returnUs (new_binds `appOL` floats, new_body) + returnUs (new_binds `appendFloats` floats, new_body) corePrepExprFloat env (Note n@(SCC _) expr) = corePrepAnExpr env expr `thenUs` \ expr1 -> @@ -350,7 +403,7 @@ corePrepExprFloat env (Note other_note expr) corePrepExprFloat env expr@(Lam _ _) = cloneBndrs env bndrs `thenUs` \ (env', bndrs') -> corePrepAnExpr env' body `thenUs` \ body' -> - returnUs (nilOL, mkLams bndrs' body') + returnUs (emptyFloats, mkLams bndrs' body') where (bndrs,body) = collectBinders expr @@ -359,7 +412,7 @@ corePrepExprFloat env (Case scrut bndr alts) deLamFloat scrut1 `thenUs` \ (floats2, scrut2) -> cloneBndr env bndr `thenUs` \ (env', bndr') -> mapUs (sat_alt env') alts `thenUs` \ alts' -> - returnUs (floats1 `appOL` floats2 , Case scrut2 bndr' alts') + returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' alts') where sat_alt env (con, bs, rhs) = cloneBndrs env bs `thenUs` \ (env', bs') -> @@ -393,7 +446,7 @@ corePrepExprFloat env expr@(App _ _) (CoreExpr,Int), -- the head of the application, -- and no. of args it was applied to Type, -- type of the whole expr - OrdList FloatingBind, -- any floats we pulled out + Floats, -- any floats we pulled out [Demand]) -- remaining argument demands collect_args (App fun arg@(Type arg_ty)) depth @@ -410,12 +463,12 @@ corePrepExprFloat env expr@(App _ _) splitFunTy_maybe fun_ty in corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') -> - returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest) + returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) collect_args (Var v) depth = fiddleCCall v `thenUs` \ v1 -> let v2 = lookupVarEnv env v1 `orElse` v1 in - returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts) + returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) where stricts = case idNewStrictness v of StrictSig (DmdType _ demands _) @@ -449,10 +502,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 @@ -476,9 +530,9 @@ maybeSaturate fn expr n_args ty floatRhs :: TopLevelFlag -> RecFlag -> Id - -> (OrdList FloatingBind, CoreExpr) -- Rhs: let binds in body - -> UniqSM (OrdList FloatingBind, -- Floats out of this bind - CoreExpr) -- Final Rhs + -> (Floats, CoreExpr) -- Rhs: let binds in body + -> UniqSM (Floats, -- Floats out of this bind + CoreExpr) -- Final Rhs floatRhs top_lvl is_rec bndr (floats, rhs) | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or @@ -494,12 +548,12 @@ floatRhs top_lvl is_rec bndr (floats, rhs) | otherwise -- Don't float; the RHS isn't a value = mkBinds floats rhs `thenUs` \ rhs' -> - returnUs (nilOL, rhs') + returnUs (emptyFloats, rhs') -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings -mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand - -> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body - -> UniqSM (OrdList FloatingBind) +mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand + -> Floats -> CoreExpr -- Rhs: let binds in body + -> UniqSM Floats mkLocalNonRec bndr dem floats rhs | isUnLiftedType (idType bndr) @@ -508,7 +562,7 @@ mkLocalNonRec bndr dem floats rhs let float = FloatCase bndr rhs (exprOkForSpeculation rhs) in - returnUs (floats `snocOL` float) + returnUs (addFloat floats float) | isStrict dem -- It's a strict let so we definitely float all the bindings @@ -518,18 +572,15 @@ mkLocalNonRec bndr dem floats rhs float | exprIsValue rhs = FloatLet (NonRec bndr rhs) | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs) in - returnUs (floats `snocOL` float) + returnUs (addFloat floats float) | otherwise = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> - returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs')) - - where - bndr_ty = idType bndr + returnUs (addFloat floats' (FloatLet (NonRec bndr rhs'))) -mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr -mkBinds binds body +mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr +mkBinds (Floats _ binds) body | isNilOL binds = returnUs body | otherwise = deLam body `thenUs` \ body' -> returnUs (foldrOL mk_bind body' binds) @@ -587,7 +638,7 @@ deLam expr = mkBinds floats expr -deLamFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr) +deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr) -- Remove top level lambdas by let-bindinig deLamFloat (Note n expr) @@ -597,12 +648,12 @@ deLamFloat (Note n expr) returnUs (floats, Note n expr') deLamFloat expr - | null bndrs = returnUs (nilOL, expr) + | null bndrs = returnUs (emptyFloats, expr) | otherwise = case tryEta bndrs body of - Just no_lam_result -> returnUs (nilOL, no_lam_result) + Just no_lam_result -> returnUs (emptyFloats, no_lam_result) Nothing -> newVar (exprType expr) `thenUs` \ fn -> - returnUs (unitOL (FloatLet (NonRec fn expr)), + returnUs (unitFloat (FloatLet (NonRec fn expr)), Var fn) where (bndrs,body) = collectBinders expr @@ -626,7 +677,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)