[commit: ghc] master: Tweak sizing heurstics for case expressions (see comments). (4177efa)

[Simon Marlow]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/4177efa79d0ebc45e1319caff1c000f5fb6cfdcf

>---------------------------------------------------------------

commit 4177efa79d0ebc45e1319caff1c000f5fb6cfdcf
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Tue May 24 13:14:17 2011 +0100

    Tweak sizing heurstics for case expressions (see comments).
    This improves the code generated for the examples in #4978, and
    appears to make very little difference to nofib.

>---------------------------------------------------------------

 compiler/coreSyn/CoreUnfold.lhs  |   46 ++++++++++++++++++++++++++++++-------
 compiler/prelude/ForeignCall.lhs |    5 +++-
 2 files changed, 41 insertions(+), 10 deletions(-)

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 5883013..da703ef 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -64,6 +64,8 @@ import Pair
 import FastTypes
 import FastString
 import Outputable
+import ForeignCall
+
 import Data.Maybe
 \end{code}
 
@@ -398,15 +400,41 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
 	  alts_size tot_size _ = tot_size
 
-    size_up (Case e _ _ alts) = size_up e  `addSizeNSD` 
-                                foldr (addAltSize . size_up_alt) sizeZero alts
-	  	-- We don't charge for the case itself
-		-- It's a strict thing, and the price of the call
-		-- is paid by scrut.  Also consider
-		--	case f x of DEFAULT -> e
-		-- This is just ';'!  Don't charge for it.
-		--
-		-- Moreover, we charge one per alternative.
+    size_up (Case e b _ alts) = size_up e  `addSizeNSD`
+                                foldr (addAltSize . size_up_alt) case_size alts
+      where
+          case_size
+           | is_inline_scrut e, not (lengthExceeds alts 1)  = sizeN (-1)
+           | otherwise = sizeZero
+                -- Normally we don't charge for the case itself, but
+                -- we charge one per alternative (see size_up_alt,
+                -- below) to account for the cost of the info table
+                -- and comparisons.
+                --
+                -- However, in certain cases (see is_inline_scrut
+                -- below), no code is generated for the case unless
+                -- there are multiple alts.  In these cases we
+                -- subtract one, making the first alt free.
+                -- e.g. case x# +# y# of _ -> ...   should cost 1
+                --      case touch# x# of _ -> ...  should cost 0
+                -- (see #4978)
+                --
+                -- I would like to not have the "not (lengthExceeds alts 1)"
+                -- condition above, but without that some programs got worse
+                -- (spectral/hartel/event and spectral/para).  I don't fully
+                -- understand why. (SDM 24/5/11)
+
+                -- unboxed variables, inline primops and unsafe foreign calls
+                -- are all "inline" things:
+          is_inline_scrut (Var v) = isUnLiftedType (idType v)
+          is_inline_scrut scrut
+              | (Var f, _) <- collectArgs scrut
+                = case idDetails f of
+                    FCallId fc  -> not (isSafeForeignCall fc)
+                    PrimOpId op -> not (primOpOutOfLine op)
+                    _other      -> False
+              | otherwise
+                = False
 
     ------------ 
     -- size_up_app is used when there's ONE OR MORE value args
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index a92cabd..87bb94a 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -13,7 +13,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module ForeignCall (
-	ForeignCall(..),
+        ForeignCall(..), isSafeForeignCall,
 	Safety(..), playSafe, playInterruptible,
 
 	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
@@ -43,6 +43,9 @@ newtype ForeignCall = CCall CCallSpec
   deriving Eq
   {-! derive: Binary !-}
 
+isSafeForeignCall :: ForeignCall -> Bool
+isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
+
 -- We may need more clues to distinguish foreign calls
 -- but this simple printer will do for now
 instance Outputable ForeignCall where