Take the old strictness analyser out of #ifdef DEBUG and put it
instead in #ifdef OLD_STRICTNESS. DEBUG was getting a bit slow.
setIdCgInfo,
setIdOccInfo,
setIdCgInfo,
setIdOccInfo,
idDemandInfo,
idStrictness,
idCprInfo,
idDemandInfo,
idStrictness,
idCprInfo,
newStrictnessFromOld -- Temporary
#endif
newStrictnessFromOld -- Temporary
#endif
`setIdSpecialisation`,
`setInlinePragma`,
`idCafInfo`
`setIdSpecialisation`,
`setInlinePragma`,
`idCafInfo`
,`idCprInfo`
,`setIdStrictness`
,`setIdDemandInfo`
,`idCprInfo`
,`setIdStrictness`
,`setIdDemandInfo`
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
setIdArity :: Id -> Arity -> Id
setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id
---------------------------------
-- (OLD) STRICTNESS
idStrictness :: Id -> StrictnessInfo
---------------------------------
-- (OLD) STRICTNESS
idStrictness :: Id -> StrictnessInfo
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
setIdUnfolding :: Id -> Unfolding -> Id
setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id
---------------------------------
-- (OLD) DEMAND
idDemandInfo :: Id -> Demand.Demand
---------------------------------
-- (OLD) DEMAND
idDemandInfo :: Id -> Demand.Demand
---------------------------------
-- CG INFO
idCgInfo :: Id -> CgInfo
---------------------------------
-- CG INFO
idCgInfo :: Id -> CgInfo
idCgInfo id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCgInfo" (ppr id)
info -> info
idCgInfo id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCgInfo" (ppr id)
info -> info
---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
idCafInfo id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCafInfo" (ppr id)
info -> cgCafInfo info
idCafInfo id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCafInfo" (ppr id)
info -> cgCafInfo info
#endif
---------------------------------
-- CPR INFO
#endif
---------------------------------
-- CPR INFO
idCprInfo :: Id -> CprInfo
idCprInfo id = cprInfo (idInfo id)
idCprInfo :: Id -> CprInfo
idCprInfo id = cprInfo (idInfo id)
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
-- Old DemandInfo and StrictnessInfo
demandInfo, setDemandInfo,
strictnessInfo, setStrictnessInfo,
-- Old DemandInfo and StrictnessInfo
demandInfo, setDemandInfo,
strictnessInfo, setStrictnessInfo,
`setNewStrictnessInfo`,
`setAllStrictnessInfo`,
`setNewDemandInfo`
`setNewStrictnessInfo`,
`setAllStrictnessInfo`,
`setNewDemandInfo`
, `setCprInfo`
, `setDemandInfo`
, `setStrictnessInfo`
, `setCprInfo`
, `setDemandInfo`
, `setStrictnessInfo`
-- Set old and new strictness info
setAllStrictnessInfo info Nothing
= info { newStrictnessInfo = Nothing
-- Set old and new strictness info
setAllStrictnessInfo info Nothing
= info { newStrictnessInfo = Nothing
, strictnessInfo = NoStrictnessInfo
, cprInfo = NoCPRInfo
#endif
, strictnessInfo = NoStrictnessInfo
, cprInfo = NoCPRInfo
#endif
setAllStrictnessInfo info (Just sig)
= info { newStrictnessInfo = Just sig
setAllStrictnessInfo info (Just sig)
= info { newStrictnessInfo = Just sig
, strictnessInfo = oldStrictnessFromNew sig
, cprInfo = cprInfoFromNewStrictness sig
#endif
, strictnessInfo = oldStrictnessFromNew sig
, cprInfo = cprInfoFromNewStrictness sig
#endif
seqNewStrictnessInfo Nothing = ()
seqNewStrictnessInfo (Just ty) = seqStrictSig ty
seqNewStrictnessInfo Nothing = ()
seqNewStrictnessInfo (Just ty) = seqStrictSig ty
oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
where
oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo
oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info)
where
oldDemand (Eval (Poly _)) = WwStrict
oldDemand (Call _) = WwStrict
oldDemand (Eval (Poly _)) = WwStrict
oldDemand (Call _) = WwStrict
+#endif /* OLD_STRICTNESS */
arityInfo :: !ArityInfo, -- Its arity
specInfo :: CoreRules, -- Specialisations of this function which exist
tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id
arityInfo :: !ArityInfo, -- Its arity
specInfo :: CoreRules, -- Specialisations of this function which exist
tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id
cprInfo :: CprInfo, -- Function always constructs a product result
demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded
strictnessInfo :: StrictnessInfo, -- Strictness properties
cprInfo :: CprInfo, -- Function always constructs a product result
demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded
strictnessInfo :: StrictnessInfo, -- Strictness properties
seqDemand (newDemandInfo info) `seq`
seqNewStrictnessInfo (newStrictnessInfo info) `seq`
seqDemand (newDemandInfo info) `seq`
seqNewStrictnessInfo (newStrictnessInfo info) `seq`
Demand.seqDemand (demandInfo info) `seq`
seqStrictnessInfo (strictnessInfo info) `seq`
seqCpr (cprInfo info) `seq`
Demand.seqDemand (demandInfo info) `seq`
seqStrictnessInfo (strictnessInfo info) `seq`
seqCpr (cprInfo info) `seq`
setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg }
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo info oc = oc `seq` info { occInfo = oc }
setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg }
setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr }
setOccInfo info oc = oc `seq` info { occInfo = oc }
setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
#endif
-- Try to avoid spack leaks by seq'ing
setStrictnessInfo info st = st `seq` info { strictnessInfo = st }
#endif
-- Try to avoid spack leaks by seq'ing
-- actually increases residency significantly.
= info { unfoldingInfo = uf }
-- actually increases residency significantly.
= info { unfoldingInfo = uf }
setDemandInfo info dd = info { demandInfo = dd }
setCprInfo info cp = info { cprInfo = cp }
#endif
setDemandInfo info dd = info { demandInfo = dd }
setCprInfo info cp = info { cprInfo = cp }
#endif
= IdInfo {
cgInfo = noCgInfo,
arityInfo = unknownArity,
= IdInfo {
cgInfo = noCgInfo,
arityInfo = unknownArity,
cprInfo = NoCPRInfo,
demandInfo = wwLazy,
strictnessInfo = NoStrictnessInfo,
cprInfo = NoCPRInfo,
demandInfo = wwLazy,
strictnessInfo = NoStrictnessInfo,
downstream, by the code generator.
\begin{code}
downstream, by the code generator.
\begin{code}
newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo
noCgInfo = panic "NoCgInfo!"
#else
newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo
noCgInfo = panic "NoCgInfo!"
#else
data CprInfo
= NoCPRInfo
| ReturnsCPR -- Yes, this function returns a constructed product
data CprInfo
= NoCPRInfo
| ReturnsCPR -- Yes, this function returns a constructed product
-> IdInfo -- f (the exported one)
-> IdInfo -- New info for f
copyIdInfo f_local f = f { newStrictnessInfo = newStrictnessInfo f_local,
-> IdInfo -- f (the exported one)
-> IdInfo -- New info for f
copyIdInfo f_local f = f { newStrictnessInfo = newStrictnessInfo f_local,
strictnessInfo = strictnessInfo f_local,
cprInfo = cprInfo f_local,
#endif
strictnessInfo = strictnessInfo f_local,
cprInfo = cprInfo f_local,
#endif
import CostCentre ( pprCostCentreCore )
import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo,
import CostCentre ( pprCostCentreCore )
import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo,
idDemandInfo,
#endif
globalIdDetails, isGlobalId, isExportedId,
idDemandInfo,
#endif
globalIdDetails, isGlobalId, isExportedId,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo,
newStrictnessInfo,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo,
newStrictnessInfo,
cprInfo, ppCprInfo,
strictnessInfo,
#endif
cprInfo, ppCprInfo,
strictnessInfo,
#endif
(megaSeqIdInfo (idInfo id) `seq`
-- Useful for poking on black holes
ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
(megaSeqIdInfo (idInfo id) `seq`
-- Useful for poking on black holes
ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
ppr (idDemandInfo id) <+>
#endif
ppr (idNewDemandInfo id) <+>
ppr (idDemandInfo id) <+>
#endif
ppr (idNewDemandInfo id) <+>
= hsep [ ppArityInfo a,
ppTyGenInfo g,
ppWorkerInfo (workerInfo info),
= hsep [ ppArityInfo a,
ppTyGenInfo g,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
ppCprInfo m,
#endif
ppStrictnessInfo s,
ppCprInfo m,
#endif
where
a = arityInfo info
g = tyGenInfo info
where
a = arityInfo info
g = tyGenInfo info
s = strictnessInfo info
m = cprInfo info
#endif
s = strictnessInfo info
m = cprInfo info
#endif
constructed product result}
\begin{code}
constructed product result}
\begin{code}
module CprAnalyse ( ) where
#else
module CprAnalyse ( ) where
#else
arity = idArity v
-- Imported (non-nullary) constructors will have the CPR property
-- in their IdInfo, so no need to look at their unfolding
arity = idArity v
-- Imported (non-nullary) constructors will have the CPR property
-- in their IdInfo, so no need to look at their unfolding
+#endif /* OLD_STRICTNESS */
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.88 2002/03/05 14:18:55 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.89 2002/03/15 13:57:31 simonmar Exp $
-- -fno-* pattern below doesn't work. We therefore allow
-- certain optimisation passes to be turned off explicitly:
, ( "fno-strictness" , NoArg (writeIORef v_Strictness False) )
-- -fno-* pattern below doesn't work. We therefore allow
-- certain optimisation passes to be turned off explicitly:
, ( "fno-strictness" , NoArg (writeIORef v_Strictness False) )
, ( "fno-cpr" , NoArg (writeIORef v_CPR False) )
#endif
, ( "fno-cse" , NoArg (writeIORef v_CSE False) )
, ( "fno-cpr" , NoArg (writeIORef v_CPR False) )
#endif
, ( "fno-cse" , NoArg (writeIORef v_CSE False) )
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.71 2002/03/13 13:51:35 simonmar Exp $
+-- $Id: DriverState.hs,v 1.72 2002/03/15 13:57:31 simonmar Exp $
--
-- Settings for the driver
--
--
-- Settings for the driver
--
GLOBAL_VAR(v_StgStats, False, Bool)
GLOBAL_VAR(v_UsageSPInf, False, Bool) -- Off by default
GLOBAL_VAR(v_Strictness, True, Bool)
GLOBAL_VAR(v_StgStats, False, Bool)
GLOBAL_VAR(v_UsageSPInf, False, Bool) -- Off by default
GLOBAL_VAR(v_Strictness, True, Bool)
GLOBAL_VAR(v_CPR, True, Bool)
#endif
GLOBAL_VAR(v_CSE, True, Bool)
GLOBAL_VAR(v_CPR, True, Bool)
#endif
GLOBAL_VAR(v_CSE, True, Bool)
max_iter <- readIORef v_MaxSimplifierIterations
usageSP <- readIORef v_UsageSPInf
strictness <- readIORef v_Strictness
max_iter <- readIORef v_MaxSimplifierIterations
usageSP <- readIORef v_UsageSPInf
strictness <- readIORef v_Strictness
cpr <- readIORef v_CPR
#endif
cse <- readIORef v_CSE
cpr <- readIORef v_CPR
#endif
cse <- readIORef v_CSE
],
case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
],
case rule_check of { Just pat -> CoreDoRuleCheck 0 pat; Nothing -> CoreDoNothing },
if cpr then CoreDoCPResult else CoreDoNothing,
#endif
if strictness then CoreDoStrictness else CoreDoNothing,
if cpr then CoreDoCPResult else CoreDoNothing,
#endif
if strictness then CoreDoStrictness else CoreDoNothing,
= _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
doCorePass dfs rb us binds CoreDoSpecConstr
= _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
= _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
doCorePass dfs rb us binds CoreDoSpecConstr
= _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
doCorePass dfs rb us binds CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
#endif
doCorePass dfs rb us binds CoreDoCPResult
= _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds)
#endif
= noStats dfs (return binds)
strictAnal dfs binds = do
= noStats dfs (return binds)
strictAnal dfs binds = do
binds <- saBinds dfs binds
#endif
dmdAnalPgm dfs binds
binds <- saBinds dfs binds
#endif
dmdAnalPgm dfs binds
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlinePragma,
isDataConId, isGlobalId, idArity,
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlinePragma,
isDataConId, isGlobalId, idArity,
idDemandInfo, idStrictness, idCprInfo,
#endif
idNewStrictness, idNewStrictness_maybe,
setIdNewStrictness, idNewDemandInfo,
setIdNewDemandInfo, idName
)
idDemandInfo, idStrictness, idCprInfo,
#endif
idNewStrictness, idNewStrictness_maybe,
setIdNewStrictness, idNewDemandInfo,
setIdNewDemandInfo, idName
)
import IdInfo ( newStrictnessFromOld, newDemand )
#endif
import Var ( Var )
import IdInfo ( newStrictnessFromOld, newDemand )
#endif
import Var ( Var )
let { binds_plus_dmds = do_prog binds } ;
endPass dflags "Demand analysis"
Opt_D_dump_stranal 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
+#ifdef OLD_STRICTNESS
+ -- Only if OLD_STRICTNESS 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) ;
-- strictness analyser run
let { dmd_changes = get_changes binds_plus_dmds } ;
printDump (text "Changes in demands" $$ dmd_changes) ;
get_changes binds = vcat (map get_changes_bind binds)
get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
get_changes binds = vcat (map get_changes_bind binds)
get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs)
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
\section[SaAbsInt]{Abstract interpreter for strictness analysis}
\begin{code}
-#ifndef DEBUG
--- If DEBUG is off, omit all exports
+#ifndef OLD_STRICTNESS
+-- If OLD_STRICTNESS is off, omit all exports
module SaAbsInt () where
#else
module SaAbsInt () where
#else
iterations, because there are several variables involved at once.
\begin{code}
iterations, because there are several variables involved at once.
\begin{code}
+#endif /* OLD_STRICTNESS */
Semantique analyser) was written by Andy Gill.
\begin{code}
Semantique analyser) was written by Andy Gill.
\begin{code}
module StrictAnal ( ) where
#else
module StrictAnal ( ) where
#else
sequenceSa ms `thenSa` \ rs ->
returnSa (r:rs)
sequenceSa ms `thenSa` \ rs ->
returnSa (r:rs)
+#endif /* OLD_STRICTNESS */