[project @ 2001-07-23 23:26:14 by ken]

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

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 102d8bc..6853b96 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -42,14 +42,15 @@ import CoreSyn
 import PprCore         ( pprCoreExpr )
 import OccurAnal       ( occurAnalyseGlobalExpr )
 import CoreUtils       ( exprIsValue, exprIsCheap, exprIsTrivial )
-import Id              ( Id, idType, idFlavour, isId,
+import Id              ( Id, idType, isId,
                          idSpecialisation, idInlinePragma, idUnfolding,
-                         isPrimOpId_maybe
+                         isFCallId_maybe, globalIdDetails
                        )
 import VarSet
-import Literal         ( isLitLitLit, litIsDupable )
-import PrimOp          ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
-import IdInfo          ( InlinePragInfo(..), OccInfo(..), IdFlavour(..),
+import Literal         ( isLitLitLit, litSize )
+import PrimOp          ( primOpIsDupable, primOpOutOfLine )
+import ForeignCall     ( okToExposeFCall )
+import IdInfo          ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
                          isNeverInlinePrag
                        )
 import Type            ( isUnLiftedType )
@@ -188,13 +189,20 @@ sizeExpr bOMB_OUT_SIZE top_args expr
     size_up (Type t)         = sizeZero        -- Types cost nothing
     size_up (Var v)           = sizeOne
 
-    size_up (Note _ body)     = size_up body   -- Notes cost nothing
+    size_up (Note InlineMe body) = sizeOne     -- Inline notes make it look very small
+       -- This can be important.  If you have an instance decl like this:
+       --      instance Foo a => Foo [a] where
+       --         {-# INLINE op1, op2 #-}
+       --         op1 = ...
+       --         op2 = ...
+       -- then we'll get a dfun which is a pair of two INLINE lambdas
+
+    size_up (Note _        body) = size_up body        -- Other notes cost nothing
 
     size_up (App fun (Type t)) = size_up fun
     size_up (App fun arg)      = size_up_app fun [arg]
 
-    size_up (Lit lit) | litIsDupable lit = sizeOne
-                     | otherwise        = sizeN opt_UF_DearOp  -- For lack of anything better
+    size_up (Lit lit)         = sizeN (litSize lit)
 
     size_up (Lam b e) | isId b    = lamScrutDiscount (size_up e `addSizeN` 1)
                      | otherwise = size_up e
@@ -289,9 +297,10 @@ sizeExpr bOMB_OUT_SIZE top_args expr
       | fun `hasKey` buildIdKey   = buildSize
       | fun `hasKey` augmentIdKey = augmentSize
       | otherwise 
-      = case idFlavour fun of
+      = case globalIdDetails fun of
          DataConId dc -> conSizeN (valArgCount args)
 
+         FCallId fc   -> sizeN opt_UF_DearOp
          PrimOpId op  -> primOpSize op (valArgCount args)
                          -- foldr addSize (primOpSize op) (map arg_discount args)
                          -- At one time I tried giving an arg-discount if a primop 
@@ -363,7 +372,6 @@ maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 ># n2  = s1
 
 sizeZero       = SizeIs (_ILIT 0) emptyBag (_ILIT 0)
 sizeOne        = SizeIs (_ILIT 1) emptyBag (_ILIT 0)
-sizeTwo        = SizeIs (_ILIT 2) emptyBag (_ILIT 0)
 sizeN n        = SizeIs (iUnbox n) emptyBag (_ILIT 0)
 conSizeN n      = SizeIs (_ILIT 1) emptyBag (iUnbox n +# _ILIT 1)
        -- Treat constructors as size 1; we are keen to expose them
@@ -471,9 +479,9 @@ okToUnfoldInHiFile :: CoreExpr -> Bool
 okToUnfoldInHiFile e = opt_UnfoldCasms || go e
  where
     -- Race over an expression looking for CCalls..
-    go (Var v)                = case isPrimOpId_maybe v of
-                                 Just op -> okToUnfoldPrimOp op
-                                 Nothing -> True
+    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
@@ -482,10 +490,6 @@ okToUnfoldInHiFile e = opt_UnfoldCasms || go e
                                not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
     go (Note _ body)          = go body
     go (Type _)                      = True
-
-    -- ok to unfold a PrimOp as long as it's not a _casm_
-    okToUnfoldPrimOp (CCallOp ccall) = not (ccallIsCasm ccall)
-    okToUnfoldPrimOp _               = True
 \end{code}
 
 
@@ -572,7 +576,9 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont
                -- Note: there used to be a '&& not top_level' in the guard above,
                --       but that stopped us inlining top-level functions used only once,
                --       which is stupid
-         = not in_lam || not (null arg_infos) || interesting_cont
+         = WARN( not in_lam, ppr id )  -- If (not in_lam) && one_br then PreInlineUnconditionally
+                                       -- should have caught it, shouldn't it?
+           not (null arg_infos) || interesting_cont
 
          | otherwise
          = case guidance of
@@ -615,7 +621,6 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont
                                                 arg_infos really_interesting_cont
                
     in    
-#ifdef DEBUG
     if dopt Opt_D_dump_inlinings dflags then
        pprTrace "Considering inlining"
                 (ppr id <+> vcat [text "black listed:" <+> ppr black_listed,
@@ -631,7 +636,6 @@ callSiteInline dflags black_listed inline_call occ id arg_infos interesting_cont
                                   else empty])
                  result
     else
-#endif
     result
     }