From 30b5b5cceb167a87907d4cf122e77ce333fc5066 Mon Sep 17 00:00:00 2001 From: kglynn Date: Tue, 13 Apr 1999 08:55:54 +0000 Subject: [PATCH] [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. --- ghc/compiler/Makefile | 4 +- ghc/compiler/basicTypes/Id.lhs | 29 ++++- ghc/compiler/basicTypes/IdInfo.lhs | 146 +++++++++++++++++++---- ghc/compiler/coreSyn/PprCore.lhs | 5 +- ghc/compiler/hsSyn/HsDecls.lhs | 3 +- ghc/compiler/main/CmdLineOpts.lhs | 10 +- ghc/compiler/main/MkIface.lhs | 17 ++- ghc/compiler/prelude/PrelVals.lhs | 2 +- ghc/compiler/reader/Lex.lhs | 26 +++- ghc/compiler/rename/ParseIface.y | 4 +- ghc/compiler/rename/RnSource.lhs | 1 + ghc/compiler/simplCore/SimplCore.lhs | 9 +- ghc/compiler/simplCore/Simplify.lhs | 2 +- ghc/compiler/stranal/SaLib.lhs | 2 +- ghc/compiler/stranal/StrictAnal.lhs | 22 ++-- ghc/compiler/stranal/WorkWrap.lhs | 139 +++++++++++++++++----- ghc/compiler/stranal/WwLib.lhs | 210 +++++++++++++++++++++++++++++++-- ghc/compiler/typecheck/TcIfaceSig.lhs | 9 +- ghc/driver/ghc.lprl | 1 + 19 files changed, 543 insertions(+), 98 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 63dfbbe..48401c6 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $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) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index f5bff89..6dec041 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -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} @@ -237,6 +245,14 @@ 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 getIdUnfolding id = unfoldingInfo (idInfo id) @@ -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} diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index f486614..83138ea 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -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} + + + diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 3da38c2..9972096 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -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} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index fe026da..adefae8 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 87b8939..4f8d893 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -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) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 088de6a..ea3f81c 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -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 diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 132b453..f183292 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -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 diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index 74ab14a..a8595e3 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -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 diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index aac197f..4b48681 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -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 diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 498d309..8e2e660 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -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' -> diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index dfd9ac5..62d67a8 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -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 diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 4f5699e..f05373f 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -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 diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index 9135e87..1a057b6 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -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 diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 3382bec..67872b9 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -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 diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 8f50283..bac9ff5 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -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 ) 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 @@ -30,19 +32,53 @@ import WwLib 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 @@ -176,8 +212,7 @@ tryWW non_rec fn_id rhs -- 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 @@ -186,32 +221,53 @@ tryWW non_rec fn_id rhs 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 @@ -219,18 +275,41 @@ tryWW non_rec fn_id rhs -- snaffles out (a) the worker Id and (b) constructors needed to -- make the wrapper. -- These are needed when we write an interface file. + +-- - 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 diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 93de682..95007d6 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -14,21 +14,27 @@ module WwLib ( #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} @@ -227,9 +233,10 @@ the function and the name of its worker, and we want to make its body (the wrapp \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 @@ -249,7 +256,7 @@ mkWrapper fun_ty demands 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} @@ -258,11 +265,12 @@ mkWrapper fun_ty demands \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 @@ -282,17 +290,21 @@ mkWwBodies tyvars args body_ty demands \ 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} @@ -363,6 +375,167 @@ mkWW (arg : ds) 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} %************************************************************************ %* * @@ -406,4 +579,15 @@ mk_pk_let DataType arg boxing_con con_tys unpk_args body 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} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 9500baf..df77454 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -88,6 +88,7 @@ tcIdInfo unf_env name ty info info_ins 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 @@ -135,18 +136,22 @@ tcIdInfo unf_env name ty info info_ins \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} diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index eb9f967..e72ae94 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -873,6 +873,7 @@ sub setupOptimiseFlags { ']', '-fstrictness', + '-fworker-wrapper', '-fsimplify', '[', -- 1.7.10.4