X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=2e2967d89b236789ae7e001a92aed45072c7b5c5;hp=129ebd0719a11bc5dcef66f16f552270805098c4;hb=72462499b891d5779c19f3bda03f96e24f9554ae;hpb=ad23a496a860063ab01025051d9c9baf45725a61

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 129ebd0..2e2967d 100644
--- 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