X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=806d9dfb4b2187e6efe96139b27d9548b479d88e;hb=fffba9e37c59f6b03bb79dcafb818b88abc0ed47;hp=22472899d04384e96cf331c741e5e30f92c6991e;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 2247289..806d9df 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 ( @@ -42,19 +54,19 @@ module SetLevels ( import CoreSyn -import CoreUtils ( exprType, exprIsTrivial, exprIsBottom ) +import CoreUtils ( exprType, exprIsTrivial, exprIsBottom, mkPiType ) import CoreFVs -- all of it import Subst import Id ( Id, idType, idFreeTyVars, mkSysLocal, isOneShotLambda, modifyIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) import IdInfo ( workerExists, vanillaIdInfo, demandInfo, setDemandInfo ) -import Var ( Var, TyVar, setVarUnique ) +import Var ( Var, setVarUnique ) import VarSet import VarEnv import Name ( getOccName ) import OccName ( occNameUserString ) -import Type ( isUnLiftedType, mkPiType, Type ) +import Type ( isUnLiftedType, Type ) import BasicTypes ( TopLevelFlag(..) ) import Demand ( isStrict, wwLazy ) import UniqSupply @@ -121,9 +133,6 @@ ltLvl (Level maj1 min1) (Level maj2 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 (Level maj1 _) (Level maj2 _) = maj1 < maj2 isTopLvl :: Level -> Bool @@ -132,6 +141,9 @@ isTopLvl other = False instance Outputable Level where ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ] + +instance Eq Level where + (Level maj1 min1) == (Level maj2 min2) = maj1==maj2 && min1==min2 \end{code} %************************************************************************ @@ -214,8 +226,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 tOP_LEVEL + = lvlExpr tOP_LEVEL env expr `thenLvl` \ expr' -> returnLvl (Note InlineMe expr') lvlExpr ctxt_lvl env (_, AnnNote note expr) @@ -250,7 +262,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 +305,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 @@ -340,7 +353,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') @@ -437,6 +450,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 +538,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 +563,62 @@ 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 env scrut case_bndr lvl = case scrut of Var v -> extendCloneLvlEnv lvl env [(case_bndr, v)] other -> 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, subst, id_env) 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' 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_subst env (v,v') = extendSubst env v (DoneEx (Var v')) + add_id env (v,v') = extendVarEnv env v ([v'], Var v') maxIdLevel :: LevelEnv -> VarSet -> Level @@ -694,19 +730,15 @@ cloneVars NotTopLevel env vs ctxt_lvl dest_lvl in returnUs (env', vs'') -subst_id_info (_, _, subst_env, _) ctxt_lvl dest_lvl v +subst_id_info (_, _, subst, _) ctxt_lvl dest_lvl v = modifyIdInfo (\info -> substIdInfo subst info (zap_dmd info)) v where - subst = mkSubst emptyVarSet subst_env - -- 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 + | stays_put || not (isStrict (demandInfo info)) = info + | otherwise = setDemandInfo info wwLazy - float_past_lam = ctxt_lvl `ltMajLvl` dest_lvl + stays_put = ctxt_lvl == dest_lvl \end{code}