X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=f8ab29dcd593189f77eb18929143305d51ae4b5a;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=2d95727e35637c33141f954014bb514a9867c3ba;hpb=59c796f8e77325d35f29ddd3e724bfa780466d40;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 2d95727..f8ab29d 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -55,20 +55,21 @@ module SetLevels (
 
 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
@@ -274,7 +275,8 @@ lvlExpr ctxt_lvl env (_, AnnApp fun arg)
     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
@@ -331,13 +333,13 @@ lvlExpr ctxt_lvl env (_, AnnLet bind body)
     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
 
@@ -680,7 +682,7 @@ extendLvlEnv (float_lams, lvl_env, subst, id_env) prs
 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
@@ -693,7 +695,7 @@ extendPolyLvlEnv dest_lvl (float_lams, lvl_env, subst, id_env) abs_vars bndr_pai
      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
@@ -771,7 +773,7 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v
 	-- 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
@@ -794,9 +796,9 @@ newPolyBndrs dest_lvl env abs_vars bndrs
     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)
 	
 
@@ -805,7 +807,7 @@ newLvlVar :: String
 	  -> 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.
@@ -817,7 +819,7 @@ cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
   = 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
@@ -830,7 +832,7 @@ cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
   = 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