[project @ 1996-07-25 20:43:49 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..ca79733 100644 (file)
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -21,36 +21,37 @@ module SetLevels (
 -- not exported: , incMajorLvl, isTopMajLvl, unTopify
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
 
 import AnnCoreSyn
 import CoreSyn
 
-import CoreUtils       ( coreExprType, manifestlyWHNF, manifestlyBottom )
+import CoreUtils       ( coreExprType )
+import CoreUnfold      ( whnfOrBottom )
 import FreeVars                -- all of it
 import Id              ( idType, mkSysLocal, toplevelishId,
                          nullIdEnv, addOneToIdEnv, growIdEnvList,
                          unionManyIdSets, minusIdSet, mkIdSet,
                          idSetToList,
-                         lookupIdEnv, IdEnv(..)
+                         lookupIdEnv, SYN_IE(IdEnv)
                        )
 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,
-                         TyVarEnv(..),
+                         SYN_IE(TyVarEnv),
                          unionManyTyVarSets
                        )
 import UniqSupply      ( thenUs, returnUs, mapUs, mapAndUnzipUs,
-                         mapAndUnzip3Us, getUnique, UniqSM(..)
+                         mapAndUnzip3Us, getUnique, SYN_IE(UniqSM),
+                         UniqSupply
                        )
-import Usage           ( UVar(..) )
-import Util            ( mapAccumL, zipWithEqual, panic, assertPanic )
+import Usage           ( SYN_IE(UVar) )
+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 +216,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 +265,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')
@@ -403,7 +408,7 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 -- any harm, and not floating it may pin something important.  For
 -- example
 --
---     x = let v = Nil
+--     x = let v = []
 --             w = 1:v
 --         in ...
 --
@@ -462,7 +467,7 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 
     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 
-    manifestly_whnf = manifestlyWHNF de_ann_expr || manifestlyBottom de_ann_expr
+    manifestly_whnf = whnfOrBottom de_ann_expr
 
     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
     maybe_unTopify lvl                                  = lvl
@@ -514,7 +519,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 +570,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 +607,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 +653,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}
@@ -670,7 +673,7 @@ isWorthFloating alreadyLetBound expr
   | otherwise       =  -- No point in adding a fresh let-binding for a WHNF, because
                        -- floating it isn't beneficial enough.
                      isWorthFloatingExpr expr &&
-                     not (manifestlyWHNF expr || manifestlyBottom expr)
+                     not (whnfOrBottom expr)
 ********** -}
 
 isWorthFloatingExpr :: CoreExpr -> Bool
@@ -688,7 +691,7 @@ canFloatToTop :: (Type, CoreExprWithFVs) -> Bool
 canFloatToTop (ty, (FVInfo _ _ (LeakFree _), expr)) = True
 canFloatToTop (ty, (FVInfo _ _ MightLeak,    expr)) = isLeakFreeType [] ty
 
-valSuggestsLeakFree expr = manifestlyWHNF expr || manifestlyBottom expr
+valSuggestsLeakFree expr = whnfOrBottom expr
 \end{code}