X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=fa14e39a33b411975d2d42084af5e62c0fcf177a;hb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;hp=f046fa845a38b47c89b4d5a9bfb664ef8234bc9e;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index f046fa8..fa14e39 100644
--- 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