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.

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 5883013..da703ef 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -64,6 +64,8 @@ import Pair
 import FastTypes
 import FastString
 import Outputable
 import FastTypes
 import FastString
 import Outputable

+import ForeignCall
+

 import Data.Maybe
 \end{code}
 
 import Data.Maybe
 \end{code}
 

@@ -398,15 +400,41 @@ sizeExpr bOMB_OUT_SIZE top_args expr
 
          alts_size tot_size _ = tot_size
 
 
          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
 
     ------------ 
     -- 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 (file)
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -13,7 +13,7 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module ForeignCall (
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module ForeignCall (

-       ForeignCall(..),
+        ForeignCall(..), isSafeForeignCall,

        Safety(..), playSafe, playInterruptible,
 
        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
        Safety(..), playSafe, playInterruptible,
 
        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,

@@ -43,6 +43,9 @@ newtype ForeignCall = CCall CCallSpec
   deriving Eq
   {-! derive: Binary !-}
 
   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
 -- We may need more clues to distinguish foreign calls
 -- but this simple printer will do for now
 instance Outputable ForeignCall where