# -----------------------------------------------------------------------------
-# $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
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)
setIdArity,
setIdDemandInfo,
setIdStrictness,
+ setIdWorkerInfo,
setIdSpecialisation,
setIdUpdateInfo,
setIdCafInfo,
+ setIdCprInfo,
getIdArity,
getIdDemandInfo,
getIdStrictness,
+ getIdWorkerInfo,
getIdUnfolding,
getIdSpecialisation,
getIdUpdateInfo,
- getIdCafInfo
+ getIdCafInfo,
+ getIdCprInfo
) where
`setIdArity`,
`setIdDemandInfo`,
`setIdStrictness`,
+ `setIdWorkerInfo`,
`setIdSpecialisation`,
`setIdUpdateInfo`,
- `setInlinePragma`
+ `setInlinePragma`,
+ `getIdCafInfo`,
+ `getIdCprInfo`
+
-- infixl so you can say (id `set` a `set` b)
\end{code}
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
getIdUnfolding id = unfoldingInfo (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}
-- Strictness
StrictnessInfo(..), -- Non-abstract
- workerExists, mkStrictnessInfo,
+ mkStrictnessInfo,
noStrictnessInfo, strictnessInfo,
ppStrictnessInfo, setStrictnessInfo,
isBottomingStrictness, appIsBottom,
+ -- Worker
+ WorkerInfo, workerExists,
+ mkWorkerInfo, noWorkerInfo, workerInfo, setWorkerInfo,
+ ppWorkerInfo,
+
-- Unfolding
unfoldingInfo, setUnfoldingInfo,
-- CAF info
CafInfo(..), cafInfo, setCafInfo, ppCafInfo,
+
+ -- Constructed Product Result Info
+ CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo
) where
#include "HsVersions.h"
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
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}
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}
demandInfo = wwLazy,
specInfo = emptySpecEnv,
strictnessInfo = NoStrictnessInfo,
+ workerInfo = noWorkerInfo,
unfoldingInfo = noUnfolding,
updateInfo = NoUpdateInfo,
cafInfo = MayHaveCafRefs,
+ cprInfo = NoCPRInfo,
inlinePragInfo = NoInlinePragInfo
}
\end{code}
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
-- 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}
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}
+
+
+
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 )
ppStrictnessInfo s,
ppr d,
ppCafInfo c,
+ ppCprInfo m,
ppSpecInfo p
-- Inline pragma printed out with all binders; see PprCore.pprIdBndr
]
s = strictnessInfo info
u = updateInfo info
c = cafInfo info
+ m = cprInfo info
p = specInfo info
\end{code}
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 )
| HsUpdate UpdateInfo
| HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
| HsNoCafRefs
+ | HsCprInfo CprInfo
data HsStrictnessInfo name
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,
| CoreDoPrintCore
| CoreDoStaticArgs
| CoreDoStrictness
+ | CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoFoldrBuildWorkerWrapper
| CoreDoFoldrBuildWWAnal
+ | CoreDoCPResult
\end{code}
\begin{code}
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")
"-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)
arityInfo, ppArityInfo,
strictnessInfo, ppStrictnessInfo,
cafInfo, ppCafInfo,
- workerExists, isBottomingStrictness
+ cprInfo, ppCprInfo,
+ workerExists, workerInfo, isBottomingStrictness
)
import CoreSyn ( CoreExpr, CoreBind, Bind(..) )
import CoreUtils ( exprSomeFreeVars )
| otherwise = hsep [ptext SLIT("{-##"),
arity_pretty,
caf_pretty,
+ cpr_pretty,
strict_pretty,
unfold_pretty,
spec_pretty,
------------ 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
| 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
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
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 )
| ITnocaf
| ITunfold InlinePragInfo
| ITstrict ([Demand], Bool)
+ | ITcprinfo (CprInfo)
| ITscc
| ITsccAllCafs
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')
= 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
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(..),
'__C' { ITnocaf }
'__U' { ITunfold $$ }
'__S' { ITstrict $$ }
+ '__M' { ITcprinfo $$ }
'..' { ITdotdot } -- reserved symbols
'::' { ITdcolon }
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
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' ->
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
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
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
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
Semantique analyser) was written by Andy Gill.
\begin{code}
-module StrictAnal ( saWwTopBinds ) where
+module StrictAnal ( saBinds ) where
#include "HsVersions.h"
import SaAbsInt
import SaLib
import Demand ( isStrict )
-import WorkWrap -- "back-end" of strictness analyser
import UniqSupply ( UniqSupply )
import Util ( zipWith4Equal )
import Outputable
%* *
%************************************************************************
+@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";
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}
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
\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 )
import Id ( Id, getIdStrictness,
setIdStrictness, setInlinePragma, idWantsToBeINLINEd,
- )
+ setIdWorkerInfo, getIdCprInfo )
import VarSet
import Type ( splitAlgTyConApp_maybe )
-import IdInfo ( mkStrictnessInfo, StrictnessInfo(..),
- InlinePragInfo(..) )
+import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
+ InlinePragInfo(..), CprInfo(..) )
+import Demand ( wwLazy )
import SaLib
import UniqSupply ( UniqSupply, initUs, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
import UniqSet
import Outputable
\end{code}
-We take Core bindings whose binders have their strictness attached (by
-the front-end of the strictness analyser), and we return some
-``plain'' bindings which have been worker/wrapper-ified, meaning:
+We take Core bindings whose binders have:
+
\begin{enumerate}
-\item
-Functions have been split into workers and wrappers where appropriate;
-\item
-Binders' @IdInfos@ have been updated to reflect the existence
-of these workers/wrappers (this is where we get STRICTNESS pragma
+
+\item Strictness attached (by the front-end of the strictness
+analyser), and / or
+
+\item Constructed Product Result information attached by the CPR
+analysis pass.
+
+\end{enumerate}
+
+and we return some ``plain'' bindings which have been
+worker/wrapper-ified, meaning:
+
+\begin{enumerate}
+
+\item Functions have been split into workers and wrappers where
+appropriate. If a function has both strictness and CPR properties
+then only one worker/wrapper doing both transformations is produced;
+
+\item Binders' @IdInfos@ have been updated to reflect the existence of
+these workers/wrappers (this is where we get STRICTNESS and CPR pragma
info for exported values).
\end{enumerate}
\begin{code}
+
+wwTopBinds :: UniqSupply
+ -> [CoreBind]
+ -> IO [CoreBind]
+
+wwTopBinds us binds
+ = do {
+ beginPass "Worker Wrapper binds";
+
+ -- Create worker/wrappers, and mark binders with their
+ -- "strictness info" [which encodes their worker/wrapper-ness]
+ let { binds' = workersAndWrappers us binds };
+
+ endPass "Worker Wrapper binds" (opt_D_dump_worker_wrapper ||
+ opt_D_verbose_core2core) binds'
+ }
+\end{code}
+
+
+\begin{code}
workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
workersAndWrappers us top_binds
-- twice, this test also prevents wrappers (which are INLINEd)
-- from being re-done.
- || not has_strictness_info
- || not (worthSplitting revised_wrap_args_info)
+ || not (do_strict_ww || do_cpr_ww)
= returnUs [ (fn_id, rhs) ]
| otherwise -- Do w/w split
in
mkWwBodies tyvars wrap_args
(coreExprType body)
- revised_wrap_args_info `thenUs` \ (wrap_fn, work_fn, work_demands) ->
+ revised_wrap_args_info
+ cpr_info
+ `thenUs` \ (wrap_fn, work_fn, work_demands) ->
getUniqueUs `thenUs` \ work_uniq ->
let
work_rhs = work_fn body
work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) `setIdStrictness`
- mkStrictnessInfo (work_demands, result_bot) False
+ (if do_strict_ww then mkStrictnessInfo (work_demands, result_bot)
+ else noStrictnessInfo)
wrap_rhs = wrap_fn work_id
- wrap_id = fn_id `setIdStrictness` mkStrictnessInfo (revised_wrap_args_info, result_bot) True
+ wrap_id = fn_id `setIdStrictness`
+ (if do_strict_ww then mkStrictnessInfo (revised_wrap_args_info, result_bot)
+ else noStrictnessInfo)
+ `setIdWorkerInfo` (Just work_id)
`setInlinePragma` IWantToBeINLINEd
-- Add info to the wrapper:
-- (a) we want to inline it everywhere
- -- (b) we want to pin on its revised stricteness info
- -- (c) we pin on its worker id and the list of constructors mentioned in the wrapper
+ -- (b) we want to pin on its revised strictness info
+ -- (c) we pin on its worker id
in
returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
-- Worker first, because wrapper mentions it
where
strictness_info = getIdStrictness fn_id
has_strictness_info = case strictness_info of
- StrictnessInfo _ _ _ -> True
- other -> False
+ StrictnessInfo _ _ -> True
+ other -> False
- StrictnessInfo wrap_args_info result_bot _ = strictness_info
+ StrictnessInfo wrap_args_info result_bot = strictness_info
- revised_wrap_args_info = setUnpackStrategy wrap_args_info
+ revised_wrap_args_info = if has_strictness_info
+ then setUnpackStrategy wrap_args_info
+ else repeat wwLazy
+
+
+ -- If we are going to split for CPR purposes anyway, then
+ -- we may as well do the strictness transformation
+ do_strict_ww = has_strictness_info && (do_cpr_ww ||
+ worthSplitting revised_wrap_args_info)
+
+ cpr_info = getIdCprInfo fn_id
+ has_cpr_info = case cpr_info of
+ CPRInfo _ -> True
+ other -> False
+
+ do_cpr_ww = has_cpr_info
unfold_guidance = calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
-- snaffles out (a) the worker Id and (b) constructors needed to
-- make the wrapper.
-- These are needed when we write an interface file.
+
+-- <Mar 1999 (keving)> - Well, since the addition of the CPR transformation this function
+-- got too crude!
+-- Now the worker id is stored directly in the id's Info field. We still use this function to
+-- snaffle the wrapper's constructors but I don't trust the code to find the worker id.
getWorkerIdAndCons :: Id -> CoreExpr -> (Id, UniqSet DataCon)
getWorkerIdAndCons wrap_id wrapper_fn
- = (get_work_id wrapper_fn, get_cons wrapper_fn)
+ = (work_id wrapper_fn, get_cons wrapper_fn)
where
+
+ work_id wrapper_fn
+ = case get_work_id wrapper_fn of
+ [] -> case work_id_try2 wrapper_fn of
+ [] -> pprPanic "getWorkerIdAndCons: can't find worker id" (ppr wrap_id)
+ [id] -> id
+ _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
+ [id] -> id
+ _ -> pprPanic "getWorkerIdAndCons: found too many worker ids" (ppr wrap_id)
+
get_work_id (Lam _ body) = get_work_id body
- get_work_id (Case _ _ [(_,_,rhs)]) = get_work_id rhs
+ get_work_id (Case _ _ [(_,_,rhs@(Case _ _ _))]) = get_work_id rhs
+ get_work_id (Case scrut _ [(_,_,rhs)]) = (get_work_id scrut) ++ (get_work_id rhs)
get_work_id (Note _ body) = get_work_id body
get_work_id (Let _ body) = get_work_id body
+ get_work_id (App (Var work_id) _) = [work_id]
get_work_id (App fn _) = get_work_id fn
- get_work_id (Var work_id) = work_id
- get_work_id other = pprPanic "getWorkerIdAndCons" (ppr wrap_id)
-
+ get_work_id (Var work_id) = []
+ get_work_id other = []
+
+ work_id_try2 (Lam _ body) = work_id_try2 body
+ work_id_try2 (Note _ body) = work_id_try2 body
+ work_id_try2 (Let _ body) = work_id_try2 body
+ work_id_try2 (App fn _) = work_id_try2 fn
+ work_id_try2 (Var work_id) = [work_id]
+ work_id_try2 other = []
get_cons (Lam _ body) = get_cons body
get_cons (Let (NonRec _ rhs) body) = get_cons rhs `unionUniqSets` get_cons body
#include "HsVersions.h"
import CoreSyn
-import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo )
-import Const ( Con(..) )
+import Id ( Id, idType, mkSysLocal, getIdDemandInfo, setIdDemandInfo,
+ mkWildId )
+import IdInfo ( CprInfo(..), noCprInfo )
+import Const ( Con(..), DataCon )
import DataCon ( dataConArgTys )
import Demand ( Demand(..) )
import PrelVals ( aBSENT_ERROR_ID )
-import TysWiredIn ( unitTy, unitDataCon )
+import TysWiredIn ( unitTy, unitDataCon,
+ unboxedTupleCon, unboxedTupleTyCon )
import Type ( isUnLiftedType, mkTyVarTys, mkTyVarTy, mkFunTys,
splitForAllTys, splitFunTys,
- splitAlgTyConApp_maybe,
+ splitAlgTyConApp_maybe, mkTyConApp,
Type
)
+import TyCon ( isNewTyCon,
+ TyCon )
import BasicTypes ( NewOrData(..) )
import Var ( TyVar )
-import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM )
-import Util ( zipWithEqual )
+import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs,
+ mapUs, UniqSM )
+import Util ( zipWithEqual, zipEqual )
import Outputable
\end{code}
\begin{code}
mkWrapper :: Type -- Wrapper type
-> [Demand] -- Wrapper strictness info
+ -> CprInfo -- Wrapper cpr info
-> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id
-mkWrapper fun_ty demands
+mkWrapper fun_ty demands cpr_info
= let
n_wrap_args = length demands
in
leftover_arg_tys = drop n_wrap_args arg_tys
final_body_ty = mkFunTys leftover_arg_tys body_ty
in
- mkWwBodies tyvars wrap_args final_body_ty demands `thenUs` \ (wrap_fn, _, _) ->
+ mkWwBodies tyvars wrap_args final_body_ty demands cpr_info `thenUs` \ (wrap_fn, _, _) ->
returnUs wrap_fn
\end{code}
\begin{code}
mkWwBodies :: [TyVar] -> [Id] -> Type -- Original fn args and body type
-> [Demand] -- Strictness info for original fn; corresp 1-1 with args
+ -> CprInfo -- Result of CPR analysis
-> UniqSM (Id -> CoreExpr, -- Wrapper body, lacking only the worker Id
CoreExpr -> CoreExpr, -- Worker body, lacking the original function body
[Demand]) -- Strictness info for worker
-mkWwBodies tyvars args body_ty demands
+mkWwBodies tyvars args body_ty demands cpr_info
| allAbsent demands &&
isUnLiftedType body_ty
= -- Horrid special case. If the worker would have no arguments, and the
\ body -> mkLams (tyvars ++ [void_arg]) body,
[WwLazy True])
-mkWwBodies tyvars wrap_args body_ty demands
+mkWwBodies tyvars wrap_args body_ty demands cpr_info
| otherwise
= let
- wrap_args_w_demands = zipWithEqual "mkWwBodies" setIdDemandInfo wrap_args demands
+ -- demands may be longer than number of args. If we aren't doing w/w
+ -- for strictness then demands is an infinite list of 'lazy' args.
+ wrap_args_w_demands = zipWith setIdDemandInfo wrap_args demands
in
mkWW wrap_args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
+ mkWWcpr body_ty cpr_info
+ `thenUs` \ (wrap_fn_w_cpr, work_fn_w_cpr) ->
returnUs (\ work_id -> mkLams tyvars $ mkLams wrap_args_w_demands $
- wrap_fn (mkTyApps (Var work_id) (mkTyVarTys tyvars)),
+ (wrap_fn_w_cpr . wrap_fn) (mkTyApps (Var work_id) (mkTyVarTys tyvars)),
\ body -> mkLams tyvars $ mkLams work_args_w_demands $
- work_fn body,
+ (work_fn_w_cpr . work_fn) body,
map getIdDemandInfo work_args_w_demands)
\end{code}
work_fn)
\end{code}
+@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
+info and adds in the CPR transformation. The worker returns an
+unboxed tuple containing non-CPR components. The wrapper takes this
+tuple and re-produces the correct structured output.
+
+The non-CPR results appear ordered in the unboxed tuple as if by a
+left-to-right traversal of the result structure.
+
+
+\begin{code}
+
+mkWWcpr :: Type -- function body type
+ -> CprInfo -- CPR analysis results
+ -> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
+ CoreExpr -> CoreExpr) -- New worker
+
+mkWWcpr body_ty NoCPRInfo
+ = returnUs (id, id) -- Must be just the strictness transf.
+mkWWcpr body_ty (CPRInfo cpr_args)
+ = getUniqueUs `thenUs` \ body_arg_uniq ->
+ let
+ body_var = mk_ww_local body_arg_uniq body_ty
+ in
+ cpr_reconstruct body_ty cpr_info' `thenUs` \reconst_fn ->
+ cpr_flatten body_ty cpr_info' `thenUs` \flatten_fn ->
+ returnUs (reconst_fn, flatten_fn)
+ -- We only make use of the outer level of CprInfo, otherwise we
+ -- may lose laziness. :-( Hopefully, we will find a use for the
+ -- extra info some day (e.g. creating versions specialized to
+ -- the use made of the components of the result by the callee)
+ where cpr_info' = CPRInfo (map (const NoCPRInfo) cpr_args)
+\end{code}
+
+
+@cpr_flatten@ takes the result type produced by the body and the info
+from the CPR analysis and flattens the constructed product components.
+These are returned in an unboxed tuple.
+
+\begin{code}
+
+cpr_flatten :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr)
+cpr_flatten ty cpr_info
+ = mk_cpr_case (ty, cpr_info) `thenUs` \(res_id, tup_ids, flatten_exp) ->
+ returnUs (\body -> Case body res_id
+ [(DEFAULT, [], flatten_exp (fst $ mk_unboxed_tuple tup_ids))])
+
+
+
+mk_cpr_case :: (Type, CprInfo) ->
+ UniqSM (CoreBndr, -- Name of binder for this part of result
+ [(CoreExpr, Type)], -- expressions for flattened result
+ CoreExpr -> CoreExpr) -- add in code to flatten result
+
+mk_cpr_case (ty, NoCPRInfo)
+ -- this component must be returned as a component of the unboxed tuple result
+ = getUniqueUs `thenUs` \id_uniq ->
+ let id_id = mk_ww_local id_uniq ty in
+ returnUs (id_id, [(Var id_id, ty)], id)
+mk_cpr_case (ty, cpr_info@(CPRInfo ci_args))
+ | isNewTyCon tycon -- a new type: under the coercions must be a
+ -- constructed product
+ = ASSERT ( null $ tail inst_con_arg_tys )
+ mk_cpr_case (head inst_con_arg_tys, cpr_info)
+ `thenUs` \(arg, tup, exp) ->
+ getUniqueUs `thenUs` \id_uniq ->
+ let id_id = mk_ww_local id_uniq ty
+ new_exp_case = \var -> Case (Note (Coerce (idType arg) ty) (Var id_id))
+ arg
+ [(DEFAULT,[], exp var)]
+ in
+ returnUs (id_id, tup, new_exp_case)
+
+ | otherwise -- a data type
+ -- flatten components
+ = mapUs mk_cpr_case (zip inst_con_arg_tys ci_args)
+ `thenUs` \sub_builds ->
+ getUniqueUs `thenUs` \id_uniq ->
+ let id_id = mk_ww_local id_uniq ty
+ (args, tup, exp) = unzip3 sub_builds
+ con_app = mkConApp data_con (map Var args)
+ new_tup = concat tup
+ new_exp_case = \var -> Case (Var id_id) (mkWildId ty)
+ [(DataCon data_con, args,
+ foldl (\e f -> f e) var exp)]
+ in
+ returnUs (id_id, new_tup, new_exp_case)
+ where
+ (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_case" ty
+
+\end{code}
+
+@cpr_reconstruct@ does the opposite of @cpr_flatten@. It takes the unboxed
+tuple produced by the worker and reconstructs the structured result.
+
+\begin{code}
+cpr_reconstruct :: Type -> CprInfo -> UniqSM (CoreExpr -> CoreExpr)
+cpr_reconstruct ty cpr_info
+ = mk_cpr_let (ty,cpr_info) `thenUs` \(res_id, tup_ids, reconstruct_exp) ->
+ returnUs (\worker -> Case worker (mkWildId $ worker_type tup_ids)
+ [(DataCon $ unboxedTupleCon $ length tup_ids,
+ tup_ids, reconstruct_exp $ Var res_id)])
+
+ where
+ worker_type ids = mkTyConApp (unboxedTupleTyCon (length ids)) (map idType ids)
+
+
+mk_cpr_let :: (Type, CprInfo) ->
+ UniqSM (CoreBndr, -- Binder for this component of result
+ [CoreBndr], -- Binders which will appear in worker's result
+ CoreExpr -> CoreExpr) -- Code to produce structured result.
+mk_cpr_let (ty, NoCPRInfo)
+ -- this component will appear explicitly in the unboxed tuple.
+ = getUniqueUs `thenUs` \id_uniq ->
+ let id_id = mk_ww_local id_uniq ty in
+ returnUs (id_id, [id_id], id)
+mk_cpr_let (ty, cpr_info@(CPRInfo ci_args))
+ | isNewTyCon tycon -- a new type: must coerce the argument to this type
+ = ASSERT ( null $ tail inst_con_arg_tys )
+ mk_cpr_let (head inst_con_arg_tys, cpr_info)
+ `thenUs` \(arg, tup, exp) ->
+ getUniqueUs `thenUs` \id_uniq ->
+ let id_id = mk_ww_local id_uniq ty
+ new_exp = \var -> exp (Let (NonRec id_id (Note (Coerce ty (idType arg)) (Var arg))) var)
+ in
+ returnUs (id_id, tup, new_exp)
+
+ | otherwise -- a data type
+ -- reconstruct components then apply data con
+ = mapUs mk_cpr_let (zip inst_con_arg_tys ci_args)
+ `thenUs` \sub_builds ->
+ getUniqueUs `thenUs` \id_uniq ->
+ let id_id = mk_ww_local id_uniq ty
+ (args, tup, exp) = unzip3 sub_builds
+ con_app = mkConApp data_con $ (map Type tycon_arg_tys) ++ (map Var args)
+ new_tup = concat tup
+ new_exp = \var -> foldl (\e f -> f e) (Let (NonRec id_id con_app) var) exp
+ in
+ returnUs (id_id, new_tup, new_exp)
+ where
+ (data_con, tycon, tycon_arg_tys, inst_con_arg_tys) = splitType "mk_cpr_let" ty
+
+splitType :: String -> Type -> (DataCon, TyCon, [Type], [Type])
+splitType fname ty = (data_con, tycon, tycon_arg_tys, dataConArgTys data_con tycon_arg_tys)
+ where
+ (data_con, tycon, tycon_arg_tys)
+ = case (splitAlgTyConApp_maybe ty) of
+ Just (arg_tycon, tycon_arg_tys, [data_con]) ->
+ -- The main event: a single-constructor data type
+ (data_con, arg_tycon, tycon_arg_tys)
+
+ Just (_, _, data_cons) ->
+ pprPanic (fname ++ ":")
+ (text "not one constr (interface files not consistent/up to date?)"
+ $$ ppr ty)
+
+ Nothing ->
+ pprPanic (fname ++ ":")
+ (text "not a datatype" $$ ppr ty)
+
+
+\end{code}
%************************************************************************
%* *
mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
+
+
+mk_unboxed_tuple :: [(CoreExpr, Type)] -> (CoreExpr, Type)
+mk_unboxed_tuple contents
+ = (mkConApp (unboxedTupleCon (length contents))
+ (map (Type . snd) contents ++
+ map fst contents),
+ mkTyConApp (unboxedTupleTyCon (length contents))
+ (map snd contents))
+
+
\end{code}
tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info)
tcPrag info (HsNoCafRefs) = returnTc (NoCafRefs `setCafInfo` info)
+ tcPrag info (HsCprInfo cpr_info) = returnTc (cpr_info `setCprInfo` info)
tcPrag info (HsUnfold inline_prag maybe_expr)
= (case maybe_expr of
\begin{code}
tcStrictness unf_env ty info (HsStrictnessInfo (demands, bot_result) maybe_worker)
= tcWorker unf_env maybe_worker `thenNF_Tc` \ maybe_worker_id ->
- uniqSMToTcM (mkWrapper ty demands) `thenNF_Tc` \ wrap_fn ->
+ -- We are relying here on cpr info always appearing before strictness info
+ -- fingers crossed ....
+ uniqSMToTcM (mkWrapper ty demands (cprInfo info))
+ `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on maybe_worker_id too eagerly!
info' = case maybe_worker_id of
Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
+ setWorkerInfo (Just worker_id) $
setInlinePragInfo IWantToBeINLINEd info
Nothing -> info
has_worker = maybeToBool maybe_worker_id
in
- returnTc (StrictnessInfo demands bot_result has_worker `setStrictnessInfo` info')
+ returnTc (StrictnessInfo demands bot_result `setStrictnessInfo` info')
\end{code}
\begin{code}
']',
'-fstrictness',
+ '-fworker-wrapper',
'-fsimplify',
'[',
projects / ghc-hetmet.git / commitdiff