X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=2eedd331314a2de3dcefedeebc2348006ea10e7e;hb=18896fa2b06844407fd1e0d3f85cd3db97a96ff4;hp=d74c278e6081e5ddc8a950834c239996616d1662;hpb=5cdc2f1dcea1425ab4a842fde708cf55b17333c5;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index d74c278..2eedd33 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -25,7 +25,7 @@ module CoreUtils (
 
 	-- * Properties of expressions
 	exprType, coreAltType, coreAltsType,
-	exprIsDupable, exprIsTrivial, 
+	exprIsDupable, exprIsTrivial, exprIsBottom,
         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
 	exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
 	rhsIsStatic, isCheapApp, isExpandableApp,
@@ -424,6 +424,25 @@ exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 exprIsTrivial _                = False
 \end{code}
 
+exprIsBottom is a very cheap and cheerful function; it may return
+False for bottoming expressions, but it never costs much to ask.
+See also CoreArity.exprBotStrictness_maybe, but that's a bit more 
+expensive.
+
+\begin{code}
+exprIsBottom :: CoreExpr -> Bool
+exprIsBottom e 
+  = go 0 e
+  where
+    go n (Var v) = isBottomingId v &&  n >= idArity v 
+    go n (App e a) | isTypeArg a = go n e 
+                   | otherwise   = go (n+1) e 
+    go n (Note _ e) 		 = go n e     
+    go n (Cast e _) 		 = go n e
+    go n (Let _ e)  		 = go n e
+    go _ _          		 = False
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -631,6 +650,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, 
@@ -656,9 +680,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
 
@@ -718,7 +747,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 
@@ -726,7 +754,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)