X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=61bfd2e5831dac001485a65a9cb633b30cafbf4a;hb=d056dfedcf9c7e5e58031ad5948c480f9cdca16f;hp=72977be81ddf845ed8bbecc8556144db47a9b820;hpb=a3bab0506498db41853543558c52a4fda0d183af;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 72977be..61bfd2e 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -25,7 +25,8 @@ module CoreUtils (
 
 	-- * Properties of expressions
 	exprType, coreAltType, coreAltsType,
-	exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
+	exprIsDupable, exprIsTrivial, 
+        exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
 	exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
 	rhsIsStatic, isCheapApp, isExpandableApp,
 
@@ -513,8 +514,8 @@ exprIsCheap = exprIsCheap' isCheapApp
 exprIsExpandable :: CoreExpr -> Bool
 exprIsExpandable = exprIsCheap' isExpandableApp	-- See Note [CONLIKE pragma] in BasicTypes
 
-
-exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool
+type CheapAppFun = Id -> Int -> Bool
+exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
 exprIsCheap' _          (Lit _)   = True
 exprIsCheap' _          (Type _)  = True
 exprIsCheap' _          (Var _)   = True
@@ -548,7 +549,7 @@ exprIsCheap' good_app other_expr 	-- Applications and variables
     go (Var _) [] = True	-- Just a type application of a variable
 				-- (f t1 t2 t3) counts as WHNF
     go (Var f) args
- 	= case idDetails f of
+        = case idDetails f of
 		RecSelId {}  	    	     -> go_sel args
 		ClassOpId {} 	    	     -> go_sel args
 		PrimOpId op  	    	     -> go_primop op args
@@ -582,12 +583,12 @@ exprIsCheap' good_app other_expr 	-- Applications and variables
   		-- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
   		--	there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
 
-isCheapApp :: Id -> Int -> Bool
+isCheapApp :: CheapAppFun
 isCheapApp fn n_val_args
   = isDataConWorkId fn 
   || n_val_args < idArity fn
 
-isExpandableApp :: Id -> Int -> Bool
+isExpandableApp :: CheapAppFun
 isExpandableApp fn n_val_args
   =  isConLikeId fn
   || n_val_args < idArity fn
@@ -630,6 +631,11 @@ it's applied only to dictionaries.
 --
 --  * Safe /not/ to evaluate even if normal order would do so
 --
+-- It is usually called on arguments of unlifted type, but not always
+-- In particular, Simplify.rebuildCase calls it on lifted types
+-- when a 'case' is a plain 'seq'. See the example in 
+-- Note [exprOkForSpeculation: case expressions] below
+--
 -- Precisely, it returns @True@ iff:
 --
 --  * The expression guarantees to terminate, 
@@ -655,9 +661,14 @@ it's applied only to dictionaries.
 exprOkForSpeculation :: CoreExpr -> Bool
 exprOkForSpeculation (Lit _)     = True
 exprOkForSpeculation (Type _)    = True
-    -- Tick boxes are *not* suitable for speculation
-exprOkForSpeculation (Var v)     = isUnLiftedType (idType v)
-				 && not (isTickBoxOp v)
+
+exprOkForSpeculation (Var v)     
+  | isTickBoxOp v = False     -- Tick boxes are *not* suitable for speculation
+  | otherwise     =  isUnLiftedType (idType v)	-- c.f. the Var case of exprIsHNF
+    		  || isDataConWorkId v	    	-- Nullary constructors
+    		  || idArity v > 0   		-- Functions
+    		  || isEvaldUnfolding (idUnfolding v)	-- Let-bound values
+
 exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
 exprOkForSpeculation (Cast e _)  = exprOkForSpeculation e
 
@@ -686,6 +697,9 @@ exprOkForSpeculation other_expr
 		-- Often there is a literal divisor, and this 
 		-- can get rid of a thunk in an inner looop
 
+      | DataToTagOp <- op      -- See Note [dataToTag speculation]
+      = True
+
       | otherwise
       = primOpOkForSpeculation op && 
 	all exprOkForSpeculation args
@@ -714,7 +728,6 @@ isDivOp _                = False
 
 Note [exprOkForSpeculation: case expressions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
-
 It's always sound for exprOkForSpeculation to return False, and we
 don't want it to take too long, so it bales out on complicated-looking
 terms.  Notably lets, which can be stacked very deeply; and in any 
@@ -722,7 +735,7 @@ case the argument of exprOkForSpeculation is usually in a strict context,
 so any lets will have been floated away.
 
 However, we keep going on case-expressions.  An example like this one
-showed up in DPH code:
+showed up in DPH code (Trac #3717):
     foo :: Int -> Int
     foo 0 = 0
     foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
@@ -741,6 +754,27 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
 
 The inner case is redundant, and should be nuked.
 
+Note [dataToTag speculation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Is this OK?
+   f x = let v::Int# = dataToTag# x
+         in ...
+We say "yes", even though 'x' may not be evaluated.  Reasons
+
+  * dataToTag#'s strictness means that its argument often will be
+    evaluated, but FloatOut makes that temporarily untrue
+         case x of y -> let v = dataToTag# y in ...
+    -->
+         case x of y -> let v = dataToTag# x in ...
+    Note that we look at 'x' instead of 'y' (this is to improve
+    floating in FloatOut).  So Lint complains.    
+ 
+    Moreover, it really *might* improve floating to let the
+    v-binding float out
+         
+  * CorePrep makes sure dataToTag#'s argument is evaluated, just
+    before code gen.  Until then, it's not guaranteed
+
 
 %************************************************************************
 %*									*