The Big INLINE Patch: totally reorganise way that INLINE pragmas work

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

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 129ebd0..2e2967d 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -9,7 +9,8 @@ module IfaceSyn (
 
        IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
        IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
-       IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..),
+       IfaceBinding(..), IfaceConAlt(..), 
+       IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
        IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
        IfaceInst(..), IfaceFamInst(..),
 
@@ -201,15 +202,21 @@ data IfaceInfoItem
   = HsArity     Arity
   | HsStrictness StrictSig
   | HsInline     InlinePragma
-  | HsUnfold    IfaceExpr
+  | HsUnfold    IfaceUnfolding
   | HsNoCafRefs
-  | HsWorker    Name Arity     -- Worker, if any see IdInfo.WorkerInfo
-                                       -- for why we want arity here.
-       -- NB: we need IfaceExtName (not just OccName) because the worker
-       --     can simplify to a function in another module.
+
 -- NB: Specialisations and rules come in separately and are
 -- only later attached to the Id.  Partial reason: some are orphans.
 
+data IfaceUnfolding 
+  = IfCoreUnfold IfaceExpr
+  | IfInlineRule Arity 
+                 Bool          -- Sat/UnSat
+                 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]
+
 --------------------------------
 data IfaceExpr
   = IfaceLcl   FastString
@@ -227,7 +234,6 @@ data IfaceExpr
   | IfaceTick   Module Int
 
 data IfaceNote = IfaceSCC CostCentre
-              | IfaceInlineMe
                | IfaceCoreNote String
 
 type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
@@ -504,10 +510,10 @@ pprIfaceConDecl tc
   = sep [main_payload,
         if is_infix then ptext (sLit "Infix") else empty,
         if has_wrap then ptext (sLit "HasWrapper") else empty,
-        if null strs then empty 
-             else nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
-        if null fields then empty
-             else nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+        ppUnless (null strs) $
+           nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
+        ppUnless (null fields) $
+           nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
   where
     main_payload = ppr name <+> dcolon <+> 
                   pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
@@ -632,7 +638,6 @@ pprIfaceApp fun                    args = sep (pprIfaceExpr parens fun : args)
 ------------------
 instance Outputable IfaceNote where
     ppr (IfaceSCC cc)     = pprCostCentreCore cc
-    ppr IfaceInlineMe     = ptext (sLit "__inline_me")
     ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
 
 
@@ -652,16 +657,22 @@ instance Outputable IfaceIdDetails where
 
 instance Outputable IfaceIdInfo where
   ppr NoInfo       = empty
-  ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
+  ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
 
 instance Outputable IfaceInfoItem where
-  ppr (HsUnfold unf)    = ptext (sLit "Unfolding:") <+>
-                                       parens (pprIfaceExpr noParens unf)
+  ppr (HsUnfold unf)    = ptext (sLit "Unfolding:") <+> 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")
-  ppr (HsWorker w a)    = ptext (sLit "Worker:") <+> ppr w <+> int a
+
+instance Outputable IfaceUnfolding where
+  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 (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)
 
 
 -- -----------------------------------------------------------------------------
@@ -775,10 +786,15 @@ freeNamesIfIdInfo NoInfo = emptyNameSet
 freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
 
 freeNamesItem :: IfaceInfoItem -> NameSet
-freeNamesItem (HsUnfold u)     = freeNamesIfExpr u
-freeNamesItem (HsWorker wkr _) = unitNameSet wkr
+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
+
 freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)     = unitNameSet v
 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty