[project @ 1998-06-16 12:25:36 by sof]

New function: okToUnfoldInHiFile.

  - For values whose RHS have been deemed to be interface
    file unfolding candidates, do a last minute check to
    see whether the unfolding is really suitable.

    An unfolding is not suitable iff

       - contains a _casm_
       - contains a lit-lit

    The reason for not unfolding _casm_/lit-lits into
    interface files is that their C fragments are likely
    to mention #defines/functions that will be
    out-of-scope at an unfolding site. Turning off unfolding
    of such expressions avoid this unfortunate situation.

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index d06fd93..55b285b 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -23,6 +23,7 @@ module CoreUnfold (
 
        smallEnoughToInline, couldBeSmallEnoughToInline, 
        certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
+       okToUnfoldInHiFile,
 
        calcUnfoldingGuidance
     ) where
@@ -51,10 +52,10 @@ import CoreUtils    ( coreExprType )
 import Id              ( Id, idType, getIdArity,  isBottomingId, isDataCon,
                          idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
                          IdSet )
-import PrimOp          ( fragilePrimOp, primOpCanTriggerGC )
+import PrimOp          ( fragilePrimOp, primOpCanTriggerGC, PrimOp(..) )
 import IdInfo          ( ArityInfo(..), InlinePragInfo(..) )
 import Name            ( isExported )
-import Literal         ( isNoRepLit )
+import Literal         ( isNoRepLit, isLitLitLit )
 import TyCon           ( tyConFamilySize )
 import Type            ( splitAlgTyConApp_maybe )
 import Unique           ( Unique )
@@ -237,7 +238,6 @@ calcUnfoldingGuidance
        :: Int                  -- bomb out if size gets bigger than this
        -> CoreExpr             -- expression to look at
        -> UnfoldingGuidance
-
 calcUnfoldingGuidance bOMB_OUT_SIZE expr
   = case collectBinders expr of { (ty_binders, val_binders, body) ->
     case (sizeExpr bOMB_OUT_SIZE val_binders body) of
@@ -549,3 +549,51 @@ okToInline id whnf small binder_info
 #endif
   = isInlinableOcc whnf small binder_info
 \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 = go e
+ where
+    -- Race over an expression looking for CCalls..
+    go (Var _)   = True
+    go (Lit lit) = not (isLitLitLit lit)
+    go (Note _ body)  = go body
+    go (App fun arg)  = go fun
+    go (Con con args) = True
+    go (Prim op args) = okToUnfoldPrimOp op
+    go (Lam _ body) = go body
+    go (Let (NonRec binder rhs) body) = go rhs && go body
+    go (Let (Rec pairs) body) = and (map go (body:rhses))
+      where
+        rhses = [ rhs | (_, rhs) <- pairs ]
+    go (Case scrut alts) = and (map go (scrut:rhses))
+      where
+        rhses = getAltRhs alts
+
+        getAltRhs (PrimAlts alts deflt) =
+           let ls = map snd alts  in
+           case deflt of
+             NoDefault -> ls
+             BindDefault _ rhs -> rhs:ls
+        getAltRhs (AlgAlts alts deflt) =
+           let ls = map (\ (_,_,r) -> r) alts  in
+           case deflt of
+             NoDefault -> ls
+             BindDefault _ rhs -> rhs:ls
+
+    -- ok to unfold a PrimOp as long as it's not a _casm_
+    okToUnfoldPrimOp (CCallOp _ is_casm _ _ _) = not is_casm
+    okToUnfoldPrimOp _                         = True
+     
+\end{code}

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index cd818c1..57c82b7 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -41,7 +41,9 @@ import IdInfo         ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePr
                          bottomIsGuaranteed, workerExists, 
                        )
 import CoreSyn         ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
-import CoreUnfold      ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
+import CoreUnfold      ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding,
+                         okToUnfoldInHiFile
+                       )
 import FreeVars                ( exprFreeVars )
 import Name            ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName,
                          OccName, occNameString, nameOccName, nameString, isExported,
@@ -304,14 +306,15 @@ ifaceId get_idinfo needed_ids is_rec id rhs
 
     unfolding_is_ok
        = case inline_pragma of
-           IMustBeINLINEd       -> True
-           IWantToBeINLINEd     -> True
+           IMustBeINLINEd       -> definitely_ok_to_unfold
+           IWantToBeINLINEd     -> definitely_ok_to_unfold
            IDontWantToBeINLINEd -> False
            IMustNotBeINLINEd    -> False
            NoPragmaInfo         -> case guidance of
                                        UnfoldNever -> False    -- Too big
-                                       other       -> True
+                                       other       -> definitely_ok_to_unfold
 
+    definitely_ok_to_unfold =  okToUnfoldInHiFile rhs
     guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs
 
     ------------  Specialisations --------------