X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=4fc7362155d3bf665e889b63f309471eefab3c28;hb=f62fd70df7695286af55854911dad8a28eecb5e1;hp=e5f020a6bf8d3f911de5b8cc8ceac3e4a615372e;hpb=67a9242d7444a401056d61499c41e6e6d7555463;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index e5f020a..4fc7362 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -7,27 +7,39 @@ Overview *************************** -* We attach binding levels to Core bindings, in preparation for floating - outwards (@FloatOut@). +1. We attach binding levels to Core bindings, in preparation for floating + outwards (@FloatOut@). -* We also let-ify many expressions (notably case scrutinees), so they - will have a fighting chance of being floated sensible. +2. We also let-ify many expressions (notably case scrutinees), so they + will have a fighting chance of being floated sensible. -* We clone the binders of any floatable let-binding, so that when it is - floated out it will be unique. (This used to be done by the simplifier - but the latter now only ensures that there's no shadowing.) - NOTE: Very tiresomely, we must apply this substitution to - the rules stored inside a variable too. +3. We clone the binders of any floatable let-binding, so that when it is + floated out it will be unique. (This used to be done by the simplifier + but the latter now only ensures that there's no shadowing; indeed, even + that may not be true.) - We do *not* clone top-level bindings, because some of them must not change, - but we *do* clone bindings that are heading for the top level + NOTE: this can't be done using the uniqAway idea, because the variable + must be unique in the whole program, not just its current scope, + because two variables in different scopes may float out to the + same top level place -* In the expression + NOTE: Very tiresomely, we must apply this substitution to + the rules stored inside a variable too. + + We do *not* clone top-level bindings, because some of them must not change, + but we *do* clone bindings that are heading for the top level + +4. In the expression case x of wild { p -> ...wild... } - we substitute x for wild in the RHS of the case alternatives: + we substitute x for wild in the RHS of the case alternatives: case x of wild { p -> ...x... } - This means that a sub-expression involving x is not "trapped" inside the RHS. - And it's not inconvenient because we already have a substitution. + This means that a sub-expression involving x is not "trapped" inside the RHS. + And it's not inconvenient because we already have a substitution. + + Note that this is EXACTLY BACKWARDS from the what the simplifier does. + The simplifier tries to get rid of occurrences of x, in favour of wild, + in the hope that there will only be one remaining occurrence of x, namely + the scrutinee of the case, and we can inline it. \begin{code} module SetLevels ( @@ -45,18 +57,17 @@ import CoreSyn import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType ) import CoreFVs -- all of it import Subst -import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo, +import Id ( Id, idType, mkSysLocal, isOneShotLambda, zapDemandIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) -import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo ) -import Var ( Var, TyVar, setVarUnique ) +import IdInfo ( workerExists, vanillaIdInfo, ) +import Var ( Var ) import VarSet import VarEnv import Name ( getOccName ) import OccName ( occNameUserString ) import Type ( isUnLiftedType, Type ) import BasicTypes ( TopLevelFlag(..) ) -import Demand ( isStrict, wwLazy ) import UniqSupply import Util ( sortLt, isSingleton, count ) import Outputable @@ -69,7 +80,9 @@ import Outputable %************************************************************************ \begin{code} -data Level = Level Int -- Level number of enclosing lambdas +data Level = InlineCtxt -- A level that's used only for + -- the context parameter ctxt_lvl + | Level Int -- Level number of enclosing lambdas Int -- Number of big-lambda and/or case expressions between -- here and the nearest enclosing lambda \end{code} @@ -94,46 +107,69 @@ The main function @lvlExpr@ carries a ``context level'' (@ctxt_lvl@). That's meant to be the level number of the enclosing binder in the final (floated) program. If the level number of a sub-expression is less than that of the context, then it might be worth let-binding the -sub-expression so that it will indeed float. This context level starts -at @Level 0 0@. +sub-expression so that it will indeed float. + +If you can float to level @Level 0 0@ worth doing so because then your +allocation becomes static instead of dynamic. We always start with +context @Level 0 0@. @InlineCtxt@ very similar to @Level 0 0@, but is +used for one purpose: to say "don't float anything out of here". +That's exactly what we want for the body of an INLINE, where we don't +want to float anything out at all. See notes with lvlMFE below. + \begin{code} type LevelledExpr = TaggedExpr Level -type LevelledArg = TaggedArg Level type LevelledBind = TaggedBind Level -tOP_LEVEL = Level 0 0 +tOP_LEVEL = Level 0 0 +iNLINE_CTXT = InlineCtxt incMajorLvl :: Level -> Level +incMajorLvl InlineCtxt = Level 1 0 incMajorLvl (Level major minor) = Level (major+1) 0 incMinorLvl :: Level -> Level +incMinorLvl InlineCtxt = Level 0 1 incMinorLvl (Level major minor) = Level major (minor+1) maxLvl :: Level -> Level -> Level +maxLvl InlineCtxt l2 = l2 +maxLvl l1 InlineCtxt = l1 maxLvl l1@(Level maj1 min1) l2@(Level maj2 min2) | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1 | otherwise = l2 ltLvl :: Level -> Level -> Bool +ltLvl any_lvl InlineCtxt = False +ltLvl InlineCtxt (Level _ _) = True ltLvl (Level maj1 min1) (Level maj2 min2) = (maj1 < maj2) || (maj1 == maj2 && min1 < min2) ltMajLvl :: Level -> Level -> Bool -- Tells if one level belongs to a difft *lambda* level to another - -- But it returns True regardless if l1 is the top level - -- We always like to float to the top! -ltMajLvl (Level 0 0) _ = True +ltMajLvl any_lvl InlineCtxt = False +ltMajLvl InlineCtxt (Level maj2 _) = 0 < maj2 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2 isTopLvl :: Level -> Bool isTopLvl (Level 0 0) = True -isTopLvl other = False +isTopLvl other = False + +isInlineCtxt :: Level -> Bool +isInlineCtxt InlineCtxt = True +isInlineCtxt other = False instance Outputable Level where + ppr InlineCtxt = text "" ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] + +instance Eq Level where + InlineCtxt == InlineCtxt = True + (Level maj1 min1) == (Level maj2 min2) = maj1==maj2 && min1==min2 + l1 == l2 = False \end{code} + %************************************************************************ %* * \subsection{Main level-setting code} @@ -214,8 +250,8 @@ lvlExpr ctxt_lvl env (_, AnnApp fun arg) -- but we do if the function is big and hairy, like a case lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr) - -- Don't float anything out of an InlineMe - = lvlExpr tOP_LEVEL env expr `thenLvl` \ expr' -> +-- Don't float anything out of an InlineMe; hence the iNLINE_CTXT + = lvlExpr iNLINE_CTXT env expr `thenLvl` \ expr' -> returnLvl (Note InlineMe expr') lvlExpr ctxt_lvl env (_, AnnNote note expr) @@ -250,7 +286,6 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts) mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' -> returnLvl (Case expr' (case_bndr, incd_lvl) alts') where - expr_type = exprType (deAnnotate expr) incd_lvl = incMinorLvl ctxt_lvl lvl_alt alts_env (con, bs, rhs) @@ -294,6 +329,8 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) || not good_destination || exprIsTrivial expr -- Is trivial || (strict_ctxt && exprIsBottom expr) -- Strict context and is bottom + -- e.g. \x -> error "foo" + -- No gain from floating this = -- Don't float it out lvlExpr ctxt_lvl env ann_expr @@ -308,11 +345,18 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) dest_lvl = destLevel env fvs (isFunction ann_expr) abs_vars = abstractVars dest_lvl env fvs - good_destination = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda - || (isTopLvl dest_lvl && not strict_ctxt) -- Goes to the top + good_destination = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda + || (isTopLvl dest_lvl -- Goes to the top + && not (isInlineCtxt ctxt_lvl) -- Don't float out of an __inline__ context + && not strict_ctxt) -- or from a strict context -- A decision to float entails let-binding this thing, and we only do -- that if we'll escape a value lambda, or will go to the top level. - -- But beware + -- But beware (a): + -- x = __inline__ (f (g y)) + -- Here we don't want to float the (g y); otherwise it'll get outside the + -- __inline__ envelope, and may never get inlined + -- + -- Also beware (b): -- concat = /\ a -> foldr ..a.. (++) [] -- was getting turned into -- concat = /\ a -> lvl a @@ -340,7 +384,7 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) | null abs_vars = -- No type abstraction; clone existing binder - lvlExpr ctxt_lvl env rhs `thenLvl` \ rhs' -> + lvlExpr dest_lvl env rhs `thenLvl` \ rhs' -> cloneVar top_lvl env bndr ctxt_lvl dest_lvl `thenLvl` \ (env', bndr') -> returnLvl (NonRec (bndr', dest_lvl) rhs', env') @@ -365,7 +409,7 @@ lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) \begin{code} lvlBind top_lvl ctxt_lvl env (AnnRec pairs) | null abs_vars - = cloneVars top_lvl env bndrs ctxt_lvl dest_lvl `thenLvl` \ (new_env, new_bndrs) -> + = cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl `thenLvl` \ (new_env, new_bndrs) -> mapLvl (lvlExpr ctxt_lvl new_env) rhss `thenLvl` \ new_rhss -> returnLvl (Rec ((new_bndrs `zip` repeat dest_lvl) `zip` new_rhss), new_env) @@ -437,6 +481,8 @@ lvlFloatRhs abs_vars dest_lvl env rhs \begin{code} lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [(CoreBndr, Level)]) -- Compute the levels for the binders of a lambda group +-- The binders returned are exactly the same as the ones passed, +-- but they are now paired with a level lvlLamBndrs lvl [] = (lvl, []) @@ -523,14 +569,16 @@ isFunction other = False \begin{code} type LevelEnv = (Bool, -- True <=> Float lambdas too VarEnv Level, -- Domain is *post-cloned* TyVars and Ids - SubstEnv, -- Domain is pre-cloned Ids + Subst, -- Domain is pre-cloned Ids; tracks the in-scope set + -- so that subtitution is capture-avoiding IdEnv ([Var], LevelledExpr)) -- Domain is pre-cloned Ids -- We clone let-bound variables so that they are still -- distinct when floated out; hence the SubstEnv/IdEnv. + -- (see point 3 of the module overview comment). -- We also use these envs when making a variable polymorphic -- because we want to float it out past a big lambda. -- - -- The two Envs always implement the same mapping, but the + -- The SubstEnv and IdEnv always implement the same mapping, but the -- SubstEnv maps to CoreExpr and the IdEnv to LevelledExpr -- Since the range is always a variable or type application, -- there is never any difference between the two, but sadly @@ -546,43 +594,65 @@ type LevelEnv = (Bool, -- True <=> Float lambdas too -- The domain of the VarEnv Level is the *post-cloned* Ids initialEnv :: Bool -> LevelEnv -initialEnv float_lams = (float_lams, emptyVarEnv, emptySubstEnv, emptyVarEnv) +initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv) floatLams :: LevelEnv -> Bool floatLams (float_lams, _, _, _) = float_lams extendLvlEnv :: LevelEnv -> [(Var,Level)] -> LevelEnv - -- Used when *not* cloning -extendLvlEnv (float_lams, lvl_env, subst_env, id_env) prs - = (float_lams, foldl add lvl_env prs, subst_env, id_env) +-- Used when *not* cloning +extendLvlEnv (float_lams, lvl_env, subst, id_env) prs + = (float_lams, + foldl add_lvl lvl_env prs, + foldl del_subst subst prs, + foldl del_id id_env prs) where - add env (v,l) = extendVarEnv env v l + add_lvl env (v,l) = extendVarEnv env v l + del_subst env (v,_) = extendInScope env v + del_id env (v,_) = delVarEnv env v + -- We must remove any clone for this variable name in case of + -- shadowing. This bit me in the following case + -- (in nofib/real/gg/Spark.hs): + -- + -- case ds of wild { + -- ... -> case e of wild { + -- ... -> ... wild ... + -- } + -- } + -- + -- The inside occurrence of @wild@ was being replaced with @ds@, + -- incorrectly, because the SubstEnv was still lying around. Ouch! + -- KSW 2000-07. -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can +-- (see point 4 of the module overview comment) +extendCaseBndrLvlEnv (float_lams, lvl_env, subst, id_env) (Var scrut_var) case_bndr lvl + = (float_lams, + extendVarEnv lvl_env case_bndr lvl, + extendSubst subst case_bndr (DoneEx (Var scrut_var)), + extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var)) + extendCaseBndrLvlEnv env scrut case_bndr lvl - = case scrut of - Var v -> extendCloneLvlEnv lvl env [(case_bndr, v)] - other -> extendLvlEnv env [(case_bndr,lvl)] + = extendLvlEnv env [(case_bndr,lvl)] -extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst_env, id_env) abs_vars bndr_pairs +extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pairs = (float_lams, - foldl add_lvl lvl_env bndr_pairs, - foldl add_subst subst_env bndr_pairs, - foldl add_id id_env bndr_pairs) + foldl add_lvl lvl_env bndr_pairs, + foldl add_subst subst bndr_pairs, + foldl add_id id_env bndr_pairs) where - add_lvl env (v,v') = extendVarEnv env v' dest_lvl - add_subst env (v,v') = extendSubstEnv env v (DoneEx (mkVarApps (Var v') abs_vars)) - add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) + add_lvl env (v,v') = extendVarEnv env v' dest_lvl + add_subst env (v,v') = extendSubst env v (DoneEx (mkVarApps (Var v') abs_vars)) + add_id env (v,v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars) -extendCloneLvlEnv lvl (float_lams, lvl_env, subst_env, id_env) bndr_pairs +extendCloneLvlEnv lvl (float_lams, lvl_env, _, id_env) new_subst bndr_pairs = (float_lams, - foldl add_lvl lvl_env bndr_pairs, - foldl add_subst subst_env bndr_pairs, - foldl add_id id_env bndr_pairs) + foldl add_lvl lvl_env bndr_pairs, + new_subst, + foldl add_id id_env bndr_pairs) where - add_lvl env (v,v') = extendVarEnv env v' lvl - add_subst env (v,v') = extendSubstEnv env v (DoneEx (Var v')) - add_id env (v,v') = extendVarEnv env v ([v'], Var v') + add_lvl env (v,v') = extendVarEnv env v' lvl + add_id env (v,v') = extendVarEnv env v ([v'], Var v') maxIdLevel :: LevelEnv -> VarSet -> Level @@ -646,7 +716,7 @@ mapLvl = mapUs \begin{code} newPolyBndrs dest_lvl env abs_vars bndrs - = getUniquesUs (length bndrs) `thenLvl` \ uniqs -> + = getUniquesUs `thenLvl` \ uniqs -> let new_bndrs = zipWith mk_poly_bndr bndrs uniqs in @@ -671,42 +741,33 @@ newLvlVar str vars body_ty cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id) cloneVar TopLevel env v ctxt_lvl dest_lvl = returnUs (env, v) -- Don't clone top level things -cloneVar NotTopLevel env v ctxt_lvl dest_lvl +cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl = ASSERT( isId v ) - getUniqueUs `thenLvl` \ uniq -> + getUs `thenLvl` \ us -> let - v' = setVarUnique v uniq - v'' = subst_id_info env ctxt_lvl dest_lvl v' - env' = extendCloneLvlEnv dest_lvl env [(v,v'')] + (subst', v1) = substAndCloneId subst us v + v2 = zap_demand ctxt_lvl dest_lvl v1 + env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] in - returnUs (env', v'') + returnUs (env', v2) -cloneVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id]) -cloneVars TopLevel env vs ctxt_lvl dest_lvl +cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id]) +cloneRecVars TopLevel env vs ctxt_lvl dest_lvl = returnUs (env, vs) -- Don't clone top level things -cloneVars NotTopLevel env vs ctxt_lvl dest_lvl +cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl = ASSERT( all isId vs ) - getUniquesUs (length vs) `thenLvl` \ uniqs -> + getUs `thenLvl` \ us -> let - vs' = zipWith setVarUnique vs uniqs - vs'' = map (subst_id_info env' ctxt_lvl dest_lvl) vs' - env' = extendCloneLvlEnv dest_lvl env (vs `zip` vs'') + (subst', vs1) = substAndCloneRecIds subst us vs + vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1 + env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) in - returnUs (env', vs'') - -subst_id_info (_, _, subst_env, _) ctxt_lvl dest_lvl v - = modifyIdInfo (\info -> substIdInfo subst info (zap_dmd info)) v - where - subst = mkSubst emptyVarSet subst_env + returnUs (env', vs2) -- VERY IMPORTANT: we must zap the demand info -- if the thing is going to float out past a lambda - zap_dmd info - | float_past_lam && isStrict (demandInfo info) - = setDemandInfo info wwLazy - | otherwise - = info - - float_past_lam = ctxt_lvl `ltMajLvl` dest_lvl +zap_demand dest_lvl ctxt_lvl id + | ctxt_lvl == dest_lvl = id -- Stays put + | otherwise = zapDemandIdInfo id -- Floats out \end{code}