[project @ 1996-06-05 06:44:31 by partain]

[ghc-hetmet.git] / ghc / compiler / simplCore / SetLevels.lhs

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index b52c603..f4bdc82 100644 (file)
--- 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}