import CoreSyn
-import CmdLineOpts ( FloatOutSwitches(..) )
+import DynFlags ( FloatOutSwitches(..) )
import CoreUtils ( exprType, exprIsTrivial, exprIsCheap, mkPiTypes )
import CoreFVs -- all of it
-import Subst
-import Id ( Id, idType, mkSysLocalUnencoded,
- isOneShotLambda, zapDemandIdInfo,
+import CoreSubst ( Subst, emptySubst, extendInScope, extendIdSubst,
+ cloneIdBndr, cloneRecIdBndrs )
+import Id ( Id, idType, mkSysLocal, isOneShotLambda,
+ zapDemandIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
-import IdInfo ( workerExists, vanillaIdInfo, )
+import IdInfo ( workerExists, vanillaIdInfo, isEmptySpecInfo )
import Var ( Var )
import VarSet
import VarEnv
import Name ( getOccName )
-import OccName ( occNameUserString )
+import OccName ( occNameString )
import Type ( isUnLiftedType, Type )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply
lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' ->
returnLvl (App fun' arg')
where
- lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun
+-- gaw 2004
+ lvl_fun (_, AnnCase _ _ _ _) = lvlMFE True ctxt_lvl env fun
lvl_fun other = lvlExpr ctxt_lvl env fun
-- We don't do MFE on partial applications generally,
-- but we do if the function is big and hairy, like a case
lvlExpr ctxt_lvl new_env body `thenLvl` \ body' ->
returnLvl (Let bind' body')
-lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr alts)
+lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts)
= lvlMFE True ctxt_lvl env expr `thenLvl` \ expr' ->
let
alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl
in
mapLvl (lvl_alt alts_env) alts `thenLvl` \ alts' ->
- returnLvl (Case expr' (TB case_bndr incd_lvl) alts')
+ returnLvl (Case expr' (TB case_bndr incd_lvl) ty alts')
where
incd_lvl = incMinorLvl ctxt_lvl
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)),
+ extendIdSubst subst case_bndr (Var scrut_var),
extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var))
extendCaseBndrLvlEnv env scrut case_bndr lvl
foldl add_id id_env bndr_pairs)
where
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_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
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
zap v | isId v = WARN( workerExists (idWorkerInfo v) ||
- not (isEmptyCoreRules (idSpecialisation v)),
+ not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
| otherwise = v
in
returnLvl (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs)
where
- mk_poly_bndr bndr uniq = mkSysLocalUnencoded (mkFastString str) uniq poly_ty
+ mk_poly_bndr bndr uniq = mkSysLocal (mkFastString str) uniq poly_ty
where
- str = "poly_" ++ occNameUserString (getOccName bndr)
+ str = "poly_" ++ occNameString (getOccName bndr)
poly_ty = mkPiTypes abs_vars (idType bndr)
-> LvlM Id
newLvlVar str vars body_ty
= getUniqueUs `thenLvl` \ uniq ->
- returnUs (mkSysLocalUnencoded (mkFastString str) uniq (mkPiTypes vars body_ty))
+ returnUs (mkSysLocal (mkFastString str) uniq (mkPiTypes vars body_ty))
-- The deeply tiresome thing is that we have to apply the substitution
-- to the rules inside each Id. Grr. But it matters.
= ASSERT( isId v )
getUs `thenLvl` \ us ->
let
- (subst', v1) = substAndCloneId subst us v
+ (subst', v1) = cloneIdBndr subst us v
v2 = zap_demand ctxt_lvl dest_lvl v1
env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)]
in
= ASSERT( all isId vs )
getUs `thenLvl` \ us ->
let
- (subst', vs1) = substAndCloneRecIds subst us vs
+ (subst', vs1) = cloneRecIdBndrs subst us vs
vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1
env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2)
in