[project @ 2005-01-31 13:25:33 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 a357f12..3327e8b 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -17,14 +17,13 @@ module CoreUnfold (
        Unfolding, UnfoldingGuidance,   -- Abstract types
 
        noUnfolding, mkTopUnfolding, mkUnfolding, mkCompulsoryUnfolding, seqUnfolding,
-       mkOtherCon, otherCons,
+       evaldUnfolding, mkOtherCon, otherCons,
        unfoldingTemplate, maybeUnfoldingTemplate,
        isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
        hasUnfolding, hasSomeUnfolding, neverUnfold,
 
        couldBeSmallEnoughToInline, 
        certainlyWillInline, 
-       okToUnfoldInHiFile,
 
        callSiteInline
     ) where
@@ -35,7 +34,7 @@ import CmdLineOpts    ( opt_UF_CreationThreshold,
                          opt_UF_UseThreshold,
                          opt_UF_FunAppDiscount,
                          opt_UF_KeenessFactor,
-                         opt_UF_DearOp, opt_UnfoldCasms,
+                         opt_UF_DearOp,
                          DynFlags, DynFlag(..), dopt
                        )
 import CoreSyn
@@ -43,13 +42,11 @@ import PprCore              ( pprCoreExpr )
 import OccurAnal       ( occurAnalyseGlobalExpr )
 import CoreUtils       ( exprIsValue, exprIsCheap, exprIsTrivial )
 import Id              ( Id, idType, isId,
-                         idUnfolding,
-                         isFCallId_maybe, globalIdDetails
+                         idUnfolding, globalIdDetails
                        )
 import DataCon         ( isUnboxedTupleCon )
-import Literal         ( isLitLitLit, litSize )
+import Literal         ( litSize )
 import PrimOp          ( primOpIsDupable, primOpOutOfLine )
-import ForeignCall     ( okToExposeFCall )
 import IdInfo          ( OccInfo(..), GlobalIdDetails(..) )
 import Type            ( isUnLiftedType )
 import PrelNames       ( hasKey, buildIdKey, augmentIdKey )
@@ -59,7 +56,7 @@ import Outputable
 import Util
 
 #if __GLASGOW_HASKELL__ >= 404
-import GlaExts         ( Int# )
+import GLAEXTS         ( Int# )
 #endif
 \end{code}
 
@@ -139,7 +136,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE expr
        | not inline -> UnfoldNever
                -- A big function with an INLINE pragma must
                -- have an UnfoldIfGoodArgs guidance
-       | inline     -> UnfoldIfGoodArgs n_val_binders
+       | otherwise  -> UnfoldIfGoodArgs n_val_binders
                                         (map (const 0) val_binders)
                                         max_inline_size 0
 
@@ -221,7 +218,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
       where
        rhs_size = foldr (addSize . size_up . snd) sizeZero pairs
 
-    size_up (Case (Var v) _ alts) 
+    size_up (Case (Var v) _ _ alts) 
        | v `elem` top_args             -- We are scrutinising an argument variable
        = 
 {-     I'm nuking this special case; BUT see the comment with case alternatives.
@@ -269,9 +266,9 @@ sizeExpr bOMB_OUT_SIZE top_args expr
                        -- The 1+ is a little discount for reduced allocation in the caller
          alts_size tot_size _ = tot_size
 
-
-    size_up (Case e _ alts) = nukeScrutDiscount (size_up e) `addSize` 
-                             foldr (addSize . size_up_alt) sizeZero alts
+-- gaw 2004
+    size_up (Case e _ _ alts) = nukeScrutDiscount (size_up e) `addSize` 
+                                foldr (addSize . 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
@@ -298,7 +295,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)
@@ -467,36 +464,6 @@ certainlyWillInline other
   = False
 \end{code}
 
-@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
-file to determine whether an unfolding candidate really should be unfolded.
-The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
-into interface files. 
-
-The reason for inlining expressions containing _casm_s into interface files
-is that these fragments of C are likely to mention functions/#defines that
-will be out-of-scope when inlined into another module. This is not an
-unfixable problem for the user (just need to -#include the approp. header
-file), but turning it off seems to the simplest thing to do.
-
-\begin{code}
-okToUnfoldInHiFile :: CoreExpr -> Bool
-okToUnfoldInHiFile e = opt_UnfoldCasms || go e
- where
-    -- Race over an expression looking for CCalls..
-    go (Var v)                = case isFCallId_maybe v of
-                                 Just fcall -> okToExposeFCall fcall
-                                 Nothing    -> True
-    go (Lit lit)             = not (isLitLitLit lit)
-    go (App fun arg)          = go fun && go arg
-    go (Lam _ body)           = go body
-    go (Let binds body)       = and (map go (body :rhssOfBind binds))
-    go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts)) &&
-                               not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
-    go (Note _ body)          = go body
-    go (Type _)                      = True
-\end{code}
-
-
 %************************************************************************
 %*                                                                     *
 \subsection{callSiteInline}