[project @ 1996-07-25 20:43:49 by partain]

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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index f046fa8..fa14e39 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -21,22 +21,24 @@ module SimplUtils (
        type_ok_for_let_to_case
     ) where
 
-import Ubiq{-uitous-}
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop)              -- paranoia checking
 
 import BinderInfo
 import CmdLineOpts     ( SimplifierSwitch(..) )
 import CoreSyn
-import CoreUtils       ( manifestlyWHNF )
+import CoreUnfold      ( SimpleUnfolding, mkFormSummary, FormSummary(..) )
 import Id              ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
                          getIdArity, GenId{-instance Eq-}
                        )
 import IdInfo          ( arityMaybe )
 import Maybes          ( maybeToBool )
-import PrelInfo                ( augmentId, buildId, realWorldStateTy )
+import PrelVals                ( augmentId, buildId )
 import PrimOp          ( primOpIsCheap )
 import SimplEnv
 import SimplMonad
-import Type            ( eqTy, isPrimType, maybeAppDataTyCon, getTyVar_maybe )
+import Type            ( eqTy, isPrimType, maybeAppDataTyConExpandingDicts, getTyVar_maybe )
+import TysWiredIn      ( realWorldStateTy )
 import TyVar           ( GenTyVar{-instance Eq-} )
 import Util            ( isIn, panic )
 
@@ -74,8 +76,11 @@ floatExposesHNF float_lets float_primops ok_to_dup rhs
     try (App (App (Var bld) _) _)        | bld == buildId   = True
     try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
 
-    try other = manifestlyWHNF other
-       {- but *not* necessarily "manifestlyBottom other"...
+    try other = case mkFormSummary other of
+                       VarForm   -> True
+                       ValueForm -> True
+                       other     -> False
+       {- but *not* necessarily "BottomForm"...
 
           We may want to float a let out of a let to expose WHNFs,
            but to do that to expose a "bottom" is a Bad Idea:
@@ -372,7 +377,7 @@ mkIdentityAlts rhs_ty
     returnSmpl (PrimAlts [] (BindDefault (binder, bad_occ_info) (Var binder)))
 
   | otherwise
-  = case (maybeAppDataTyCon rhs_ty) of
+  = case (maybeAppDataTyConExpandingDicts rhs_ty) of
        Just (tycon, ty_args, [data_con]) ->  -- algebraic type suitable for unpacking
            let
                inst_con_arg_tys = dataConArgTys data_con ty_args
@@ -405,7 +410,7 @@ simplIdWantsToBeINLINEd id env
 type_ok_for_let_to_case :: Type -> Bool
 
 type_ok_for_let_to_case ty
-  = case (maybeAppDataTyCon ty) of
+  = case (maybeAppDataTyConExpandingDicts ty) of
       Nothing                                   -> False
       Just (tycon, ty_args, [])                 -> False
       Just (tycon, ty_args, non_null_data_cons) -> True