X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=40366cfd9310ea2016107c3bde2e6fcb7d0aa733;hb=48081b06ec1aeb42c7d98d2dfa83e3df53ffb7a6;hp=51a46766bcb3a846789078ad38e0a486e0cc139d;hpb=96acca9ada515033cfa9b50bb36c1ca0bffe15dc;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 51a4676..40366cf 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -15,7 +15,14 @@
 
 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.)
+   but the latter now only ensures that there's no shadowing; indeed, even 
+   that may not be true.)
+
+   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
+
    NOTE: Very tiresomely, we must apply this substitution to
 	 the rules stored inside a variable too.
 
@@ -50,7 +57,7 @@ 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, modifyIdInfo, 
 			  idSpecialisation, idWorkerInfo, setIdInfo
 			)
 import IdInfo		( workerExists, vanillaIdInfo, demandInfo, setDemandInfo )
@@ -104,7 +111,6 @@ at @Level 0 0@.
 
 \begin{code}
 type LevelledExpr  = TaggedExpr Level
-type LevelledArg   = TaggedArg	Level
 type LevelledBind  = TaggedBind Level
 
 tOP_LEVEL = Level 0 0
@@ -126,9 +132,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
@@ -137,6 +140,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}
 
 %************************************************************************
@@ -219,8 +225,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)
@@ -298,6 +304,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
 
@@ -344,7 +352,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') 
 
@@ -441,6 +449,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, [])
 
@@ -527,7 +537,8 @@ 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.
@@ -535,7 +546,7 @@ type LevelEnv = (Bool, 				-- True <=> Float lambdas too
 	-- 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
@@ -551,25 +562,25 @@ 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
+extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
   = (float_lams,
      foldl add_lvl lvl_env prs,
-     foldl del_subst subst_env prs,
+     foldl del_subst subst prs,
      foldl del_id id_env prs)
   where
     add_lvl   env (v,l) = extendVarEnv env v l
-    del_subst env (v,_) = delSubstEnv env v
+    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):
+  -- shadowing.  This bit me in the following case
+  -- (in nofib/real/gg/Spark.hs):
   -- 
   --   case ds of wild {
   --     ... -> case e of wild {
@@ -588,25 +599,25 @@ extendCaseBndrLvlEnv env scrut case_bndr lvl
 	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
@@ -718,19 +729,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}