-type LvlM result
- = (GlobalSwitch -> Bool) -> UniqSupply -> result
-
-thenLvl m k sw us
- = case splitUniqSupply us of { (s1, s2) ->
- case m sw s1 of { m_result ->
- k m_result sw s2 }}
-
-returnLvl v sw us = v
-
-mapLvl f [] = returnLvl []
-mapLvl f (x:xs)
- = f x `thenLvl` \ r ->
- mapLvl f xs `thenLvl` \ rs ->
- returnLvl (r:rs)
-
-mapAndUnzipLvl f [] = returnLvl ([], [])
-mapAndUnzipLvl f (x:xs)
- = f x `thenLvl` \ (r1, r2) ->
- mapAndUnzipLvl f xs `thenLvl` \ (rs1, rs2) ->
- returnLvl (r1:rs1, r2:rs2)
-
-mapAndUnzip3Lvl f [] = returnLvl ([], [], [])
-mapAndUnzip3Lvl f (x:xs)
- = f x `thenLvl` \ (r1, r2, r3) ->
- mapAndUnzip3Lvl f xs `thenLvl` \ (rs1, rs2, rs3) ->
- returnLvl (r1:rs1, r2:rs2, r3:rs3)
-\end{code}
+type LevelEnv = (FloatOutSwitches,
+ VarEnv Level, -- Domain is *post-cloned* TyVars and 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 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
+ -- the types differ. The SubstEnv is used when substituting in
+ -- a variable's IdInfo; the IdEnv when we find a Var.
+ --
+ -- In addition the IdEnv records a list of tyvars free in the
+ -- type application, just so we don't have to call freeVars on
+ -- the type application repeatedly.
+ --
+ -- The domain of the both envs is *pre-cloned* Ids, though
+ --
+ -- The domain of the VarEnv Level is the *post-cloned* Ids
+
+initialEnv :: FloatOutSwitches -> LevelEnv
+initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
+
+floatLams :: LevelEnv -> Bool
+floatLams (FloatOutSw float_lams _, _, _, _) = float_lams
+
+floatConsts :: LevelEnv -> Bool
+floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
+
+extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
+-- 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_lvl env (TB v l) = extendVarEnv env v l
+ del_subst env (TB v _) = extendInScope env v
+ del_id env (TB 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,
+ extendIdSubst subst case_bndr (Var scrut_var),
+ extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
+
+extendCaseBndrLvlEnv env scrut case_bndr lvl
+ = extendLvlEnv env [TB case_bndr lvl]
+
+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 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') = extendIdSubst env v (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, _, id_env) new_subst bndr_pairs
+ = (float_lams,
+ 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_id env (v,v') = extendVarEnv env v ([v'], Var v')