X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FIdInfo.lhs;h=dbbaeacb490bec227658165a7aa79c0b88efd3bb;hb=601c7b4c12196950683c27f1cc796e40ac6fc15e;hp=d53bf5627d99638a48f0f07e57eb846b4e0dc65a;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs
index d53bf56..dbbaeac 100644
--- a/compiler/basicTypes/IdInfo.lhs
+++ b/compiler/basicTypes/IdInfo.lhs
@@ -1,4 +1,5 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
 \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@}
@@ -15,7 +16,7 @@ module IdInfo (
 	seqIdInfo, megaSeqIdInfo,
 
 	-- Zapping
-	zapLamInfo, zapDemandInfo,
+	zapLamInfo, zapDemandInfo, zapFragileInfo,
 
 	-- Arity
 	ArityInfo,
@@ -64,42 +65,42 @@ module IdInfo (
 
 	-- Specialisation
 	SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, 
-	specInfoFreeVars, specInfoRules, seqSpecInfo,
+	specInfoFreeVars, specInfoRules, seqSpecInfo, setSpecInfoHead,
 
 	-- CAF info
 	CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
 
         -- Lambda-bound variable info
-        LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo
+        LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo,
+
+        -- Tick-box info
+        TickBoxOp(..), TickBoxId,
     ) where
 
 #include "HsVersions.h"
 
-
 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,
-			  Arity,
-			  Activation(..)
-			)
-import DataCon		( DataCon )
-import TyCon		( TyCon, FieldLabel )
-import ForeignCall	( ForeignCall )
+import Class
+import PrimOp
+import Name
+import Var
+import VarSet
+import BasicTypes
+import DataCon
+import TyCon
+import ForeignCall
 import NewDemand
 import Outputable	
-import Maybe		( isJust )
+import Module
+import Pretty (Doc)
+
+import Data.Maybe
 
 #ifdef OLD_STRICTNESS
-import Name		( Name )
-import Demand		hiding( Demand, seqDemand )
+import Demand
 import qualified Demand
-import Util		( listLengthCmp )
-import List		( replicate )
+import Util
+import Data.List
 #endif
 
 -- infixl so you can say (id `set` a `set` b)
@@ -130,8 +131,8 @@ infixl 	1 `setSpecInfo`,
 To be removed later
 
 \begin{code}
--- setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
 -- Set old and new strictness info
+setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
 setAllStrictnessInfo info Nothing
   = info { newStrictnessInfo = Nothing
 #ifdef OLD_STRICTNESS
@@ -148,9 +149,11 @@ setAllStrictnessInfo info (Just sig)
 #endif
          }
 
+seqNewStrictnessInfo :: Maybe StrictSig -> ()
 seqNewStrictnessInfo Nothing = ()
 seqNewStrictnessInfo (Just ty) = seqStrictSig ty
 
+pprNewStrictness :: Maybe StrictSig -> PprStyle -> Doc
 pprNewStrictness Nothing = empty
 pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig
 
@@ -212,6 +215,7 @@ oldDemand (Call _)         = WwStrict
 
 
 \begin{code}
+seqNewDemandInfo :: Maybe Demand -> ()
 seqNewDemandInfo Nothing    = ()
 seqNewDemandInfo (Just dmd) = seqDemand dmd
 \end{code}
@@ -219,7 +223,7 @@ seqNewDemandInfo (Just dmd) = seqDemand dmd
 
 %************************************************************************
 %*									*
-\subsection{GlobalIdDetails
+\subsection{GlobalIdDetails}
 %*									*
 %************************************************************************
 
@@ -232,7 +236,8 @@ data GlobalIdDetails
   = VanillaGlobal		-- Imported from elsewhere, a default method Id.
 
   | RecordSelId                 -- The Id for a record selector
-    { sel_tycon   :: TyCon
+    { sel_tycon   :: TyCon	-- For a data type family, this is the *instance* TyCon
+				--	not the family TyCon
     , sel_label   :: FieldLabel
     , sel_naughty :: Bool       -- True <=> naughty
     }				-- See Note [Naughty record selectors]
@@ -250,8 +255,11 @@ data GlobalIdDetails
   | PrimOpId PrimOp		-- The Id for a primitive operator
   | FCallId ForeignCall		-- The Id for a foreign call
 
+  | TickBoxOpId TickBoxOp	-- The Id for a tick box (both traditional and binary)
+
   | NotGlobalId			-- Used as a convenient extra return value from globalIdDetails
     
+notGlobalId :: GlobalIdDetails
 notGlobalId = NotGlobalId
 
 instance Outputable GlobalIdDetails where
@@ -262,6 +270,7 @@ instance Outputable GlobalIdDetails where
     ppr (ClassOpId _)     = ptext SLIT("[ClassOp]")
     ppr (PrimOpId _)      = ptext SLIT("[PrimOp]")
     ppr (FCallId _)       = ptext SLIT("[ForeignCall]")
+    ppr (TickBoxOpId _)   = ptext SLIT("[TickBoxOp]")
     ppr (RecordSelId {})  = ptext SLIT("[RecSel]")
 \end{code}
 
@@ -348,19 +357,25 @@ megaSeqIdInfo info
 Setters
 
 \begin{code}
+setWorkerInfo :: IdInfo -> WorkerInfo -> IdInfo
 setWorkerInfo     info wk = wk `seq` info { workerInfo = wk }
+setSpecInfo :: IdInfo -> SpecInfo -> IdInfo
 setSpecInfo 	  info sp = sp `seq` info { specInfo = sp }
+setInlinePragInfo :: IdInfo -> InlinePragInfo -> IdInfo
 setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
+setOccInfo :: IdInfo -> OccInfo -> IdInfo
 setOccInfo	  info oc = oc `seq` info { occInfo = oc }
 #ifdef OLD_STRICTNESS
 setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
 #endif
 	-- Try to avoid spack leaks by seq'ing
 
+setUnfoldingInfoLazily :: IdInfo -> Unfolding -> IdInfo
 setUnfoldingInfoLazily info uf 	-- Lazy variant to avoid looking at the
   =				-- unfolding of an imported Id unless necessary
     info { unfoldingInfo = uf }	-- (In this case the demand-zapping is redundant.)
 
+setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo
 setUnfoldingInfo info uf 
 	-- We do *not* seq on the unfolding info, For some reason, doing so 
 	-- actually increases residency significantly. 
@@ -371,12 +386,17 @@ setDemandInfo	  info dd = info { demandInfo = dd }
 setCprInfo        info cp = info { cprInfo = cp }
 #endif
 
+setArityInfo :: IdInfo -> ArityInfo -> IdInfo
 setArityInfo	  info ar  = info { arityInfo = ar  }
+setCafInfo :: IdInfo -> CafInfo -> IdInfo
 setCafInfo        info caf = info { cafInfo = caf }
 
+setLBVarInfo :: IdInfo -> LBVarInfo -> IdInfo
 setLBVarInfo      info lb = {-lb `seq`-} info { lbvarInfo = lb }
 
+setNewDemandInfo :: IdInfo -> Maybe Demand -> IdInfo
 setNewDemandInfo     info dd = dd `seq` info { newDemandInfo = dd }
+setNewStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo
 setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd }
 \end{code}
 
@@ -402,6 +422,7 @@ vanillaIdInfo
 	    newStrictnessInfo   = Nothing
 	   }
 
+noCafIdInfo :: IdInfo
 noCafIdInfo  = vanillaIdInfo `setCafInfo`    NoCafRefs
 	-- Used for built-in type Ids in MkId.
 \end{code}
@@ -427,8 +448,10 @@ type ArityInfo = Arity
 	-- The arity might increase later in the compilation process, if
 	-- an extra lambda floats up to the binding site.
 
+unknownArity :: Arity
 unknownArity = 0 :: Arity
 
+ppArityInfo :: Int -> PprStyle -> Doc
 ppArityInfo 0 = empty
 ppArityInfo n = hsep [ptext SLIT("Arity"), int n]
 \end{code}
@@ -460,9 +483,13 @@ type InlinePragInfo = Activation
 %************************************************************************
 
 \begin{code}
--- CoreRules is used only in an idSpecialisation (move to IdInfo?)
 data SpecInfo 
-  = SpecInfo [CoreRule] VarSet	-- Locally-defined free vars of RHSs
+  = SpecInfo 
+	[CoreRule] 
+	VarSet		-- Locally-defined free vars of *both* LHS and RHS 
+			-- of rules.  I don't think it needs to include the
+			-- ru_fn though.
+			-- Note [Rule dependency info] in OccurAnal
 
 emptySpecInfo :: SpecInfo
 emptySpecInfo = SpecInfo [] emptyVarSet
@@ -476,10 +503,18 @@ specInfoFreeVars (SpecInfo _ fvs) = fvs
 specInfoRules :: SpecInfo -> [CoreRule]
 specInfoRules (SpecInfo rules _) = rules
 
+setSpecInfoHead :: Name -> SpecInfo -> SpecInfo
+setSpecInfoHead fn (SpecInfo rules fvs)
+  = SpecInfo (map set_head rules) fvs
+  where
+    set_head rule = rule { ru_fn = fn }
+
+seqSpecInfo :: SpecInfo -> ()
 seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs
 \end{code}
 
 
+
 %************************************************************************
 %*									*
 \subsection[worker-IdInfo]{Worker info about an @Id@}
@@ -523,6 +558,7 @@ seqWorker :: WorkerInfo -> ()
 seqWorker (HasWorker id a) = id `seq` a `seq` ()
 seqWorker NoWorker	   = ()
 
+ppWorkerInfo :: WorkerInfo -> PprStyle -> Doc
 ppWorkerInfo NoWorker            = empty
 ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id
 
@@ -532,9 +568,11 @@ workerExists (HasWorker _ _) = True
 
 workerId :: WorkerInfo -> Id
 workerId (HasWorker id _) = id
+workerId NoWorker = panic "workerId: NoWorker"
 
 wrapperArity :: WorkerInfo -> Arity
 wrapperArity (HasWorker _ a) = a
+wrapperArity NoWorker = panic "wrapperArity: NoWorker"
 \end{code}
 
 
@@ -556,13 +594,17 @@ data CafInfo
 	| NoCafRefs			-- A function or static constructor
 				        -- that refers to no CAFs.
 
+vanillaCafInfo :: CafInfo
 vanillaCafInfo = MayHaveCafRefs		-- Definitely safe
 
+mayHaveCafRefs :: CafInfo -> Bool
 mayHaveCafRefs  MayHaveCafRefs = True
 mayHaveCafRefs _	       = False
 
+seqCaf :: CafInfo -> ()
 seqCaf c = c `seq` ()
 
+ppCafInfo :: CafInfo -> PprStyle -> Doc
 ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs")
 ppCafInfo MayHaveCafRefs = empty
 \end{code}
@@ -640,15 +682,19 @@ work.
 data LBVarInfo = NoLBVarInfo 
 	       | IsOneShotLambda	-- The lambda is applied at most once).
 
+seqLBVar :: LBVarInfo -> ()
 seqLBVar l = l `seq` ()
 \end{code}
 
 \begin{code}
+hasNoLBVarInfo :: LBVarInfo -> Bool
 hasNoLBVarInfo NoLBVarInfo     = True
 hasNoLBVarInfo IsOneShotLambda = False
 
+noLBVarInfo :: LBVarInfo
 noLBVarInfo = NoLBVarInfo
 
+pprLBVarInfo :: LBVarInfo -> PprStyle -> Doc
 pprLBVarInfo NoLBVarInfo     = empty
 pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot")
 
@@ -680,11 +726,11 @@ zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand})
 	-- 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 _ _) = in_lam
-    is_safe_occ other		    = True
+    is_safe_occ _other		    = True
 
     safe_occ = case occ of
 		 OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt
-		 other	       	       -> occ
+		 _other	       	       -> occ
 
     is_safe_dmd Nothing    = True
     is_safe_dmd (Just dmd) = not (isStrictDmd dmd)
@@ -697,3 +743,31 @@ zapDemandInfo info@(IdInfo {newDemandInfo = dmd})
   | otherwise  = Nothing
 \end{code}
 
+\begin{code}
+zapFragileInfo :: IdInfo -> Maybe IdInfo
+-- Zap info that depends on free variables
+zapFragileInfo info 
+  = Just (info `setSpecInfo` emptySpecInfo
+	       `setWorkerInfo` NoWorker
+               `setUnfoldingInfo` NoUnfolding
+	       `setOccInfo` if isFragileOcc occ then NoOccInfo else occ)
+  where
+    occ = occInfo info
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{TickBoxOp}
+%*									*
+%************************************************************************
+
+\begin{code}
+type TickBoxId = Int
+
+data TickBoxOp 
+   = TickBox Module {-# UNPACK #-} !TickBoxId
+          -- ^Tick box for Hpc-style coverage
+
+instance Outputable TickBoxOp where
+    ppr (TickBox mod n)         = ptext SLIT("tick") <+> ppr (mod,n)
+\end{code}