X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=d53bf5627d99638a48f0f07e57eb846b4e0dc65a;hb=65691f95b3727c277a24ec5f0d5a4058c9a681e2;hp=88d0f3dd779f6a767991e7f0feb8b119b66095af;hpb=36d22a1cb608e8572776ab6d402fd0c1a9287dc5;p=ghc-hetmet.git

diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs
index 88d0f3d..d53bf56 100644
--- a/ghc/compiler/basicTypes/IdInfo.lhs
+++ b/ghc/compiler/basicTypes/IdInfo.lhs
@@ -63,7 +63,8 @@ module IdInfo (
 	occInfo, setOccInfo, 
 
 	-- Specialisation
-	specInfo, setSpecInfo,
+	SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, 
+	specInfoFreeVars, specInfoRules, seqSpecInfo,
 
 	-- CAF info
 	CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
@@ -79,6 +80,7 @@ import CoreSyn
 import Class		( Class )
 import PrimOp	 	( PrimOp )
 import Var              ( Id )
+import VarSet		( VarSet, emptyVarSet, seqVarSet )
 import BasicTypes	( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
 			  InsideLam, insideLam, notInsideLam, 
 			  OneBranch, oneBranch, notOneBranch,
@@ -229,14 +231,19 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported
 data GlobalIdDetails
   = VanillaGlobal		-- Imported from elsewhere, a default method Id.
 
-  | RecordSelId TyCon FieldLabel  -- The Id for a record selector
+  | RecordSelId                 -- The Id for a record selector
+    { sel_tycon   :: TyCon
+    , sel_label   :: FieldLabel
+    , sel_naughty :: Bool       -- True <=> naughty
+    }				-- See Note [Naughty record selectors]
+				-- with MkId.mkRecordSelectorId
 
   | DataConWorkId DataCon	-- The Id for a data constructor *worker*
   | DataConWrapId DataCon	-- The Id for a data constructor *wrapper*
 				-- [the only reasons we need to know is so that
-				--  a) we can  suppress printing a definition in the interface file
-				--  b) when typechecking a pattern we can get from the
-				--     Id back to the data con]
+				--  a) to support isImplicitId
+				--  b) when desugaring a RecordCon we can get 
+				--     from the Id back to the data con]
 
   | ClassOpId Class		-- An operation of a class
 
@@ -255,7 +262,7 @@ instance Outputable GlobalIdDetails where
     ppr (ClassOpId _)     = ptext SLIT("[ClassOp]")
     ppr (PrimOpId _)      = ptext SLIT("[PrimOp]")
     ppr (FCallId _)       = ptext SLIT("[ForeignCall]")
-    ppr (RecordSelId _ _) = ptext SLIT("[RecSel]")
+    ppr (RecordSelId {})  = ptext SLIT("[RecSel]")
 \end{code}
 
 
@@ -282,13 +289,20 @@ case.  KSW 1999-04).
 data IdInfo
   = IdInfo {
 	arityInfo 	:: !ArityInfo,		-- Its arity
-	specInfo 	:: CoreRules,		-- Specialisations of this function which exist
+	specInfo 	:: SpecInfo,		-- Specialisations of this function which exist
 #ifdef OLD_STRICTNESS
 	cprInfo 	:: CprInfo,             -- Function always constructs a product result
 	demandInfo 	:: Demand.Demand,	-- Whether or not it is definitely demanded
 	strictnessInfo	:: StrictnessInfo,	-- Strictness properties
 #endif
         workerInfo      :: WorkerInfo,          -- Pointer to Worker Function
+						-- Within one module this is irrelevant; the 
+						-- inlining of a worker is handled via the Unfolding
+						-- WorkerInfo is used *only* to indicate the form of
+						-- the RHS, so that interface files don't actually 
+						-- need to contain the RHS; it can be derived from
+						-- the strictness info
+
 	unfoldingInfo	:: Unfolding,		-- Its unfolding
 	cafInfo		:: CafInfo,		-- CAF info
         lbvarInfo	:: LBVarInfo,		-- Info about a lambda-bound variable
@@ -310,7 +324,7 @@ seqIdInfo (IdInfo {}) = ()
 
 megaSeqIdInfo :: IdInfo -> ()
 megaSeqIdInfo info
-  = seqRules (specInfo info)			`seq`
+  = seqSpecInfo (specInfo info)			`seq`
     seqWorker (workerInfo info)			`seq`
 
 -- Omitting this improves runtimes a little, presumably because
@@ -378,7 +392,7 @@ vanillaIdInfo
 	    demandInfo		= wwLazy,
 	    strictnessInfo	= NoStrictnessInfo,
 #endif
-	    specInfo		= emptyCoreRules,
+	    specInfo		= emptySpecInfo,
 	    workerInfo		= NoWorker,
 	    unfoldingInfo	= noUnfolding,
 	    lbvarInfo		= NoLBVarInfo,
@@ -433,6 +447,36 @@ type InlinePragInfo = Activation
 	--
 	-- If there was an INLINE pragma, then as a separate matter, the
 	-- RHS will have been made to look small with a CoreSyn Inline Note
+
+	-- The default InlinePragInfo is AlwaysActive, so the info serves
+	-- entirely as a way to inhibit inlining until we want it
+\end{code}
+
+
+%************************************************************************
+%*									*
+	SpecInfo
+%*									*
+%************************************************************************
+
+\begin{code}
+-- CoreRules is used only in an idSpecialisation (move to IdInfo?)
+data SpecInfo 
+  = SpecInfo [CoreRule] VarSet	-- Locally-defined free vars of RHSs
+
+emptySpecInfo :: SpecInfo
+emptySpecInfo = SpecInfo [] emptyVarSet
+
+isEmptySpecInfo :: SpecInfo -> Bool
+isEmptySpecInfo (SpecInfo rs _) = null rs
+
+specInfoFreeVars :: SpecInfo -> VarSet
+specInfoFreeVars (SpecInfo _ fvs) = fvs
+
+specInfoRules :: SpecInfo -> [CoreRule]
+specInfoRules (SpecInfo rules _) = rules
+
+seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
 \end{code}
 
 
@@ -635,12 +679,12 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand})
   where
 	-- The "unsafe" occ info is the ones that say I'm not in a lambda
 	-- because that might not be true for an unsaturated lambda
-    is_safe_occ (OneOcc in_lam once) = in_lam
-    is_safe_occ other		     = True
+    is_safe_occ (OneOcc in_lam _ _) = in_lam
+    is_safe_occ other		    = True
 
     safe_occ = case occ of
-		 OneOcc _ once -> OneOcc insideLam once
-		 other	       -> occ
+		 OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt
+		 other	       	       -> occ
 
     is_safe_dmd Nothing    = True
     is_safe_dmd (Just dmd) = not (isStrictDmd dmd)