X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=b679cf68c1b6d29e00b35af4bd73f780369271b7;hb=82d2bddc26026ed01c67dc5c69359b0cde624c54;hp=c33d1f5ee67015e0702218ed9632fc673cfdbd95;hpb=1fa3580c54985d73178d1d396b897176a57cd7f3;p=ghc-hetmet.git

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index c33d1f5..b679cf6 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -9,8 +9,9 @@ module IfaceSyn (
 
 	IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
 	IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
-	IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
-	IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
+	IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..),
+	IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+	IfaceInst(..), IfaceFamInst(..),
 
 	-- Misc
         ifaceDeclSubBndrs, visibleIfConDecls,
@@ -27,12 +28,14 @@ module IfaceSyn (
 import IfaceType
 
 import NewDemand
+import Annotations
 import Class
 import NameSet 
 import Name
 import CostCentre
 import Literal
 import ForeignCall
+import Serialized
 import BasicTypes
 import Outputable
 import FastString
@@ -53,9 +56,10 @@ infixl 3 &&&
 
 \begin{code}
 data IfaceDecl 
-  = IfaceId { ifName   :: OccName,
-	      ifType   :: IfaceType, 
-	      ifIdInfo :: IfaceIdInfo }
+  = IfaceId { ifName   	  :: OccName,
+	      ifType   	  :: IfaceType, 
+	      ifIdDetails :: IfaceIdDetails,
+	      ifIdInfo    :: IfaceIdInfo }
 
   | IfaceData { ifName       :: OccName,	-- Type constructor
 		ifTyVars     :: [IfaceTvBndr],	-- Type variables
@@ -123,6 +127,7 @@ visibleIfConDecls (IfNewTyCon c)   = [c]
 data IfaceConDecl 
   = IfCon {
 	ifConOcc     :: OccName,   		-- Constructor name
+	ifConWrapper :: Bool,			-- True <=> has a wrapper
 	ifConInfix   :: Bool,			-- True <=> declared infix
 	ifConUnivTvs :: [IfaceTvBndr],		-- Universal tyvars
 	ifConExTvs   :: [IfaceTvBndr],		-- Existential tyvars
@@ -163,6 +168,24 @@ data IfaceRule
 	ifRuleOrph   :: Maybe OccName	-- Just like IfaceInst
     }
 
+data IfaceAnnotation
+  = IfaceAnnotation {
+        ifAnnotatedTarget :: IfaceAnnTarget,
+        ifAnnotatedValue :: Serialized
+  }
+
+type IfaceAnnTarget = AnnTarget OccName
+
+-- We only serialise the IdDetails of top-level Ids, and even then
+-- we only need a very limited selection.  Notably, none of the
+-- implicit ones are needed here, becuase they are not put it
+-- interface files
+
+data IfaceIdDetails
+  = IfVanillaId
+  | IfRecSelId Bool
+  | IfDFunId
+
 data IfaceIdInfo
   = NoInfo			-- When writing interface file without -O
   | HasInfo [IfaceInfoItem]	-- Has info, and here it is
@@ -336,28 +359,22 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}  = []
 -- Newtype
 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
                               ifCons = IfNewTyCon (
-                                        IfCon { ifConOcc = con_occ, 
-                                                ifConFields = fields
-					          }),
+                                        IfCon { ifConOcc = con_occ }),
                               ifFamInst = famInst}) 
-  = -- fields (names of selectors)
-    fields ++ 
-    -- implicit coerion and (possibly) family instance coercion
+  =   -- implicit coerion and (possibly) family instance coercion
     (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
-    -- data constructor and worker (newtypes don't have a wrapper)
+      -- data constructor and worker (newtypes don't have a wrapper)
     [con_occ, mkDataConWorkerOcc con_occ]
 
 
 ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
 			      ifCons = IfDataTyCon cons, 
 			      ifFamInst = famInst})
-  = -- fields (names of selectors) 
-    nub (concatMap ifConFields cons) 	-- Eliminate duplicate fields
-    -- (possibly) family instance coercion;
-    -- there is no implicit coercion for non-newtypes
-    ++ famInstCo famInst tc_occ
-    -- for each data constructor in order,
-    --    data constructor, worker, and (possibly) wrapper
+  =   -- (possibly) family instance coercion;
+      -- there is no implicit coercion for non-newtypes
+    famInstCo famInst tc_occ
+      -- for each data constructor in order,
+      --    data constructor, worker, and (possibly) wrapper
     ++ concatMap dc_occs cons
   where
     dc_occs con_decl
@@ -367,11 +384,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
 	  con_occ  = ifConOcc con_decl			-- DataCon namespace
 	  wrap_occ = mkDataConWrapperOcc con_occ	-- Id namespace
 	  work_occ = mkDataConWorkerOcc con_occ		-- Id namespace
-	  strs     = ifConStricts con_decl
-	  has_wrapper = any isMarkedStrict strs	-- See MkId.mkDataConIds (sigh)
-			|| not (null . ifConEqSpec $ con_decl)
-			|| isJust famInst
-		-- ToDo: may miss strictness in existential dicts
+	  has_wrapper = ifConWrapper con_decl		-- This is the reason for
+	  	      		     			-- having the ifConWrapper field!
 
 ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, 
 			       ifSigs = sigs, ifATs = ats })
@@ -417,8 +431,10 @@ instance Outputable IfaceDecl where
   ppr = pprIfaceDecl
 
 pprIfaceDecl :: IfaceDecl -> SDoc
-pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
+pprIfaceDecl (IfaceId {ifName = var, ifType = ty, 
+                       ifIdDetails = details, ifIdInfo = info})
   = sep [ ppr var <+> dcolon <+> ppr ty, 
+    	  nest 2 (ppr details),
 	  nest 2 (ppr info) ]
 
 pprIfaceDecl (IfaceForeign {ifName = tycon})
@@ -484,12 +500,13 @@ pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
 
 pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
 pprIfaceConDecl tc
-	(IfCon { ifConOcc = name, ifConInfix = is_infix, 
+	(IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
 		 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, 
 		 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, 
 		 ifConStricts = strs, ifConFields = fields })
   = 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
@@ -630,6 +647,12 @@ instance Outputable IfaceConAlt where
     -- IfaceTupleAlt is handled by the case-alternative printer
 
 ------------------
+instance Outputable IfaceIdDetails where
+  ppr IfVanillaId    = empty
+  ppr (IfRecSelId b) = ptext (sLit "RecSel")
+      		       <> if b then ptext (sLit "<naughty>") else empty
+  ppr IfDFunId       = ptext (sLit "DFunId")
+
 instance Outputable IfaceIdInfo where
   ppr NoInfo       = empty
   ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
@@ -655,7 +678,7 @@ instance Outputable IfaceInfoItem where
 -- fingerprinting the instance, so DFuns are not dependencies.
 
 freeNamesIfDecl :: IfaceDecl -> NameSet
-freeNamesIfDecl (IfaceId _s t i) = 
+freeNamesIfDecl (IfaceId _s t _d i) = 
   freeNamesIfType t &&&
   freeNamesIfIdInfo i
 freeNamesIfDecl IfaceForeign{} =