Commit 30b5b5cc authored by kglynn's avatar kglynn

[project @ 1999-04-13 08:55:33 by kglynn]

(keving)

Big Bang introduction of CPR Analysis Pass.  Note that now
-fstrictness only does the strictness analysis phase,  it is necessary
to follow this with -fworker-wrapper to actually do the required Core
transformations. The -O option in the ghc driver script has been
modified appropriately.

For now,  CPR analysis is turned off.  To try it,  insert a
-fcpr_analyse between the -fstrictness and the -fworker-wrapper
options.

Misc. comments:

- The worker flag has been removed from an ID's StrictnessInfo field.
Now the worker info is an extra field in the Id's prag info.

- We do a nested CPR analysis,  but worker-wrapper only looks at the
info for the outermost constructor,  else laziness can be lost.

- Id's CPR Info in traces and interfaces file follows __M

- Worker-wrappery transformation now accounts for both strictness and
CPR analysis results.
parent f3270acf
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.53 1999/03/02 18:54:47 sof Exp $
# $Id: Makefile,v 1.54 1999/04/13 08:55:52 kglynn Exp $
TOP = ..
include $(TOP)/mk/boilerplate.mk
......@@ -49,7 +49,7 @@ $(HS_PROG) :: $(HS_SRCS)
DIRS = \
utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \
specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \
reader profiling parser
reader profiling parser cprAnalysis
ifeq ($(GhcWithNativeCodeGen),YES)
......
......@@ -40,17 +40,21 @@ module Id (
setIdArity,
setIdDemandInfo,
setIdStrictness,
setIdWorkerInfo,
setIdSpecialisation,
setIdUpdateInfo,
setIdCafInfo,
setIdCprInfo,
getIdArity,
getIdDemandInfo,
getIdStrictness,
getIdWorkerInfo,
getIdUnfolding,
getIdSpecialisation,
getIdUpdateInfo,
getIdCafInfo
getIdCafInfo,
getIdCprInfo
) where
......@@ -84,9 +88,13 @@ infixl 1 `setIdUnfolding`,
`setIdArity`,
`setIdDemandInfo`,
`setIdStrictness`,
`setIdWorkerInfo`,
`setIdSpecialisation`,
`setIdUpdateInfo`,
`setInlinePragma`
`setInlinePragma`,
`getIdCafInfo`,
`getIdCprInfo`
-- infixl so you can say (id `set` a `set` b)
\end{code}
......@@ -236,6 +244,14 @@ isBottomingId id = isBottomingStrictness (strictnessInfo (idInfo id))
idAppIsBottom :: Id -> Int -> Bool
idAppIsBottom id n = appIsBottom (strictnessInfo (idInfo id)) n
---------------------------------
-- WORKER ID
getIdWorkerInfo :: Id -> WorkerInfo
getIdWorkerInfo id = workerInfo (idInfo id)
setIdWorkerInfo :: Id -> WorkerInfo -> Id
setIdWorkerInfo id work_info = modifyIdInfo id (work_info `setWorkerInfo`)
---------------------------------
-- UNFOLDING
getIdUnfolding :: Id -> Unfolding
......@@ -275,6 +291,15 @@ getIdCafInfo id = cafInfo (idInfo id)
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo id (caf_info `setCafInfo`)
---------------------------------
-- CPR INFO
getIdCprInfo :: Id -> CprInfo
getIdCprInfo id = cprInfo (idInfo id)
setIdCprInfo :: Id -> CprInfo -> Id
setIdCprInfo id cpr_info = modifyIdInfo id (cpr_info `setCprInfo`)
\end{code}
......
......@@ -19,11 +19,16 @@ module IdInfo (
-- Strictness
StrictnessInfo(..), -- Non-abstract
workerExists, mkStrictnessInfo,
mkStrictnessInfo,
noStrictnessInfo, strictnessInfo,
ppStrictnessInfo, setStrictnessInfo,
isBottomingStrictness, appIsBottom,
-- Worker
WorkerInfo, workerExists,
mkWorkerInfo, noWorkerInfo, workerInfo, setWorkerInfo,
ppWorkerInfo,
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
......@@ -43,6 +48,9 @@ module IdInfo (
-- CAF info
CafInfo(..), cafInfo, setCafInfo, ppCafInfo,
-- Constructed Product Result Info
CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo
) where
#include "HsVersions.h"
......@@ -51,9 +59,13 @@ module IdInfo (
import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding )
import {-# SOURCE #-} CoreSyn ( CoreExpr )
import Id ( Id )
import SpecEnv ( SpecEnv, emptySpecEnv )
import Demand ( Demand, isLazy, wwLazy, pprDemands )
import Outputable
import Maybe ( isJust )
\end{code}
An @IdInfo@ gives {\em optional} information about an @Id@. If
......@@ -75,9 +87,11 @@ data IdInfo
demandInfo :: Demand, -- Whether or not it is definitely demanded
specInfo :: IdSpecEnv, -- Specialisations of this function which exist
strictnessInfo :: StrictnessInfo, -- Strictness properties
workerInfo :: WorkerInfo, -- Pointer to Worker Function
unfoldingInfo :: Unfolding, -- Its unfolding
updateInfo :: UpdateInfo, -- Which args should be updated
cafInfo :: CafInfo,
cprInfo :: CprInfo, -- Function always constructs a product result
inlinePragInfo :: !InlinePragInfo -- Inline pragmas
}
\end{code}
......@@ -88,11 +102,13 @@ Setters
setUpdateInfo ud info = info { updateInfo = ud }
setDemandInfo dd info = info { demandInfo = dd }
setStrictnessInfo st info = info { strictnessInfo = st }
setWorkerInfo wk info = info { workerInfo = wk }
setSpecInfo sp info = info { specInfo = sp }
setArityInfo ar info = info { arityInfo = ar }
setInlinePragInfo pr info = info { inlinePragInfo = pr }
setUnfoldingInfo uf info = info { unfoldingInfo = uf }
setCafInfo cf info = info { cafInfo = cf }
setCprInfo cp info = info { cprInfo = cp }
\end{code}
......@@ -102,9 +118,11 @@ noIdInfo = IdInfo {
demandInfo = wwLazy,
specInfo = emptySpecEnv,
strictnessInfo = NoStrictnessInfo,
workerInfo = noWorkerInfo,
unfoldingInfo = noUnfolding,
updateInfo = NoUpdateInfo,
cafInfo = MayHaveCafRefs,
cprInfo = NoCPRInfo,
inlinePragInfo = NoInlinePragInfo
}
\end{code}
......@@ -273,10 +291,12 @@ each of the ``wrapper's'' arguments (see the description about
worker/wrapper-style transformations in the PJ/Launchbury paper on
unboxed types).
The list of @Demands@ specifies: (a)~the strictness properties
of a function's arguments; (b)~the {\em existence} of a ``worker''
version of the function; and (c)~the type signature of that worker (if
it exists); i.e. its calling convention.
The list of @Demands@ specifies: (a)~the strictness properties of a
function's arguments; and (b)~the type signature of that worker (if it
exists); i.e. its calling convention.
Note that the existence of a worker function is now denoted by the Id's
workerInfo field.
\begin{code}
data StrictnessInfo
......@@ -288,40 +308,58 @@ data StrictnessInfo
-- BUT NB: f = \x y. error "urk"
-- will have info SI [SS] True
-- but still (f) and (f 2) are not bot; only (f 3 2) is bot
Bool -- True <=> there is a worker. There might not be, even for a
-- strict function, because:
-- (a) the function might be small enough to inline,
-- so no need for w/w split
-- (b) the strictness info might be "SSS" or something, so no w/w split.
\end{code}
\begin{code}
mkStrictnessInfo :: ([Demand], Bool) -> Bool -> StrictnessInfo
mkStrictnessInfo :: ([Demand], Bool) -> StrictnessInfo
mkStrictnessInfo (xs, is_bot) has_wrkr
mkStrictnessInfo (xs, is_bot)
| all isLazy xs && not is_bot = NoStrictnessInfo -- Uninteresting
| otherwise = StrictnessInfo xs is_bot has_wrkr
| otherwise = StrictnessInfo xs is_bot
noStrictnessInfo = NoStrictnessInfo
isBottomingStrictness (StrictnessInfo _ bot _) = bot
isBottomingStrictness NoStrictnessInfo = False
isBottomingStrictness (StrictnessInfo _ bot) = bot
isBottomingStrictness NoStrictnessInfo = False
-- appIsBottom returns true if an application to n args would diverge
appIsBottom (StrictnessInfo ds bot _) n = bot && (n >= length ds)
appIsBottom (StrictnessInfo ds bot) n = bot && (n >= length ds)
appIsBottom NoStrictnessInfo n = False
ppStrictnessInfo NoStrictnessInfo = empty
ppStrictnessInfo (StrictnessInfo wrapper_args bot wrkr_maybe)
ppStrictnessInfo (StrictnessInfo wrapper_args bot)
= hsep [ptext SLIT("__S"), pprDemands wrapper_args bot]
\end{code}
%************************************************************************
%* *
\subsection[worker-IdInfo]{Worker info about an @Id@}
%* *
%************************************************************************
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.
There might not be a worker, even for a strict function, because:
(a) the function might be small enough to inline, so no need
for w/w split
(b) the strictness info might be "SSS" or something, so no w/w split.
\begin{code}
workerExists :: StrictnessInfo -> Bool
workerExists (StrictnessInfo _ _ worker_exists) = worker_exists
workerExists other = False
type WorkerInfo = Maybe Id
mkWorkerInfo :: Id -> WorkerInfo
mkWorkerInfo wk_id = Just wk_id
noWorkerInfo = Nothing
ppWorkerInfo Nothing = empty
ppWorkerInfo (Just wk_id) = ppr wk_id
workerExists :: Maybe Id -> Bool
workerExists = isJust
\end{code}
......@@ -384,3 +422,69 @@ data CafInfo
ppCafInfo NoCafRefs = ptext SLIT("__C")
ppCafInfo MayHaveCafRefs = empty
\end{code}
%************************************************************************
%* *
\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@}
%* *
%************************************************************************
If the @Id@ is a function then it may have CPR info. A CPR analysis
phase detects whether:
\begin{enumerate}
\item
The function's return value has a product type, i.e. an algebraic type
with a single constructor. Examples of such types are tuples and boxed
primitive values.
\item
The function always 'constructs' the value that it is returning. It
must do this on every path through, and it's OK if it calls another
function which constructs the result.
\end{enumerate}
If this is the case then we store a template which tells us the
function has the CPR property and which components of the result are
also CPRs.
\begin{code}
data CprInfo
= NoCPRInfo
| CPRInfo [CprInfo]
-- e.g. const 5 == CPRInfo [NoCPRInfo]
-- == __M(-)
-- \x -> (5,
-- (x,
-- 5,
-- x)
-- )
-- CPRInfo [CPRInfo [NoCPRInfo],
-- CPRInfo [NoCprInfo,
-- CPRInfo [NoCPRInfo],
-- NoCPRInfo]
-- ]
-- __M((-)(-(-)-)-)
\end{code}
\begin{code}
noCprInfo = NoCPRInfo
ppCprInfo NoCPRInfo = empty
ppCprInfo c@(CPRInfo _)
= hsep [ptext SLIT("__M"), ppCprInfo' c]
where
ppCprInfo' NoCPRInfo = char '-'
ppCprInfo' (CPRInfo args) = parens (hcat (map ppCprInfo' args))
instance Outputable CprInfo where
ppr = ppCprInfo
instance Show CprInfo where
showsPrec p c = showsPrecSDoc p (ppr c)
\end{code}
......@@ -22,7 +22,8 @@ import Var ( isTyVar )
import IdInfo ( IdInfo,
arityInfo, ppArityInfo,
demandInfo, updateInfo, ppUpdateInfo, specInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
cprInfo, ppCprInfo
)
import Const ( Con(..), DataCon )
import DataCon ( isTupleCon, isUnboxedTupleCon )
......@@ -330,6 +331,7 @@ ppIdInfo info
ppStrictnessInfo s,
ppr d,
ppCafInfo c,
ppCprInfo m,
ppSpecInfo p
-- Inline pragma printed out with all binders; see PprCore.pprIdBndr
]
......@@ -339,6 +341,7 @@ ppIdInfo info
s = strictnessInfo info
u = updateInfo info
c = cafInfo info
m = cprInfo info
p = specInfo info
\end{code}
......
......@@ -24,7 +24,7 @@ import HsPragmas ( DataPragmas, ClassPragmas )
import HsTypes
import HsCore ( UfExpr )
import BasicTypes ( Fixity, NewOrData(..) )
import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo )
import IdInfo ( ArityInfo, UpdateInfo, InlinePragInfo, CprInfo )
import Demand ( Demand )
import CallConv ( CallConv, pprCallConv )
......@@ -453,6 +453,7 @@ data HsIdInfo name
| HsUpdate UpdateInfo
| HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
| HsNoCafRefs
| HsCprInfo CprInfo
data HsStrictnessInfo name
......
......@@ -38,6 +38,8 @@ module CmdLineOpts (
opt_D_dump_spec,
opt_D_dump_stg,
opt_D_dump_stranal,
opt_D_dump_cpranal,
opt_D_dump_worker_wrapper,
opt_D_dump_tc,
opt_D_show_passes,
opt_D_show_rn_trace,
......@@ -174,9 +176,11 @@ data CoreToDo -- These are diff core-to-core passes,
| CoreDoPrintCore
| CoreDoStaticArgs
| CoreDoStrictness
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoFoldrBuildWorkerWrapper
| CoreDoFoldrBuildWWAnal
| CoreDoCPResult
\end{code}
\begin{code}
......@@ -308,6 +312,8 @@ opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl-iterations")
opt_D_dump_spec = lookUp SLIT("-ddump-spec")
opt_D_dump_stg = lookUp SLIT("-ddump-stg")
opt_D_dump_stranal = lookUp SLIT("-ddump-stranal")
opt_D_dump_worker_wrapper = lookUp SLIT("-ddump-workwrap")
opt_D_dump_cpranal = lookUp SLIT("-ddump-cpranalyse")
opt_D_dump_tc = lookUp SLIT("-ddump-tc")
opt_D_show_passes = lookUp SLIT("-dshow-passes")
opt_D_show_rn_trace = lookUp SLIT("-dshow-rn-trace")
......@@ -416,9 +422,11 @@ classifyOpts = sep argv [] [] -- accumulators...
"-fprint-core" -> CORE_TD(CoreDoPrintCore)
"-fstatic-args" -> CORE_TD(CoreDoStaticArgs)
"-fstrictness" -> CORE_TD(CoreDoStrictness)
"-fworker-wrapper" -> CORE_TD(CoreDoWorkerWrapper)
"-fspecialise" -> CORE_TD(CoreDoSpecialising)
"-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper)
"-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal)
"-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal)
"-fcpr-analyse" -> CORE_TD(CoreDoCPResult)
"-fstg-static-args" -> STG_TD(StgDoStaticArgs)
"-fupdate-analysis" -> STG_TD(StgDoUpdateAnalysis)
......
......@@ -36,7 +36,8 @@ import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePr
arityInfo, ppArityInfo,
strictnessInfo, ppStrictnessInfo,
cafInfo, ppCafInfo,
workerExists, isBottomingStrictness
cprInfo, ppCprInfo,
workerExists, workerInfo, isBottomingStrictness
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..) )
import CoreUtils ( exprSomeFreeVars )
......@@ -277,6 +278,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
| otherwise = hsep [ptext SLIT("{-##"),
arity_pretty,
caf_pretty,
cpr_pretty,
strict_pretty,
unfold_pretty,
spec_pretty,
......@@ -288,9 +290,13 @@ ifaceId get_idinfo needed_ids is_rec id rhs
------------ Caf Info --------------
caf_pretty = ppCafInfo (cafInfo idinfo)
------------ Strictness --------------
------------ CPR Info --------------
cpr_pretty = ppCprInfo (cprInfo idinfo)
------------ Strictness and Worker --------------
strict_info = strictnessInfo idinfo
has_worker = workerExists strict_info
work_info = workerInfo idinfo
has_worker = workerExists work_info
bottoming_fn = isBottomingStrictness strict_info
strict_pretty = ppStrictnessInfo strict_info <+> wrkr_pretty
......@@ -299,8 +305,9 @@ ifaceId get_idinfo needed_ids is_rec id rhs
| otherwise = ppr work_id <+>
braces (hsep (map ppr con_list))
(work_id, wrapper_cons) = getWorkerIdAndCons id rhs
con_list = uniqSetToList wrapper_cons
(Just work_id) = work_info
wrapper_cons = snd $ getWorkerIdAndCons id rhs
con_list = uniqSetToList wrapper_cons
------------ Unfolding --------------
unfold_pretty | show_unfold = unfold_herald <+> pprIfaceUnfolding rhs
......
......@@ -98,7 +98,7 @@ templates, but we don't ever expect to generate code for it.
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
bottoming_info = mkStrictnessInfo ([wwStrict], True) False `setStrictnessInfo` noCafIdInfo
bottoming_info = mkStrictnessInfo ([wwStrict], True) `setStrictnessInfo` noCafIdInfo
-- these "bottom" out, no matter what their arguments
eRROR_ID
......
......@@ -35,7 +35,7 @@ module Lex (
import Char ( ord, isSpace )
import List ( isSuffixOf )
import IdInfo ( InlinePragInfo(..) )
import IdInfo ( InlinePragInfo(..), CprInfo(..) )
import Name ( isLowerISO, isUpperISO )
import Module ( IfaceFlavour, hiFile, hiBootFile )
import PrelMods ( mkTupNameStr, mkUbxTupNameStr )
......@@ -140,6 +140,7 @@ data IfaceToken
| ITnocaf
| ITunfold InlinePragInfo
| ITstrict ([Demand], Bool)
| ITcprinfo (CprInfo)
| ITscc
| ITsccAllCafs
......@@ -268,13 +269,16 @@ lexIface cont buf =
buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of
[ (ch, rest)] -> cont (ITchar ch) (stepOverLexeme (incLexeme buf'))
-- strictness pragma and __scc treated specially.
-- strictness and cpr pragmas and __scc treated specially.
'_'# ->
case lookAhead# buf 1# of
'_'# -> case lookAhead# buf 2# of
'S'# ->
lex_demand cont (stepOnUntil (not . isSpace)
(stepOnBy# buf 3#)) -- past __S
'M'# ->
lex_cpr cont (stepOnUntil (not . isSpace)
(stepOnBy# buf 3#)) -- past __M
's'# ->
case prefixMatch (stepOnBy# buf 3#) "cc" of
Just buf' -> lex_scc cont (stepOverLexeme buf')
......@@ -350,6 +354,24 @@ lex_demand cont buf =
= case read_em [] buf of
(stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
lex_cpr cont buf =
case read_em [] buf of { (cpr_inf,buf') ->
ASSERT ( null (tail cpr_inf) )
cont (ITcprinfo $ head cpr_inf) (stepOverLexeme buf')
}
where
-- code snatched from lex_demand above
read_em acc buf =
case currentChar# buf of
'-'# -> read_em (NoCPRInfo : acc) (stepOn buf)
'('# -> do_unpack acc (stepOn buf)
')'# -> (reverse acc, stepOn buf)
_ -> (reverse acc, buf)
do_unpack acc buf
= case read_em [] buf of
(stuff, rest) -> read_em ((CPRInfo stuff) : acc) rest
------------------
lex_scc cont buf =
case currentChar# buf of
......
......@@ -15,7 +15,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..),
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import HsPragmas ( noDataPragmas, noClassPragmas )
import Type ( Kind, mkArrowKind, boxedTypeKind, openTypeKind )
import IdInfo ( ArityInfo, exactArity )
import IdInfo ( ArityInfo, exactArity, CprInfo(..) )
import Lex
import RnMonad ( ImportVersion, LocalVersion, ParsedIface(..), WhatsImported(..),
......@@ -98,6 +98,7 @@ import Ratio ( (%) )
'__C' { ITnocaf }
'__U' { ITunfold $$ }
'__S' { ITstrict $$ }
'__M' { ITcprinfo $$ }
'..' { ITdotdot } -- reserved symbols
'::' { ITdcolon }
......@@ -531,6 +532,7 @@ id_info : { [] }
id_info_item :: { HsIdInfo RdrName }
id_info_item : '__A' arity_info { HsArity $2 }
| strict_info { HsStrictness $1 }
| '__M' { HsCprInfo $1 }
| '__U' core_expr { HsUnfold $1 (Just $2) }
| '__U' { HsUnfold $1 Nothing }
| '__P' spec_tvs
......
......@@ -640,6 +640,7 @@ rnIdInfo (HsUnfold inline Nothing) = returnRn (HsUnfold inline Nothing)
rnIdInfo (HsArity arity) = returnRn (HsArity arity)
rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
rnIdInfo (HsNoCafRefs) = returnRn (HsNoCafRefs)
rnIdInfo (HsCprInfo cpr_info) = returnRn (HsCprInfo cpr_info)
rnIdInfo (HsSpecialise tyvars tys expr)
= bindTyVarsRn doc tyvars $ \ tyvars' ->
rnCoreExpr expr `thenRn` \ expr' ->
......
......@@ -57,7 +57,10 @@ import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
import Specialise ( specProgram)
import SpecEnv ( specEnvToList, specEnvFromList )
import StrictAnal ( saWwTopBinds )
import StrictAnal ( saBinds )
import WorkWrap ( wwTopBinds )
import CprAnalyse ( cprAnalyse )
import Var ( TyVar, mkId )
import Unique ( Unique, Uniquable(..),
ratioTyConKey, mkUnique, incrUnique, initTidyUniques
......@@ -112,8 +115,10 @@ doCorePass us binds CoreLiberateCase = _scc_ "LiberateCase" liberateCase
doCorePass us binds CoreDoFloatInwards = _scc_ "FloatInwards" floatInwards binds
doCorePass us binds CoreDoFullLaziness = _scc_ "CoreFloating" floatOutwards us binds
doCorePass us binds CoreDoStaticArgs = _scc_ "CoreStaticArgs" doStaticArgs us binds
doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saWwTopBinds us binds
doCorePass us binds CoreDoStrictness = _scc_ "CoreStranal" saBinds binds
doCorePass us binds CoreDoWorkerWrapper = _scc_ "CoreWorkWrap" wwTopBinds us binds
doCorePass us binds CoreDoSpecialising = _scc_ "Specialise" specProgram us binds
doCorePass us binds CoreDoCPResult = _scc_ "CPResult" cprAnalyse binds
doCorePass us binds CoreDoPrintCore = _scc_ "PrintCore" do
putStr (showSDoc $ pprCoreBindings binds)
return binds
......
......@@ -1038,7 +1038,7 @@ rebuild expr cont
case expr of
Var v -> case getIdStrictness v of
NoStrictnessInfo -> do_rebuild expr cont
StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot )
StrictnessInfo demands result_bot -> ASSERT( not (null demands) || result_bot )
-- If this happened we'd get an infinite loop
rebuild_strict demands result_bot expr (idType v) cont
other -> do_rebuild expr cont
......
......@@ -115,7 +115,7 @@ lookupAbsValEnv (AbsValEnv idenv) y
absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
absValFromStrictness anal NoStrictnessInfo = AbsTop
absValFromStrictness anal (StrictnessInfo args_info bot_result _)
absValFromStrictness anal (StrictnessInfo args_info bot_result)
= case args_info of -- Check the invariant that the arg list on
[] -> res -- AbsApproxFun is non-empty
_ -> AbsApproxFun args_info res
......
......@@ -7,7 +7,7 @@ The original version(s) of all strictness-analyser code (except the
Semantique analyser) was written by Andy Gill.
\begin{code}
module StrictAnal ( saWwTopBinds ) where
module StrictAnal ( saBinds ) where
#include "HsVersions.h"
......@@ -23,7 +23,6 @@ import ErrUtils ( dumpIfSet )
import SaAbsInt
import SaLib
import Demand ( isStrict )
import WorkWrap -- "back-end" of strictness analyser
import UniqSupply ( UniqSupply )
import Util ( zipWith4Equal )
import Outputable
......@@ -75,12 +74,15 @@ Alas and alack.
%* *
%************************************************************************
@saBinds@ decorates bindings with strictness info. A later
worker-wrapper pass can use this info to create wrappers and
strict workers.
\begin{code}
saWwTopBinds :: UniqSupply
-> [CoreBind]
-> IO [CoreBind]
saBinds ::[CoreBind]
-> IO [CoreBind]
saWwTopBinds us binds
saBinds binds
= do {
beginPass "Strictness analysis";
......@@ -93,11 +95,7 @@ saWwTopBinds us binds
let { binds_w_strictness = saTopBindsBinds binds };
#endif
-- Create worker/wrappers, and mark binders with their
-- "strictness info" [which encodes their worker/wrapper-ness]
let { binds' = workersAndWrappers us binds_w_strictness };
endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds'
endPass "Strictness analysis" (opt_D_dump_stranal || opt_D_verbose_core2core) binds_w_strictness
}
\end{code}
......@@ -328,7 +326,7 @@ addStrictnessInfoToId
addStrictnessInfoToId str_val abs_val binder body
= case (collectTyAndValBinders body) of
(_, lambda_bounds, rhs) -> binder `setIdStrictness`
mkStrictnessInfo strictness False
mkStrictnessInfo strictness
where
tys = map idType lambda_bounds
strictness = findStrictness tys str_val abs_val
......
......@@ -4,25 +4,27 @@
\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
\begin{code}
module WorkWrap ( workersAndWrappers, getWorkerIdAndCons ) where
module WorkWrap ( wwTopBinds, getWorkerIdAndCons ) where
#include "HsVersions.h"
import CoreSyn
import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
import CmdLineOpts ( opt_UnfoldingCreationThreshold )
import CmdLineOpts ( opt_UnfoldingCreationThreshold, opt_D_verbose_core2core,
opt_D_dump_worker_wrapper )
import CoreLint ( beginPass, endPass )
import CoreUtils ( coreExprType )
import Const ( Con(..) )
import DataCon ( DataCon )
import MkId ( mkWorkerId )