X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSetLevels.lhs;h=f4bdc82638a2ece4b441e55857689e1f0af9b884;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=b52c6035b6a613cf997b75ad1d3e3acfb73e4895;hpb=0596517a9b4b2b32e5d375a986351102ac4540fc;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index b52c603..f4bdc82 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -21,7 +21,7 @@ module SetLevels (
 -- not exported: , incMajorLvl, isTopMajLvl, unTopify
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import AnnCoreSyn
 import CoreSyn
@@ -36,7 +36,7 @@ import Id		( idType, mkSysLocal, toplevelishId,
 			)
 import Pretty		( ppStr, ppBesides, ppChar, ppInt )
 import SrcLoc		( mkUnknownSrcLoc )
-import Type		( isPrimType, mkTyVarTys )
+import Type		( isPrimType, mkTyVarTys, mkForAllTys )
 import TyVar		( nullTyVarEnv, addOneToTyVarEnv,
 			  growTyVarEnvList, lookupTyVarEnv,
 			  tyVarSetToList,
@@ -47,10 +47,9 @@ import UniqSupply	( thenUs, returnUs, mapUs, mapAndUnzipUs,
 			  mapAndUnzip3Us, getUnique, UniqSM(..)
 			)
 import Usage		( UVar(..) )
-import Util		( mapAccumL, zipWithEqual, panic, assertPanic )
+import Util		( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
 
-quantifyTy     = panic "SetLevels.quantifyTy (ToDo)"
-isLeakFreeType = panic "SetLevels.isLeakFreeType (ToDo)"
+isLeakFreeType x y = False -- safe option; ToDo
 \end{code}
 
 %************************************************************************
@@ -215,7 +214,7 @@ lvlBind ctxt_lvl envs@(venv, tenv) (AnnRec pairs)
 	binders_w_lvls = binders `zip` repeat final_lvl
 	new_envs       = (growIdEnvList venv binders_w_lvls, tenv)
     in
-    returnLvl (extra_binds ++ [Rec (binders_w_lvls `zip` rhss')], new_envs)
+    returnLvl (extra_binds ++ [Rec (zipEqual "lvlBind" binders_w_lvls rhss')], new_envs)
   where
     (binders,rhss) = unzip pairs
 \end{code}
@@ -264,6 +263,10 @@ lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
   = lvlExpr ctxt_lvl envs expr 		`thenLvl` \ expr' ->
     returnLvl (SCC cc expr')
 
+lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
+  = lvlExpr ctxt_lvl envs expr 		`thenLvl` \ expr' ->
+    returnLvl (Coerce c ty expr')
+
 lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
   = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
     returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
@@ -514,7 +517,7 @@ abstractWrtTyVars offending_tyvars ty (venv,tenv) lvl expr
     in
     returnLvl final_expr
   where
-    poly_ty 	    = snd (quantifyTy offending_tyvars ty)
+    poly_ty = mkForAllTys offending_tyvars ty
 
 	-- These defns are just like those in the TyLam case of lvlExpr
     (incd_lvl, tyvar_lvls) = mapAccumL next (unTopify lvl) offending_tyvars
@@ -565,11 +568,11 @@ type lambdas.
 \begin{code}
 decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
   | isTopMajLvl ids_only_lvl   &&		-- Destination = top
-    not (all canFloatToTop (tys `zip` rhss))	-- Some can't float to top
+    not (all canFloatToTop (zipEqual "decideRec" tys rhss)) -- Some can't float to top
   = 	-- Pin it here
     let
 	ids_w_lvls = ids `zip` repeat ctxt_lvl
-	new_envs       = (growIdEnvList venv ids_w_lvls, tenv)
+	new_envs   = (growIdEnvList venv ids_w_lvls, tenv)
     in
     mapLvl (lvlExpr ctxt_lvl new_envs) rhss	`thenLvl` \ rhss' ->
     returnLvl (ctxt_lvl, [], rhss')
@@ -602,20 +605,20 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
     mapLvl (lvlExpr incd_lvl new_envs) rhss	`thenLvl` \ rhss' ->
     mapLvl newLvlVar poly_tys			`thenLvl` \ poly_vars ->
     let
-	ids_w_poly_vars = ids `zip` poly_vars
+	ids_w_poly_vars = zipEqual "decideRec2" ids poly_vars
 
 		-- The "d_rhss" are the right-hand sides of "D" and "D'"
 		-- in the documentation above
 	d_rhss = [ mkTyApp (Var poly_var) offending_tyvar_tys | poly_var <- poly_vars]
 
 		-- "local_binds" are "D'" in the documentation above
-	local_binds = zipWithEqual NonRec ids_w_incd_lvl d_rhss
+	local_binds = zipWithEqual "SetLevels" NonRec ids_w_incd_lvl d_rhss
 
 	poly_var_rhss = [ mkTyLam offending_tyvars (foldr Let rhs' local_binds)
 			| rhs' <- rhss'	-- mkCoLet* requires Core...
 			]
 
-	poly_binds  = [(poly_var, ids_only_lvl) | poly_var <- poly_vars] `zip` poly_var_rhss
+	poly_binds  = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] poly_var_rhss
 
     in
     returnLvl (ctxt_lvl, [Rec poly_binds], d_rhss)
@@ -648,9 +651,7 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 	| otherwise 			       = []
 
     offending_tyvar_tys = mkTyVarTys offending_tyvars
-    poly_tys 	        = [ snd (quantifyTy offending_tyvars ty)
-			  | ty <- tys
-			  ]
+    poly_tys = map (mkForAllTys offending_tyvars) tys
 
     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 \end{code}