From: sof <unknown>
Date: Tue, 16 Jun 1998 12:25:39 +0000 (+0000)
Subject: [project @ 1998-06-16 12:25:36 by sof]
X-Git-Tag: Approx_2487_patches~571
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1ca8c2c729e6c224090307fc7e9c42e302a2097a;p=ghc-hetmet.git

[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
--- 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
--- 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 --------------