Implement INLINABLE pragma

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

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index c844d62..c8348cb 100644 (file)
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -105,7 +105,7 @@ data IfaceDecl
                                                 -- beyond .NET
                   ifExtName :: Maybe FastString }
 
-data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
+data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
        -- Nothing    => no default method
        -- Just False => ordinary polymorphic default method
        -- Just True  => generic default method
@@ -133,7 +133,7 @@ data IfaceConDecl
        ifConCtxt    :: IfaceContext,           -- Non-stupid context
        ifConArgTys  :: [IfaceType],            -- Arg types
        ifConFields  :: [OccName],              -- ...ditto... (field labels)
-       ifConStricts :: [StrictnessMark]}       -- Empty (meaning all lazy),
+       ifConStricts :: [HsBang]}               -- Empty (meaning all lazy),
                                                -- or 1-1 corresp with arg tys
 
 data IfaceInst 
@@ -210,7 +210,8 @@ data IfaceInfoItem
 -- only later attached to the Id.  Partial reason: some are orphans.
 
 data IfaceUnfolding 
-  = IfCoreUnfold IfaceExpr
+  = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding
+
   | IfCompulsory IfaceExpr     -- Only used for default methods, in fact
 
   | IfInlineRule Arity 
@@ -524,10 +525,13 @@ pprIfaceConDecl tc
         if is_infix then ptext (sLit "Infix") else empty,
         if has_wrap then ptext (sLit "HasWrapper") else empty,
         ppUnless (null strs) $
-           nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
+           nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
         ppUnless (null fields) $
            nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
   where
+    ppr_bang HsNoBang = char '_'       -- Want to see these
+    ppr_bang bang     = ppr bang
+        
     main_payload = ppr name <+> dcolon <+> 
                   pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
 
@@ -685,11 +689,13 @@ instance Outputable IfaceInfoItem where
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
-  ppr (IfCoreUnfold e)     = parens (ppr e)
+  ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty) <+> parens (ppr e)
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
                                        pprParendIfaceExpr e]
-  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
-  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:") <+> brackets (pprWithCommas pprParendIfaceExpr ns)
+  ppr (IfWrapper a wkr)    = ptext (sLit "Worker:") <+> ppr wkr
+                             <+> parens (ptext (sLit "arity") <+> int a)
+  ppr (IfDFunUnfold ns)    = ptext (sLit "DFun:")
+                             <+> brackets (pprWithCommas pprParendIfaceExpr ns)
 
 
 -- -----------------------------------------------------------------------------
@@ -807,7 +813,7 @@ freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
 freeNamesItem _              = emptyNameSet
 
 freeNamesIfUnfold :: IfaceUnfolding -> NameSet
-freeNamesIfUnfold (IfCoreUnfold e)       = freeNamesIfExpr e
+freeNamesIfUnfold (IfCoreUnfold _ e)     = freeNamesIfExpr e
 freeNamesIfUnfold (IfCompulsory e)       = freeNamesIfExpr e
 freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
 freeNamesIfUnfold (IfWrapper _ v)        = unitNameSet v