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

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 61bfd2e..70e1db7 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -25,13 +25,14 @@ module CoreUtils (
 
 	-- * Properties of expressions
 	exprType, coreAltType, coreAltsType,
-	exprIsDupable, exprIsTrivial, 
+	exprIsDupable, exprIsTrivial, exprIsBottom,
         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
 	exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
 	rhsIsStatic, isCheapApp, isExpandableApp,
 
 	-- * Expression and bindings size
 	coreBindsSize, exprSize,
+        CoreStats(..), coreBindsStats, 
 
 	-- * Hashing
 	hashExpr,
@@ -69,7 +70,6 @@ import CostCentre
 import Unique
 import Outputable
 import TysPrim
-import PrelNames( absentErrorIdKey )
 import FastString
 import Maybes
 import Util
@@ -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}
+
 
 %************************************************************************
 %*									*
@@ -446,22 +465,27 @@ Note [exprIsDupable]
 
 \begin{code}
 exprIsDupable :: CoreExpr -> Bool
-exprIsDupable (Type _)   = True
-exprIsDupable (Var _)    = True
-exprIsDupable (Lit lit)  = litIsDupable lit
-exprIsDupable (Note _ e) = exprIsDupable e
-exprIsDupable (Cast e _) = exprIsDupable e
-exprIsDupable expr
-  = go expr 0
+exprIsDupable e
+  = isJust (go dupAppSize e)
   where
-    go (Var _)   _      = True
-    go (App f a) n_args =  n_args < dupAppSize
-			&& exprIsDupable a
-			&& go f (n_args+1)
-    go _         _      = False
+    go :: Int -> CoreExpr -> Maybe Int
+    go n (Type {}) = Just n
+    go n (Var {})  = decrement n
+    go n (Note _ e) = go n e
+    go n (Cast e _) = go n e
+    go n (App f a) | Just n' <- go n a = go n' f
+    go n (Lit lit) | litIsDupable lit = decrement n
+    go _ _ = Nothing
+
+    decrement :: Int -> Maybe Int
+    decrement 0 = Nothing
+    decrement n = Just (n-1)
 
 dupAppSize :: Int
-dupAppSize = 4		-- Size of application we are prepared to duplicate
+dupAppSize = 8	 -- Size of term we are prepared to duplicate
+	         -- This is *just* big enough to make test MethSharing
+		 -- inline enough join points.  Really it should be
+		 -- smaller, and could be if we fixed Trac #4960.
 \end{code}
 
 %************************************************************************
@@ -543,6 +567,7 @@ exprIsCheap' good_app other_expr 	-- Applications and variables
   = go other_expr []
   where
 	-- Accumulate value arguments, then decide
+    go (Cast e _) val_args                 = go e val_args
     go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
 			  | otherwise      = go f val_args
 
@@ -678,10 +703,7 @@ exprOkForSpeculation (Case e _ _ alts)
 
 exprOkForSpeculation other_expr
   = case collectArgs other_expr of
-	(Var f, args) | f `hasKey` absentErrorIdKey	-- Note [Absent error Id]
-                      -> all exprOkForSpeculation args  --    in WwLib
-                      | otherwise 
-                      -> spec_ok (idDetails f) args
+	(Var f, args) -> spec_ok (idDetails f) args
         _             -> False
  
   where
@@ -1099,6 +1121,7 @@ coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 exprSize :: CoreExpr -> Int
 -- ^ A measure of the size of the expressions, strictly greater than 0
 -- It also forces the expression pretty drastically as a side effect
+-- Counts *leaves*, not internal nodes. Types and coercions are not counted.
 exprSize (Var v)         = v `seq` 1
 exprSize (Lit lit)       = lit `seq` 1
 exprSize (App f a)       = exprSize f + exprSize a
@@ -1133,6 +1156,62 @@ altSize :: CoreAlt -> Int
 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 \end{code}
 
+\begin{code}
+data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
+
+plusCS :: CoreStats -> CoreStats -> CoreStats
+plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 })
+       (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 })
+  = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 }
+  
+zeroCS, oneTM :: CoreStats
+zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 }
+oneTM  = zeroCS { cs_tm = 1 }
+
+sumCS :: (a -> CoreStats) -> [a] -> CoreStats
+sumCS f = foldr (plusCS . f) zeroCS 
+ 
+coreBindsStats :: [CoreBind] -> CoreStats
+coreBindsStats = sumCS bindStats
+
+bindStats :: CoreBind -> CoreStats
+bindStats (NonRec v r) = bindingStats v r
+bindStats (Rec prs)    = sumCS (\(v,r) -> bindingStats v r) prs
+
+bindingStats :: Var -> CoreExpr -> CoreStats
+bindingStats v r = bndrStats v `plusCS` exprStats r
+
+bndrStats :: Var -> CoreStats
+bndrStats v = oneTM `plusCS` tyStats (varType v)
+
+exprStats :: CoreExpr -> CoreStats
+exprStats (Var {})        = oneTM
+exprStats (Lit {})        = oneTM
+exprStats (App f (Type t))= tyCoStats (exprType f) t
+exprStats (App f a)       = exprStats f `plusCS` exprStats a 
+exprStats (Lam b e)       = bndrStats b `plusCS` exprStats e 
+exprStats (Let b e)       = bindStats b `plusCS` exprStats e 
+exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
+exprStats (Cast e co)     = coStats co `plusCS` exprStats e
+exprStats (Note _ e)      = exprStats e
+exprStats (Type ty)       = zeroCS { cs_ty = typeSize ty }
+	  -- Ugh (might be a co)
+
+altStats :: CoreAlt -> CoreStats
+altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
+
+tyCoStats :: Type -> Type -> CoreStats
+tyCoStats fun_ty arg
+  = case splitForAllTy_maybe fun_ty of
+      Just (tv,_) | isCoVar tv -> coStats arg
+      _                        -> tyStats arg
+
+tyStats :: Type -> CoreStats
+tyStats ty = zeroCS { cs_ty = typeSize ty }
+
+coStats :: Coercion -> CoreStats
+coStats co = zeroCS { cs_co = typeSize co }
+\end{code}
 
 %************************************************************************
 %*									*