-- IdInfo stuff
setIdUnfolding,
setIdArity,
- setIdDemandInfo, setIdNewDemandInfo,
- setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
+ setIdNewDemandInfo,
+ setIdNewStrictness, zapIdNewStrictness,
setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
setIdCgInfo,
- setIdCprInfo,
setIdOccInfo,
+#ifdef DEBUG
+ idDemandInfo,
+ idStrictness,
+ idCprInfo,
+ setIdStrictness,
+ setIdDemandInfo,
+ setIdCprInfo,
+#endif
+
idArity,
- idDemandInfo, idNewDemandInfo,
- idStrictness, idNewStrictness, idNewStrictness_maybe,
+ idNewDemandInfo,
+ idNewStrictness, idNewStrictness_maybe,
idTyGenInfo,
idWorkerInfo,
idUnfolding,
idSpecialisation,
idCgInfo,
idCafInfo,
- idCprInfo,
idLBVarInfo,
idOccInfo,
+#ifdef DEBUG
newStrictnessFromOld -- Temporary
+#endif
) where
import Outputable
import Unique ( Unique, mkBuiltinUnique )
+-- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`,
`setIdArity`,
- `setIdDemandInfo`,
- `setIdStrictness`,
`setIdNewDemandInfo`,
`setIdNewStrictness`,
`setIdTyGenInfo`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
`setInlinePragma`,
- `idCafInfo`,
- `idCprInfo`
-
- -- infixl so you can say (id `set` a `set` b)
+ `idCafInfo`
+#ifdef DEBUG
+ ,`idCprInfo`
+ ,`setIdStrictness`
+ ,`setIdDemandInfo`
+#endif
\end{code}
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
+#ifdef DEBUG
---------------------------------
- -- STRICTNESS
+ -- (OLD) STRICTNESS
idStrictness :: Id -> StrictnessInfo
idStrictness id = strictnessInfo (idInfo id)
setIdStrictness :: Id -> StrictnessInfo -> Id
setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id
+#endif
-- isBottomingId returns true if an application to n args would diverge
isBottomingId :: Id -> Bool
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
+#ifdef DEBUG
---------------------------------
- -- DEMAND
+ -- (OLD) DEMAND
idDemandInfo :: Id -> Demand.Demand
idDemandInfo id = demandInfo (idInfo id)
setIdDemandInfo :: Id -> Demand.Demand -> Id
setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id
+#endif
idNewDemandInfo :: Id -> NewDemand.Demand
idNewDemandInfo id = newDemandInfo (idInfo id)
#else
idCafInfo id = cgCafInfo (idCgInfo id)
#endif
-
---------------------------------
-- CPR INFO
+#ifdef DEBUG
idCprInfo :: Id -> CprInfo
idCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id
+#endif
---------------------------------
-- Occcurrence INFO
-- New demand and strictness info
newStrictnessInfo, setNewStrictnessInfo,
- newDemandInfo, setNewDemandInfo, newDemand, oldDemand,
+ newDemandInfo, setNewDemandInfo,
-- Strictness; imported from Demand
StrictnessInfo(..),
mkStrictnessInfo, noStrictnessInfo,
ppStrictnessInfo,isBottomingStrictness,
- strictnessInfo, setStrictnessInfo, setAllStrictnessInfo,
- oldStrictnessFromNew, newStrictnessFromOld, cprInfoFromNewStrictness,
+ setAllStrictnessInfo,
-- Usage generalisation
TyGenInfo(..),
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
- -- DemandInfo
+#ifdef DEBUG
+ -- Old DemandInfo and StrictnessInfo
demandInfo, setDemandInfo,
+ strictnessInfo, setStrictnessInfo,
+ cprInfoFromNewStrictness,
+ oldStrictnessFromNew, newStrictnessFromOld,
+ oldDemand, newDemand,
+
+ -- Constructed Product Result Info
+ CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo,
+#endif
-- Inline prags
InlinePragInfo,
-- CAF info
CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,
- -- Constructed Product Result Info
- CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo,
-
-- Lambda-bound variable info
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo
) where
import ForeignCall ( ForeignCall )
import FieldLabel ( FieldLabel )
import Type ( usOnce, usMany )
-import Demand hiding( Demand )
+import Demand hiding( Demand, seqDemand )
import qualified Demand
-import NewDemand ( Demand(..), DmdResult(..), Demands(..),
- lazyDmd, topDmd, dmdTypeDepth, isStrictDmd, isBotRes,
- splitStrictSig, strictSigResInfo,
- StrictSig, mkStrictSig, mkTopDmdType, evalDmd, lazyDmd
- )
+import NewDemand
import Outputable
import Util ( seqList, listLengthCmp )
import List ( replicate )
-infixl 1 `setDemandInfo`,
- `setTyGenInfo`,
- `setStrictnessInfo`,
+-- infixl so you can say (id `set` a `set` b)
+infixl 1 `setTyGenInfo`,
`setSpecInfo`,
`setArityInfo`,
`setInlinePragInfo`,
`setUnfoldingInfo`,
- `setCprInfo`,
`setWorkerInfo`,
`setLBVarInfo`,
`setOccInfo`,
`setNewStrictnessInfo`,
`setAllStrictnessInfo`,
`setNewDemandInfo`
- -- infixl so you can say (id `set` a `set` b)
+#ifdef DEBUG
+ `setCprInfo`,
+ `setDemandInfo`,
+ `setStrictnessInfo`,
+#endif
\end{code}
%************************************************************************
-- Set old and new strictness info
setAllStrictnessInfo info Nothing
= info { newStrictnessInfo = Nothing,
+#ifdef DEBUG
strictnessInfo = NoStrictnessInfo,
- cprInfo = NoCPRInfo }
+ cprInfo = NoCPRInfo,
+#endif
+ }
setAllStrictnessInfo info (Just sig)
= info { newStrictnessInfo = Just sig,
+#ifdef DEBUG
strictnessInfo = oldStrictnessFromNew sig,
- cprInfo = cprInfoFromNewStrictness sig }
+ cprInfo = cprInfoFromNewStrictness sig,
+#endif
+ }
+
+seqNewStrictnessInfo Nothing = ()
+seqNewStrictnessInfo (Just ty) = seqStrictSig ty
+#ifdef DEBUG
oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
where
oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds)
oldDemand (Eval (Poly _)) = WwStrict
oldDemand (Call _) = WwStrict
+
+#endif /* DEBUG */
\end{code}
\begin{code}
data IdInfo
= IdInfo {
- arityInfo :: ArityInfo, -- Its arity
- demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded
+ arityInfo :: !ArityInfo, -- Its arity
specInfo :: CoreRules, -- Specialisations of this function which exist
tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id
+#ifdef DEBUG
+ 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
unfoldingInfo :: Unfolding, -- Its unfolding
cgInfo :: CgInfo, -- Code generator info (arity, CAF info)
- cprInfo :: CprInfo, -- Function always constructs a product result
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
inlinePragInfo :: InlinePragInfo, -- Inline pragma
occInfo :: OccInfo, -- How it occurs
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
- = seqArity (arityInfo info) `seq`
- seqDemand (demandInfo info) `seq`
- seqRules (specInfo info) `seq`
+ = seqRules (specInfo info) `seq`
seqTyGenInfo (tyGenInfo info) `seq`
- seqStrictnessInfo (strictnessInfo info) `seq`
seqWorker (workerInfo info) `seq`
--- seqUnfolding (unfoldingInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
+-- seqUnfolding (unfoldingInfo info) `seq`
+
+ seqDemand (newDemandInfo info) `seq`
+ seqNewStrictnessInfo (newStrictnessInfo info) `seq`
+
+#ifdef DEBUG
+ Demand.seqDemand (demandInfo info) `seq`
+ seqStrictnessInfo (strictnessInfo info) `seq`
+ seqCpr (cprInfo info) `seq`
+#endif
-- CgInfo is involved in a loop, so we have to be careful not to seq it
-- too early.
-- seqCg (cgInfo info) `seq`
- seqCpr (cprInfo info) `seq`
seqLBVar (lbvarInfo info) `seq`
seqOccInfo (occInfo info)
\end{code}
setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg }
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo info oc = oc `seq` info { occInfo = oc }
+#ifdef DEBUG
setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
+#endif
-- Try to avoid spack leaks by seq'ing
setUnfoldingInfo info uf
-- actually increases residency significantly.
= info { unfoldingInfo = uf }
+#ifdef DEBUG
setDemandInfo info dd = info { demandInfo = dd }
+setCprInfo info cp = info { cprInfo = cp }
+#endif
+
setArityInfo info ar = info { arityInfo = ar }
setCgInfo info cg = info { cgInfo = cg }
-setCprInfo info cp = info { cprInfo = cp }
-setLBVarInfo info lb = info { lbvarInfo = lb }
-setNewDemandInfo info dd = info { newDemandInfo = dd }
-setNewStrictnessInfo info dd = info { newStrictnessInfo = dd }
+setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb }
+
+setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd }
+setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd }
\end{code}
= IdInfo {
cgInfo = noCgInfo,
arityInfo = unknownArity,
+#ifdef DEBUG
+ cprInfo = NoCPRInfo,
demandInfo = wwLazy,
+ strictnessInfo = NoStrictnessInfo,
+#endif
specInfo = emptyCoreRules,
tyGenInfo = noTyGenInfo,
workerInfo = NoWorker,
- strictnessInfo = NoStrictnessInfo,
unfoldingInfo = noUnfolding,
- cprInfo = NoCPRInfo,
lbvarInfo = NoLBVarInfo,
inlinePragInfo = AlwaysActive,
occInfo = NoOccInfo,
-- The arity might increase later in the compilation process, if
-- an extra lambda floats up to the binding site.
-seqArity :: ArityInfo -> ()
-seqArity a = a `seq` ()
-
unknownArity = 0 :: Arity
ppArityInfo 0 = empty
If this Id has a worker then we store a reference to it. Worker
functions are generated by the worker/wrapper pass. This uses
-information from the strictness and CPR analyses.
+information from strictness analysis.
There might not be a worker, even for a strict function, because:
(a) the function might be small enough to inline, so no need
-- w/w split. See comments in MkIface.ifaceId, with the 'Worker' code.
seqWorker :: WorkerInfo -> ()
-seqWorker (HasWorker id _) = id `seq` ()
+seqWorker (HasWorker id a) = id `seq` a `seq` ()
seqWorker NoWorker = ()
ppWorkerInfo NoWorker = empty
also CPRs.
\begin{code}
+#ifdef DEBUG
data CprInfo
= NoCPRInfo
| ReturnsCPR -- Yes, this function returns a constructed product
-- We used to keep nested info about sub-components, but
-- we never used it so I threw it away
-\end{code}
-\begin{code}
seqCpr :: CprInfo -> ()
seqCpr ReturnsCPR = ()
seqCpr NoCPRInfo = ()
instance Show CprInfo where
showsPrec p c = showsPrecSDoc p (ppr c)
+#endif
\end{code}
copyIdInfo :: IdInfo -- f_local
-> IdInfo -- f (the exported one)
-> IdInfo -- New info for f
-copyIdInfo f_local f = f { strictnessInfo = strictnessInfo f_local,
- workerInfo = workerInfo f_local,
+copyIdInfo f_local f = f { newStrictnessInfo = newStrictnessInfo f_local,
+#ifdef DEBUG
+ strictnessInfo = strictnessInfo f_local,
cprInfo = cprInfo f_local
+#endif
+ workerInfo = workerInfo f_local,
}
\end{code}
import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
setUnfoldingInfo,
setArityInfo, setSpecInfo, setCafInfo,
- newStrictnessFromOld, setAllStrictnessInfo,
- GlobalIdDetails(..), CafInfo(..), CprInfo(..)
+ setAllStrictnessInfo,
+ GlobalIdDetails(..), CafInfo(..)
)
import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
mkTopDmdType, topDmd, evalDmd, lazyDmd,
mkPrimOpId prim_op
= id
where
- (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op
+ (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op
ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
name = mkPrimOpIdName prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafNoTyGenIdInfo
`setSpecInfo` rules
`setArityInfo` arity
- `setAllStrictnessInfo` Just (newStrictnessFromOld name arity strict_info NoCPRInfo)
- -- Until we modify the primop generation code
+ `setAllStrictnessInfo` Just strict_sig
rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
import CoreSyn
import CostCentre ( pprCostCentreCore )
import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
- idInfo, idInlinePragma, idDemandInfo, idOccInfo,
- globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
+ idInfo, idInlinePragma, idOccInfo,
+#ifdef DEBUG
+ idDemandInfo,
+#endif
+ globalIdDetails, isGlobalId, isExportedId,
+ isSpecPragmaId, idNewDemandInfo
)
import Var ( isTyVar )
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
- specInfo, cprInfo, ppCprInfo,
- strictnessInfo, ppStrictnessInfo,
- cprInfo, ppCprInfo,
+ specInfo, ppStrictnessInfo,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo,
- newDemandInfo, newStrictnessInfo
+ newStrictnessInfo,
+#ifdef DEBUG
+ cprInfo, ppCprInfo,
+ strictnessInfo,
+#endif
)
import DataCon ( dataConTyCon )
import TyCon ( tupleTyConBoxity, isTupleTyCon )
(megaSeqIdInfo (idInfo id) `seq`
-- Useful for poking on black holes
ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
- ppr (idDemandInfo id)) <+> ppr (newDemandInfo (idInfo id)) <+>
- ppr (idLBVarInfo id))
+#ifdef DEBUG
+ ppr (idDemandInfo id) <+>
+#endif
+ ppr (idNewDemandInfo id) <+>
+ ppr (idLBVarInfo id)))
\end{code}
= hsep [ ppArityInfo a,
ppTyGenInfo g,
ppWorkerInfo (workerInfo info),
+#ifdef DEBUG
ppStrictnessInfo s,
ppCprInfo m,
+#endif
ppr (newStrictnessInfo info),
pprCoreRules b p
-- Inline pragma, occ, demand, lbvar info
where
a = arityInfo info
g = tyGenInfo info
+#ifdef DEBUG
s = strictnessInfo info
m = cprInfo info
+#endif
p = specInfo info
\end{code}
constructed product result}
\begin{code}
+#ifndef DEBUG
+module CprAnalyse ( ) where
+
+#else
+
module CprAnalyse ( cprAnalyse ) where
#include "HsVersions.h"
\begin{code}
cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind]
-#ifndef DEBUG
--- Omit unless DEBUG is on
-cprAnalyse dflags binds = return binds
-
-#else
cprAnalyse dflags binds
= do {
showPass dflags "Constructed Product analysis" ;
import TysPrim
import TysWiredIn
-import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) )
+import NewDemand
import Var ( TyVar )
import Name ( Name, mkWiredInName )
import RdrName ( RdrName, mkRdrOrig )
Not all primops are strict!
\begin{code}
-primOpStrictness :: PrimOp -> Arity -> StrictnessInfo
+primOpStrictness :: PrimOp -> Arity -> StrictSig
-- See Demand.StrictnessInfo for discussion of what the results
-- The arity should be the arity of the primop; that's why
-- this function isn't exported.
-- (type variables, argument types, result type)
-- It also gives arity, strictness info
-primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictnessInfo)
+primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig)
primOpSig op
= (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity)
where
-----------------------------------------------------------------------
--- $Id: primops.txt.pp,v 1.11 2001/12/07 11:34:48 sewardj Exp $
+-- $Id: primops.txt.pp,v 1.12 2001/12/10 14:07:30 simonmar Exp $
--
-- Primitive Operations
--
commutable = False
needs_wrapper = False
can_fail = False
- strictness = { \ arity -> StrictnessInfo (replicate arity wwPrim) False }
+ strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) }
usage = { nomangle other }
-- Currently, documentation is produced using latex, so contents of
in the specified state thread,
with each element containing the specified initial value.}
with
- strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False }
usage = { mangle NewArrayOp [mkP, mkM, mkP] mkM }
out_of_line = True
{Write to specified index of mutable array.}
with
usage = { mangle WriteArrayOp [mkM, mkP, mkM, mkP] mkR }
- strictness = { \ arity -> StrictnessInfo [wwPrim, wwPrim, wwLazy, wwPrim] False }
has_side_effects = True
primop IndexArrayOp "indexArray#" GenPrimOp
o -> State# RealWorld -> State# RealWorld
with
has_side_effects = True
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
primop EqForeignObj "eqForeignObj#" GenPrimOp
ForeignObj# -> ForeignObj# -> Bool
{Create MutVar\# with specified initial value in specified state thread.}
with
usage = { mangle NewMutVarOp [mkM, mkP] mkM }
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
out_of_line = True
primop ReadMutVarOp "readMutVar#" GenPrimOp
MutVar# s a -> a -> State# s -> State# s
{Write contents of MutVar\#.}
with
- strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False }
usage = { mangle WriteMutVarOp [mkM, mkM, mkP] mkR }
has_side_effects = True
-> State# RealWorld
-> (# State# RealWorld, a #)
with
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwPrim] False }
-- Catch is actually strict in its first argument
-- but we don't want to tell the strictness
-- analyser about that!
primop RaiseOp "raise#" GenPrimOp
a -> b
with
- strictness = { \ arity -> StrictnessInfo [wwLazy] True }
- -- NB: True => result is bottom
+ strictness = { \ arity -> mkStrictSig (mkTopDmdType [lazyDmd] BotRes) }
+ -- NB: result is bottom
usage = { mangle RaiseOp [mkM] mkM }
out_of_line = True
(State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
with
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
out_of_line = True
primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp
(State# RealWorld -> (# State# RealWorld, a #))
-> (State# RealWorld -> (# State# RealWorld, a #))
with
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
out_of_line = True
------------------------------------------------------------------------
{If mvar is full, block until it becomes empty.
Then store value arg as its new contents.}
with
- strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False }
usage = { mangle PutMVarOp [mkM, mkM, mkP] mkR }
has_side_effects = True
out_of_line = True
{If mvar is full, immediately return with integer 0.
Otherwise, store value arg as mvar's new contents, and return with integer 1.}
with
- strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False }
usage = { mangle TryPutMVarOp [mkM, mkM, mkP] mkR }
has_side_effects = True
out_of_line = True
a -> State# RealWorld -> (# State# RealWorld, ThreadId# #)
with
usage = { mangle ForkOp [mkO, mkP] mkR }
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
has_side_effects = True
out_of_line = True
primop MkWeakOp "mkWeak#" GenPrimOp
o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #)
with
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwLazy, wwPrim] False }
usage = { mangle MkWeakOp [mkZ, mkM, mkM, mkP] mkM }
has_side_effects = True
out_of_line = True
primop MakeStablePtrOp "makeStablePtr#" GenPrimOp
a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)
with
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
usage = { mangle MakeStablePtrOp [mkM, mkP] mkM }
has_side_effects = True
out_of_line = True
a -> State# RealWorld -> (# State# RealWorld, StableName# a #)
with
usage = { mangle MakeStableNameOp [mkZ, mkP] mkR }
- strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False }
needs_wrapper = True
has_side_effects = True
out_of_line = True
a -> Int#
with
usage = { mangle SeqOp [mkO] mkR }
- strictness = { \ arity -> StrictnessInfo [wwStrict] False }
+ strictness = { \ arity -> mkStrictSig (mkTopDmdType [evalDmd] TopRes) }
-- Seq is strict in its argument; see notes in ConFold.lhs
has_side_effects = True
a -> Int#
with
usage = { mangle ParOp [mkO] mkR }
- strictness = { \ arity -> StrictnessInfo [wwLazy] False }
-- Note that Par is lazy to avoid that the sparked thing
-- gets evaluted strictly, which it should *not* be
has_side_effects = True
primop DataToTagOp "dataToTag#" GenPrimOp
a -> Int#
- with
- strictness = { \ arity -> StrictnessInfo [wwLazy] False }
primop TagToEnumOp "tagToEnum#" GenPrimOp
Int# -> a
doCorePass dfs rb us binds CoreDoStaticArgs
= _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
doCorePass dfs rb us binds CoreDoStrictness
- = _scc_ "Stranal" noStats dfs (do { binds1 <- saBinds dfs binds ;
- dmdAnalPgm dfs binds1 })
+ = _scc_ "Stranal" noStats dfs (strictAnal dfs binds)
doCorePass dfs rb us binds CoreDoWorkerWrapper
= _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
doCorePass dfs rb us binds CoreDoSpecialising
= _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
doCorePass dfs rb us binds CoreDoSpecConstr
= _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
+#ifdef DEBUG
doCorePass dfs rb us binds CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
+#endif
doCorePass dfs rb us binds CoreDoPrintCore
= _scc_ "PrintCore" noStats dfs (printCore binds)
doCorePass dfs rb us binds CoreDoUSPInf
doCorePass dfs rb us binds CoreDoNothing
= noStats dfs (return binds)
+strictAnal dfs binds = do
+#ifdef DEBUG
+ binds <- saBinds dfs binds
+#endif
+ dmdAnalPgm dfs binds
+
printCore binds = do dumpIfSet True "Print Core"
(pprCoreBindings binds)
return binds
import CoreUtils ( exprIsValue, exprArity )
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
-import Id ( Id, idType, idDemandInfo, idInlinePragma,
+import Id ( Id, idType, idInlinePragma,
isDataConId, isGlobalId, idArity,
- idNewStrictness, idNewStrictness_maybe, setIdNewStrictness,
- idNewDemandInfo, setIdNewDemandInfo, idName, idStrictness, idCprInfo )
-import IdInfo ( newDemand, newStrictnessFromOld )
+#ifdef DEBUG
+ idDemandInfo, idStrictness, idCprInfo,
+#endif
+ idNewStrictness, idNewStrictness_maybe,
+ setIdNewStrictness, idNewDemandInfo,
+ setIdNewDemandInfo, idName
+ )
+#ifdef DEBUG
+import IdInfo ( newStrictnessFromOld, newDemand )
+#endif
import Var ( Var )
import VarEnv
import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly,
dmdAnalPgm dflags binds
= do {
showPass dflags "Demand analysis" ;
- let { binds_plus_dmds = do_prog binds ;
- dmd_changes = get_changes binds_plus_dmds } ;
+ let { binds_plus_dmds = do_prog binds } ;
endPass dflags "Demand analysis"
Opt_D_dump_stranal binds_plus_dmds ;
#ifdef DEBUG
- -- Only if DEBUG is on, because only then is the old strictness analyser run
+ -- Only if DEBUG is on, because only then is the old
+ -- strictness analyser run
+ let dmd_changes = get_changes binds_plus_dmds ;
printDump (text "Changes in demands" $$ dmd_changes) ;
#endif
return binds_plus_dmds
\begin{code}
+#ifdef DEBUG
get_changes binds = vcat (map get_changes_bind binds)
get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
old = newDemand (idDemandInfo id)
new_better = new `betterDemand` old
old_better = old `betterDemand` new
+#endif
squashSig (StrictSig (DmdType fv ds res))
= StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res)
Semantique analyser) was written by Andy Gill.
\begin{code}
+#ifndef DEBUG
+module StrictAnal ( ) where
+
+#else
+
module StrictAnal ( saBinds ) where
#include "HsVersions.h"
\begin{code}
saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
-#ifndef DEBUG
--- Omit strictness analyser if DEBUG is off
-
-saBinds dflags binds = return binds
-
-#else
saBinds dflags binds
= do {
showPass dflags "Strictness analysis";
sequenceSa (m:ms) = m `thenSa` \ r ->
sequenceSa ms `thenSa` \ rs ->
returnSa (r:rs)
+
#endif /* DEBUG */
\end{code}
projects / ghc-hetmet.git / commitdiff