[project @ 2003-06-30 14:27:51 by simonpj]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreUnfold.lhs

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index fe7b8f2..46f2ba2 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -56,9 +56,10 @@ import PrelNames     ( hasKey, buildIdKey, augmentIdKey )
 import Bag
 import FastTypes
 import Outputable
+import Util
 
 #if __GLASGOW_HASKELL__ >= 404
-import GlaExts         ( fromInt )
+import GLAEXTS         ( Int# )
 #endif
 \end{code}
 
@@ -132,7 +133,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
        --   but no more.
 
     in
-    case (sizeExpr bOMB_OUT_SIZE val_binders body) of
+    case (sizeExpr (iUnbox bOMB_OUT_SIZE) val_binders body) of
 
       TooBig 
        | not inline -> UnfoldNever
@@ -176,7 +177,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
 \end{code}
 
 \begin{code}
-sizeExpr :: Int            -- Bomb out if it gets bigger than this
+sizeExpr :: Int#           -- Bomb out if it gets bigger than this
         -> [Id]            -- Arguments; we're interested in which of these
                            -- get case'd
         -> CoreExpr
@@ -297,7 +298,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
       | fun `hasKey` augmentIdKey = augmentSize
       | otherwise 
       = case globalIdDetails fun of
-         DataConId dc -> conSizeN dc (valArgCount args)
+         DataConWorkId dc -> conSizeN dc (valArgCount args)
 
          FCallId fc   -> sizeN opt_UF_DearOp
          PrimOpId op  -> primOpSize op (valArgCount args)
@@ -335,35 +336,32 @@ sizeExpr bOMB_OUT_SIZE top_args expr
        -- These addSize things have to be here because
        -- I don't want to give them bOMB_OUT_SIZE as an argument
 
-    addSizeN TooBig          _      = TooBig
-    addSizeN (SizeIs n xs d) m
-      | n_tot ># (iUnbox bOMB_OUT_SIZE) = TooBig
-      | otherwise                  = SizeIs n_tot xs d
-      where
-       n_tot = n +# iUnbox m
+    addSizeN TooBig          _  = TooBig
+    addSizeN (SizeIs n xs d) m         = mkSizeIs bOMB_OUT_SIZE (n +# iUnbox m) xs d
     
-    addSize TooBig _ = TooBig
-    addSize _ TooBig = TooBig
-    addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)
-      | n_tot ># (iUnbox bOMB_OUT_SIZE) = TooBig
-      | otherwise             = SizeIs n_tot xys d_tot
-      where
-       n_tot = n1 +# n2
-       d_tot = d1 +# d2
-       xys   = xs `unionBags` ys
+    addSize TooBig           _                 = TooBig
+    addSize _                TooBig            = TooBig
+    addSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) 
+       = mkSizeIs bOMB_OUT_SIZE (n1 +# n2) (xs `unionBags` ys) (d1 +# d2)
 \end{code}
 
 Code for manipulating sizes
 
 \begin{code}
-
 data ExprSize = TooBig
              | SizeIs FastInt          -- Size found
                       (Bag (Id,Int))   -- Arguments cased herein, and discount for each such
                       FastInt          -- Size to subtract if result is scrutinised 
                                        -- by a case expression
 
-
+-- subtract the discount before deciding whether to bale out. eg. we
+-- want to inline a large constructor application into a selector:
+--     tup = (a_1, ..., a_99)
+--     x = case tup of ...
+--
+mkSizeIs max n xs d | (n -# d) ># max = TooBig
+                   | otherwise       = SizeIs n xs d
+ 
 maxSize TooBig         _                                 = TooBig
 maxSize _              TooBig                            = TooBig
 maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
@@ -461,16 +459,12 @@ couldBeSmallEnoughToInline threshold rhs = case calcUnfoldingGuidance threshold
                                                UnfoldNever -> False
                                                other       -> True
 
-certainlyWillInline :: Id -> Bool
-       -- Sees if the Id is pretty certain to inline   
-certainlyWillInline v
-  = case idUnfolding v of
-
-       CoreUnfolding _ _ _ is_cheap g@(UnfoldIfGoodArgs n_vals _ size _)
-          ->    is_cheap
-             && size - (n_vals +1) <= opt_UF_UseThreshold
-
-       other -> False
+certainlyWillInline :: Unfolding -> Bool
+  -- Sees if the unfolding is pretty certain to inline 
+certainlyWillInline (CoreUnfolding _ _ _ is_cheap (UnfoldIfGoodArgs n_vals _ size _))
+  = is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold
+certainlyWillInline other
+  = False
 \end{code}
 
 @okToUnfoldInHifile@ is used when emitting unfolding info into an interface
@@ -585,6 +579,11 @@ callSiteInline dflags active_inline inline_call occ id arg_infos interesting_con
                -- then if the context is totally uninteresting (not applied, not scrutinised)
                -- there is no point in substituting because it might just increase allocation,
                -- by allocating the function itself many times
+               -- Note [Jan 2002]: this comment looks out of date.  The actual code
+               -- doesn't inline *ever* in an uninteresting context.  Why not?  I
+               -- think it's just because we don't want to inline top-level constants
+               -- into uninteresting contexts, lest we (for example) re-nest top-level
+               -- literal lists.
                --
                -- Note: there used to be a '&& not top_level' in the guard above,
                --       but that stopped us inlining top-level functions used only once,
@@ -593,7 +592,7 @@ callSiteInline dflags active_inline inline_call occ id arg_infos interesting_con
                        -- If (not in_lam) && one_br then PreInlineUnconditionally
                        -- should have caught it, shouldn't it?  Unless it's a top
                        -- level thing.
-           not (null arg_infos) || interesting_cont
+           notNull arg_infos || interesting_cont
 
          | otherwise
          = case guidance of
@@ -671,7 +670,7 @@ computeDiscount n_vals_wanted arg_discounts res_discount arg_infos result_used
                        -- Discount of 1 for each arg supplied, because the 
                        -- result replaces the call
     round (opt_UF_KeenessFactor * 
-          fromInt (arg_discount + result_discount))
+          fromIntegral (arg_discount + result_discount))
   where
     arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos)