X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FIdInfo.lhs;h=ad6d24763fc311bce03f48782aafe463753f8898;hb=869feb6a8105f34092a1ae1e755dffb69a565c85;hp=9db8e350a16b414d201565facb13f92ec4a173bf;hpb=49c98d143c382a1341e1046f5ca00819a25691ba;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/IdInfo.lhs b/compiler/basicTypes/IdInfo.lhs
index 9db8e35..ad6d247 100644
--- a/compiler/basicTypes/IdInfo.lhs
+++ b/compiler/basicTypes/IdInfo.lhs
@@ -16,7 +16,7 @@ module IdInfo (
 	seqIdInfo, megaSeqIdInfo,
 
 	-- Zapping
-	zapLamInfo, zapDemandInfo,
+	zapLamInfo, zapDemandInfo, zapFragileInfo,
 
 	-- Arity
 	ArityInfo,
@@ -65,20 +65,22 @@ 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
-    ) where
+        LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo,
 
-#include "HsVersions.h"
+        -- Tick-box info
+        TickBoxOp(..), TickBoxId,
+    ) where
 
 import CoreSyn
 import Class
 import PrimOp
+import Name
 import Var
 import VarSet
 import BasicTypes
@@ -87,11 +89,12 @@ import TyCon
 import ForeignCall
 import NewDemand
 import Outputable	
+import Module
+import FastString
 
 import Data.Maybe
 
 #ifdef OLD_STRICTNESS
-import Name
 import Demand
 import qualified Demand
 import Util
@@ -126,8 +129,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
@@ -144,11 +147,13 @@ setAllStrictnessInfo info (Just sig)
 #endif
          }
 
+seqNewStrictnessInfo :: Maybe StrictSig -> ()
 seqNewStrictnessInfo Nothing = ()
 seqNewStrictnessInfo (Just ty) = seqStrictSig ty
 
+pprNewStrictness :: Maybe StrictSig -> SDoc
 pprNewStrictness Nothing = empty
-pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig
+pprNewStrictness (Just sig) = ftext (fsLit "Str:") <+> ppr sig
 
 #ifdef OLD_STRICTNESS
 oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
@@ -208,6 +213,7 @@ oldDemand (Call _)         = WwStrict
 
 
 \begin{code}
+seqNewDemandInfo :: Maybe Demand -> ()
 seqNewDemandInfo Nothing    = ()
 seqNewDemandInfo (Just dmd) = seqDemand dmd
 \end{code}
@@ -215,7 +221,7 @@ seqNewDemandInfo (Just dmd) = seqDemand dmd
 
 %************************************************************************
 %*									*
-\subsection{GlobalIdDetails
+\subsection{GlobalIdDetails}
 %*									*
 %************************************************************************
 
@@ -228,7 +234,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]
@@ -246,19 +253,23 @@ 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
-    ppr NotGlobalId       = ptext SLIT("[***NotGlobalId***]")
-    ppr VanillaGlobal     = ptext SLIT("[GlobalId]")
-    ppr (DataConWorkId _) = ptext SLIT("[DataCon]")
-    ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
-    ppr (ClassOpId _)     = ptext SLIT("[ClassOp]")
-    ppr (PrimOpId _)      = ptext SLIT("[PrimOp]")
-    ppr (FCallId _)       = ptext SLIT("[ForeignCall]")
-    ppr (RecordSelId {})  = ptext SLIT("[RecSel]")
+    ppr NotGlobalId       = ptext (sLit "[***NotGlobalId***]")
+    ppr VanillaGlobal     = ptext (sLit "[GlobalId]")
+    ppr (DataConWorkId _) = ptext (sLit "[DataCon]")
+    ppr (DataConWrapId _) = ptext (sLit "[DataConWrapper]")
+    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}
 
 
@@ -344,19 +355,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. 
@@ -367,12 +384,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}
 
@@ -398,6 +420,7 @@ vanillaIdInfo
 	    newStrictnessInfo   = Nothing
 	   }
 
+noCafIdInfo :: IdInfo
 noCafIdInfo  = vanillaIdInfo `setCafInfo`    NoCafRefs
 	-- Used for built-in type Ids in MkId.
 \end{code}
@@ -423,10 +446,12 @@ 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 -> SDoc
 ppArityInfo 0 = empty
-ppArityInfo n = hsep [ptext SLIT("Arity"), int n]
+ppArityInfo n = hsep [ptext (sLit "Arity"), int n]
 \end{code}
 
 %************************************************************************
@@ -456,9 +481,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
@@ -472,10 +501,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@}
@@ -519,8 +556,9 @@ seqWorker :: WorkerInfo -> ()
 seqWorker (HasWorker id a) = id `seq` a `seq` ()
 seqWorker NoWorker	   = ()
 
+ppWorkerInfo :: WorkerInfo -> SDoc
 ppWorkerInfo NoWorker            = empty
-ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id
+ppWorkerInfo (HasWorker wk_id _) = ptext (sLit "Worker") <+> ppr wk_id
 
 workerExists :: WorkerInfo -> Bool
 workerExists NoWorker        = False
@@ -528,9 +566,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}
 
 
@@ -552,14 +592,18 @@ 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 NoCafRefs = ptext SLIT("NoCafRefs")
+ppCafInfo :: CafInfo -> SDoc
+ppCafInfo NoCafRefs = ptext (sLit "NoCafRefs")
 ppCafInfo MayHaveCafRefs = empty
 \end{code}
 
@@ -607,7 +651,7 @@ seqCpr NoCPRInfo  = ()
 noCprInfo       = NoCPRInfo
 
 ppCprInfo NoCPRInfo  = empty
-ppCprInfo ReturnsCPR = ptext SLIT("__M")
+ppCprInfo ReturnsCPR = ptext (sLit "__M")
 
 instance Outputable CprInfo where
     ppr = ppCprInfo
@@ -636,17 +680,21 @@ 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 -> SDoc
 pprLBVarInfo NoLBVarInfo     = empty
-pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot")
+pprLBVarInfo IsOneShotLambda = ptext (sLit "OneShot")
 
 instance Outputable LBVarInfo where
     ppr = pprLBVarInfo
@@ -676,11 +724,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)
@@ -693,3 +741,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}