Fix trac #2578

[ghc-hetmet.git] / compiler / iface / IfaceSyn.lhs

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 2e2967d..1db7822 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -28,7 +28,7 @@ module IfaceSyn (
 
 import IfaceType
 
-import NewDemand
+import Demand
 import Annotations
 import Class
 import NameSet 
@@ -202,7 +202,8 @@ data IfaceInfoItem
   = HsArity     Arity
   | HsStrictness StrictSig
   | HsInline     InlinePragma
-  | HsUnfold    IfaceUnfolding
+  | HsUnfold    Bool             -- True <=> isNonRuleLoopBreaker is true
+                IfaceUnfolding   -- See Note [Expose recursive functions] 
   | HsNoCafRefs
 
 -- NB: Specialisations and rules come in separately and are
@@ -210,11 +211,16 @@ data IfaceInfoItem
 
 data IfaceUnfolding 
   = IfCoreUnfold IfaceExpr
+  | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
+
   | IfInlineRule Arity 
-                 Bool          -- Sat/UnSat
+                 Bool          -- OK to inline even if *un*-saturated
+                Bool           -- OK to inline even if context is boring
                  IfaceExpr 
+
   | IfWrapper    Arity Name      -- NB: we need a Name (not just OccName) because the worker
                                  --     can simplify to a function in another module.
+
   | IfDFunUnfold [IfaceExpr]
 
 --------------------------------
@@ -256,6 +262,13 @@ data IfaceBinding
 data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
 \end{code}
 
+Note [Expose recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For supercompilation we want to put *all* unfoldings in the interface
+file, even for functions that are recursive (or big).  So we need to
+know when an unfolding belongs to a loop-breaker so that we can refrain
+from inlining it (except during supercompilation).
+
 Note [IdInfo on nested let-bindings]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Occasionally we want to preserve IdInfo on nested let bindings. The one
@@ -660,17 +673,19 @@ instance Outputable IfaceIdInfo where
   ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
 
 instance Outputable IfaceInfoItem where
-  ppr (HsUnfold unf)    = ptext (sLit "Unfolding:") <+> ppr unf
+  ppr (HsUnfold lb unf)  = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) 
+                           <> colon <+> ppr unf
   ppr (HsInline prag)    = ptext (sLit "Inline:") <+> ppr prag
   ppr (HsArity arity)    = ptext (sLit "Arity:") <+> int arity
   ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
   ppr HsNoCafRefs       = ptext (sLit "HasNoCafRefs")
 
 instance Outputable IfaceUnfolding where
+  ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
   ppr (IfCoreUnfold e)     = parens (ppr e)
-  ppr (IfInlineRule a b e) = ptext (sLit "InlineRule:")
-                             <+> parens (ptext (sLit "arity") <+> int a <+> ppr b) 
-                            <+> parens (ppr e)
+  ppr (IfInlineRule a uok bok e) = ptext (sLit "InlineRule")
+                                  <+> ppr (a,uok,bok) 
+                                 <+> parens (ppr e)
   ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
   ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas (pprIfaceExpr parens) ns)
 
@@ -786,14 +801,15 @@ freeNamesIfIdInfo NoInfo = emptyNameSet
 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
 
 freeNamesItem :: IfaceInfoItem -> NameSet
-freeNamesItem (HsUnfold u)     = freeNamesIfUnfold u
-freeNamesItem _                = emptyNameSet
+freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
+freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e)     = freeNamesIfExpr e
-freeNamesIfUnfold (IfInlineRule _ _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfWrapper _ v)      = unitNameSet v
-freeNamesIfUnfold (IfDFunUnfold vs)    = fnList freeNamesIfExpr vs
+freeNamesIfUnfold (IfCoreUnfold e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v
+freeNamesIfUnfold (IfDFunUnfold vs)      = fnList freeNamesIfExpr vs
 
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)     = unitNameSet v