[project @ 1998-03-09 17:26:31 by simonpj]

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

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index b6935c2..1c068f0 100644 (file)
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -10,46 +10,43 @@ We also let-ify many applications (notably case scrutinees), so they
 will have a fighting chance of being floated sensible.
 
 \begin{code}
-#include "HsVersions.h"
-
 module SetLevels (
        setLevels,
 
        Level(..), tOP_LEVEL,
 
        incMinorLvl, ltMajLvl, ltLvl, isTopLvl
--- not exported: , incMajorLvl, isTopMajLvl, unTopify
     ) where
 
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
 
 import AnnCoreSyn
 import CoreSyn
 
 import CoreUtils       ( coreExprType )
-import CoreUnfold      ( whnfOrBottom )
+import CoreUnfold      ( FormSummary, whnfOrBottom, mkFormSummary )
 import FreeVars                -- all of it
 import Id              ( idType, mkSysLocal, 
                          nullIdEnv, addOneToIdEnv, growIdEnvList,
                          unionManyIdSets, minusIdSet, mkIdSet,
-                         idSetToList,
-                         lookupIdEnv, SYN_IE(IdEnv)
+                         idSetToList, Id,
+                         lookupIdEnv, IdEnv
                        )
-import Pretty          ( ppPStr, ppBesides, ppChar, ppInt )
 import SrcLoc          ( noSrcLoc )
-import Type            ( isPrimType, mkTyVarTys, mkForAllTys )
-import TyVar           ( nullTyVarEnv, addOneToTyVarEnv,
+import Type            ( isUnpointedType, mkTyVarTys, mkForAllTys, tyVarsOfTypes, Type )
+import TyVar           ( emptyTyVarEnv, addToTyVarEnv,
                          growTyVarEnvList, lookupTyVarEnv,
-                         tyVarSetToList,
-                         SYN_IE(TyVarEnv),
-                         unionManyTyVarSets
+                         tyVarSetToList, 
+                         TyVarEnv, TyVar,
+                         unionManyTyVarSets, unionTyVarSets
                        )
 import UniqSupply      ( thenUs, returnUs, mapUs, mapAndUnzipUs,
-                         mapAndUnzip3Us, getUnique, SYN_IE(UniqSM),
+                         mapAndUnzip3Us, getUnique, UniqSM,
                          UniqSupply
                        )
-import Usage           ( SYN_IE(UVar) )
+import BasicTypes      ( Unused )
 import Util            ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic )
+import Outputable
 
 isLeakFreeType x y = False -- safe option; ToDo
 \end{code}
@@ -93,9 +90,9 @@ sub-expression so that it will indeed float. This context level starts
 at @Level 0 0@; it is never @Top@.
 
 \begin{code}
-type LevelledExpr  = GenCoreExpr    (Id, Level) Id TyVar UVar
-type LevelledArg   = GenCoreArg                        Id TyVar UVar
-type LevelledBind  = GenCoreBinding (Id, Level) Id TyVar UVar
+type LevelledExpr  = GenCoreExpr    (Id, Level) Id Unused
+type LevelledArg   = GenCoreArg                        Id Unused
+type LevelledBind  = GenCoreBinding (Id, Level) Id Unused
 
 type LevelEnvs = (IdEnv    Level, -- bind Ids to levels
                  TyVarEnv Level) -- bind type variables to levels
@@ -143,8 +140,8 @@ unTopify Top = Level 0 0
 unTopify lvl = lvl
 
 instance Outputable Level where
-  ppr sty Top            = ppPStr SLIT("<Top>")
-  ppr sty (Level maj min) = ppBesides [ ppChar '<', ppInt maj, ppChar ',', ppInt min, ppChar '>' ]
+  ppr Top            = ptext SLIT("<Top>")
+  ppr (Level maj min) = hcat [ char '<', int maj, char ',', int min, char '>' ]
 \end{code}
 
 %************************************************************************
@@ -172,7 +169,7 @@ setLevels binds us
        do_them bs       `thenLvl` \ lvld_binds ->
        returnLvl (lvld_bind ++ lvld_binds)
 
-initial_envs = (nullIdEnv, nullTyVarEnv)
+initial_envs = (nullIdEnv, emptyTyVarEnv)
 
 lvlTopBind (NonRec binder rhs)
   = lvlBind (Level 0 0) initial_envs (AnnNonRec binder (freeVars rhs))
@@ -191,7 +188,7 @@ lvlTopBind (Rec pairs)
 The binding stuff works for top level too.
 
 \begin{code}
-type CoreBindingWithFVs = AnnCoreBinding Id Id TyVar UVar FVInfo
+type CoreBindingWithFVs = AnnCoreBinding Id Id Unused FVInfo
 
 lvlBind :: Level
        -> LevelEnvs
@@ -293,10 +290,7 @@ lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
     returnLvl (Lam (TyBinder tyvar) body')
   where
     incd_lvl = incMinorLvl ctxt_lvl
-    new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
-
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
-  = panic "SetLevels.lvlExpr:AnnLam UsageBinder"
+    new_tenv = addToTyVarEnv tenv tyvar incd_lvl
 
 lvlExpr ctxt_lvl envs (_, AnnLet bind body)
   = lvlBind ctxt_lvl envs bind         `thenLvl` \ (binds', new_envs) ->
@@ -353,7 +347,7 @@ lvlMFE ::  Level            -- Level of innermost enclosing lambda/tylam
        -> LvlM LevelledExpr    -- Result expression
 
 lvlMFE ctxt_lvl envs@(venv,_) ann_expr
-  | isPrimType ty      -- Can't let-bind it
+  | isUnpointedType ty -- Can't let-bind it
   = lvlExpr ctxt_lvl envs ann_expr
 
   | otherwise          -- Not primitive type so could be let-bound
@@ -479,7 +473,7 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv)
 
     offending tyvar = ids_only_lvl `ltLvl` tyvarLevel tenv tyvar
 
-    manifestly_whnf = whnfOrBottom de_ann_expr
+    manifestly_whnf = whnfOrBottom (mkFormSummary de_ann_expr)
 
     maybe_unTopify Top | not (canFloatToTop (ty, expr)) = Level 0 0
     maybe_unTopify lvl                                  = lvl
@@ -632,7 +626,8 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
                        | rhs' <- rhss' -- mkCoLet* requires Core...
                        ]
 
-       poly_binds  = zipEqual "poly_binds" [(poly_var, ids_only_lvl) | poly_var <- poly_vars] 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)
@@ -653,6 +648,20 @@ decideRecFloatLevel ctxt_lvl envs@(venv, tenv) ids rhss
 
     fvs  = unionManyIdSets [freeVarsOf   rhs | rhs <- rhss] `minusIdSet` mkIdSet ids
     tfvs = unionManyTyVarSets [freeTyVarsOf rhs | rhs <- rhss]
+          `unionTyVarSets`
+          tyVarsOfTypes tys
+       -- Why the "tyVarsOfTypes" part?  Consider this:
+       --      /\a -> letrec x::a = x in E
+       -- Now, there are no explicit free type variables in the RHS of x,
+       -- but nevertheless "a" is free in its definition.  So we add in
+       -- the free tyvars of the types of the binders.
+       -- This actually happened in the defn of errorIO in IOBase.lhs:
+       --      errorIO (ST io) = case (errorIO# io) of
+       --                          _ -> bottom
+       --                        where
+       --                          bottom = bottom -- Never evaluated
+       -- I don't think this can every happen for non-recursive bindings.
+
     fv_list = idSetToList fvs
     tv_list = tyVarSetToList tfvs