From f6cd95ff9a2bddbd78682dcd9287aec7d152cc13 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 23 Jul 2001 10:54:50 +0000 Subject: [PATCH] [project @ 2001-07-23 10:54:46 by simonpj] --------------------------------- Switch to the new demand analyser --------------------------------- This commit makes the new demand analyser the main beast, with the old strictness analyser as a backup. When DEBUG is on, the old strictness analyser is run too, and the results compared. WARNING: this isn't thorougly tested yet, so expect glitches. Delay updating for a few days if the HEAD is mission critical for you. But do try it out. I'm away for 2.5 weeks from Thursday, so it would be good to shake out any glaring bugs before then. --- ghc/compiler/basicTypes/BasicTypes.lhs | 33 +++- ghc/compiler/basicTypes/DataCon.lhs | 13 +- ghc/compiler/basicTypes/Demand.lhs | 30 ---- ghc/compiler/basicTypes/Id.lhs | 68 +++++-- ghc/compiler/basicTypes/IdInfo.lhs | 69 +++---- ghc/compiler/basicTypes/MkId.lhs | 59 +++--- ghc/compiler/basicTypes/NewDemand.lhs | 137 ++++++++++---- ghc/compiler/coreSyn/CorePrep.lhs | 25 ++- ghc/compiler/coreSyn/CoreTidy.lhs | 18 +- ghc/compiler/coreSyn/CoreUtils.lhs | 6 +- ghc/compiler/cprAnalysis/CprAnalyse.lhs | 6 + ghc/compiler/hsSyn/HsCore.lhs | 10 +- ghc/compiler/hsSyn/HsDecls.lhs | 3 +- ghc/compiler/main/CmdLineOpts.lhs | 3 + ghc/compiler/main/MkIface.lhs | 13 +- ghc/compiler/parser/Lex.lhs | 38 ++-- ghc/compiler/parser/Parser.y | 5 +- ghc/compiler/prelude/TysWiredIn.lhs | 3 +- ghc/compiler/rename/ParseIface.y | 7 +- ghc/compiler/rename/RnSource.lhs | 5 +- ghc/compiler/simplCore/SimplUtils.lhs | 14 +- ghc/compiler/simplCore/Simplify.lhs | 18 +- ghc/compiler/stranal/DmdAnal.lhs | 199 ++++++++++----------- ghc/compiler/stranal/SaAbsInt.lhs | 7 +- ghc/compiler/stranal/SaLib.lhs | 6 + ghc/compiler/stranal/StrictAnal.lhs | 6 + ghc/compiler/stranal/WorkWrap.lhs | 150 ++++++++-------- ghc/compiler/stranal/WwLib.lhs | 296 ++++++++++--------------------- ghc/compiler/typecheck/TcClassDcl.lhs | 3 +- ghc/compiler/typecheck/TcExpr.lhs | 4 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 18 +- 31 files changed, 647 insertions(+), 625 deletions(-) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 820a3b9..0f7a462 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -36,7 +36,9 @@ module BasicTypes( InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, - EP(..) + EP(..), + + StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) where #include "HsVersions.h" @@ -304,3 +306,32 @@ instance Show OccInfo where showsPrec p occ = showsPrecSDoc p (ppr occ) \end{code} +%************************************************************************ +%* * +\subsection{Strictness indication} +%* * +%************************************************************************ + +The strictness annotations on types in data type declarations +e.g. data T = MkT !Int !(Bool,Bool) + +\begin{code} +data StrictnessMark + = MarkedUserStrict -- "!" in a source decl + | MarkedStrict -- "!" in an interface decl: strict but not unboxed + | MarkedUnboxed -- "!!" in an interface decl: unboxed + | NotMarkedStrict -- No annotation at all + deriving( Eq ) + +isMarkedUnboxed MarkedUnboxed = True +isMarkedUnboxed other = False + +isMarkedStrict NotMarkedStrict = False +isMarkedStrict other = True -- All others are strict + +instance Outputable StrictnessMark where + ppr MarkedUserStrict = ptext SLIT("!u") + ppr MarkedStrict = ptext SLIT("!") + ppr MarkedUnboxed = ptext SLIT("! !") + ppr NotMarkedStrict = empty +\end{code} diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index f20fd52..44126b8 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -36,8 +36,8 @@ import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique ) import Var ( TyVar, Id ) import FieldLabel ( FieldLabel ) -import BasicTypes ( Arity ) -import Demand ( Demand, StrictnessMark(..), wwStrict, wwLazy ) +import BasicTypes ( Arity, StrictnessMark(..) ) +import NewDemand ( Demand, lazyDmd, seqDmd ) import Outputable import Unique ( Unique, Uniquable(..) ) import CmdLineOpts ( opt_UnboxStrictFields ) @@ -443,15 +443,14 @@ chooseBoxingStrategy tycon arg_ty strict Just (arg_tycon, _) -> isProductTyCon arg_tycon unbox_strict_arg_ty - :: StrictnessMark -- After strategy choice; can't be MkaredUserStrict + :: StrictnessMark -- After strategy choice; can't be MarkedUserStrict -> Type -- Source argument type -> [(Demand,Type)] -- Representation argument types and demamds -unbox_strict_arg_ty NotMarkedStrict ty = [(wwLazy, ty)] -unbox_strict_arg_ty MarkedStrict ty = [(wwStrict, ty)] +unbox_strict_arg_ty NotMarkedStrict ty = [(lazyDmd, ty)] +unbox_strict_arg_ty MarkedStrict ty = [(seqDmd, ty)] unbox_strict_arg_ty MarkedUnboxed ty = zipEqual "unbox_strict_arg_ty" (dataConRepStrictness arg_data_con) arg_tys where - (_, _, arg_data_con, arg_tys) - = splitProductType "unbox_strict_arg_ty" (repType ty) + (_, _, arg_data_con, arg_tys) = splitProductType "unbox_strict_arg_ty" (repType ty) \end{code} diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index f42e1d7..b39ad98 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -18,7 +18,6 @@ module Demand( ppStrictnessInfo, seqStrictnessInfo, isBottomingStrictness, appIsBottom, - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) where #include "HsVersions.h" @@ -200,34 +199,5 @@ ppStrictnessInfo (StrictnessInfo wrapper_args bot) = hsep [pprDemands wrapper_ar \end{code} -%************************************************************************ -%* * -\subsection{Strictness indication} -%* * -%************************************************************************ - -The strictness annotations on types in data type declarations -e.g. data T = MkT !Int !(Bool,Bool) - -\begin{code} -data StrictnessMark - = MarkedUserStrict -- "!" in a source decl - | MarkedStrict -- "!" in an interface decl: strict but not unboxed - | MarkedUnboxed -- "!!" in an interface decl: unboxed - | NotMarkedStrict -- No annotation at all - deriving( Eq ) - -isMarkedUnboxed MarkedUnboxed = True -isMarkedUnboxed other = False - -isMarkedStrict NotMarkedStrict = False -isMarkedStrict other = True -- All others are strict - -instance Outputable StrictnessMark where - ppr MarkedUserStrict = ptext SLIT("!u") - ppr MarkedStrict = ptext SLIT("!") - ppr MarkedUnboxed = ptext SLIT("! !") - ppr NotMarkedStrict = empty -\end{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 448ed01..0586195 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -44,8 +44,8 @@ module Id ( -- IdInfo stuff setIdUnfolding, setIdArityInfo, - setIdDemandInfo, - setIdStrictness, + setIdDemandInfo, setIdNewDemandInfo, + setIdStrictness, setIdNewStrictness, setIdTyGenInfo, setIdWorkerInfo, setIdSpecialisation, @@ -54,8 +54,8 @@ module Id ( setIdOccInfo, idArity, idArityInfo, - idDemandInfo, - idStrictness, + idDemandInfo, idNewDemandInfo, + idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness, idTyGenInfo, idWorkerInfo, idUnfolding, @@ -67,6 +67,8 @@ module Id ( idLBVarInfo, idOccInfo, + newStrictnessFromOld -- Temporary + ) where #include "HsVersions.h" @@ -88,7 +90,10 @@ import Type ( Type, typePrimRep, addFreeTyVars, import IdInfo -import Demand ( Demand ) +import qualified Demand ( Demand ) +import NewDemand ( Demand, DmdResult(..), StrictSig, topSig, isBotRes, + isBottomingSig, splitStrictSig, strictSigResInfo + ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, getOccName, getSrcLoc @@ -97,6 +102,7 @@ import OccName ( UserFS, mkWorkerOcc ) import PrimRep ( PrimRep ) import TysPrim ( statePrimTyCon ) import FieldLabel ( FieldLabel ) +import Maybes ( orElse ) import SrcLoc ( SrcLoc ) import Outputable import Unique ( Unique, mkBuiltinUnique ) @@ -105,6 +111,8 @@ infixl 1 `setIdUnfolding`, `setIdArityInfo`, `setIdDemandInfo`, `setIdStrictness`, + `setIdNewDemandInfo`, + `setIdNewStrictness`, `setIdTyGenInfo`, `setIdWorkerInfo`, `setIdSpecialisation`, @@ -311,16 +319,43 @@ setIdArityInfo :: Id -> Arity -> Id setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id --------------------------------- - -- STRICTNESS + -- STRICTNESS idStrictness :: Id -> StrictnessInfo -idStrictness id = strictnessInfo (idInfo id) +idStrictness id = case strictnessInfo (idInfo id) of + NoStrictnessInfo -> case idNewStrictness_maybe id of + Just sig -> oldStrictnessFromNew sig + Nothing -> NoStrictnessInfo + strictness -> strictness setIdStrictness :: Id -> StrictnessInfo -> Id setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id -- isBottomingId returns true if an application to n args would diverge isBottomingId :: Id -> Bool -isBottomingId id = isBottomingStrictness (idStrictness id) +isBottomingId id = isBottomingSig (idNewStrictness id) + +idNewStrictness_maybe :: Id -> Maybe StrictSig +idNewStrictness :: Id -> StrictSig + +idNewStrictness_maybe id = newStrictnessInfo (idInfo id) +idNewStrictness id = idNewStrictness_maybe id `orElse` topSig + +getNewStrictness :: Id -> StrictSig +-- First tries the "new-strictness" field, and then +-- reverts to the old one. This is just until we have +-- cross-module info for new strictness +getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id + +newStrictnessFromOld :: Id -> StrictSig +newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id) + +oldStrictnessFromNew :: StrictSig -> StrictnessInfo +oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) + where + (dmds, res_info) = splitStrictSig sig + +setIdNewStrictness :: Id -> StrictSig -> Id +setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id --------------------------------- -- TYPE GENERALISATION @@ -348,12 +383,18 @@ setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id --------------------------------- -- DEMAND -idDemandInfo :: Id -> Demand +idDemandInfo :: Id -> Demand.Demand idDemandInfo id = demandInfo (idInfo id) -setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo :: Id -> Demand.Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id +idNewDemandInfo :: Id -> NewDemand.Demand +idNewDemandInfo id = newDemandInfo (idInfo id) + +setIdNewDemandInfo :: Id -> NewDemand.Demand -> Id +setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id + --------------------------------- -- SPECIALISATION idSpecialisation :: Id -> CoreRules @@ -383,14 +424,17 @@ idCafInfo id = cgCafInfo (idCgInfo id) --------------------------------- -- CG ARITY - idCgArity :: Id -> Arity idCgArity id = cgArity (idCgInfo id) --------------------------------- -- CPR INFO idCprInfo :: Id -> CprInfo -idCprInfo id = cprInfo (idInfo id) +idCprInfo id = case cprInfo (idInfo id) of + NoCPRInfo -> case strictSigResInfo (idNewStrictness id) of + RetCPR -> ReturnsCPR + other -> NoCPRInfo + ReturnsCPR -> ReturnsCPR setIdCprInfo :: Id -> CprInfo -> Id setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 27919e5..52a3d5f 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -19,13 +19,13 @@ module IdInfo ( shortableIdInfo, copyIdInfo, -- Arity - ArityInfo(..), + ArityInfo, exactArity, unknownArity, hasArity, arityInfo, setArityInfo, ppArityInfo, arityLowerBound, -- New demand and strictness info newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, newDemand, + newDemandInfo, setNewDemandInfo, newDemand, oldDemand, -- Strictness; imported from Demand StrictnessInfo(..), @@ -95,8 +95,12 @@ import DataCon ( DataCon ) import ForeignCall ( ForeignCall ) import FieldLabel ( FieldLabel ) import Type ( usOnce, usMany ) -import Demand -- Lots of stuff -import qualified NewDemand +import Demand hiding( Demand ) +import NewDemand ( Demand(..), Keepity(..), Deferredness(..), DmdResult(..), + lazyDmd, topDmd, + StrictSig, mkStrictSig, + DmdType, mkTopDmdType + ) import Outputable import Util ( seqList ) import List ( replicate ) @@ -129,30 +133,35 @@ infixl 1 `setDemandInfo`, To be removed later \begin{code} -mkNewStrictnessInfo :: Id -> Arity -> StrictnessInfo -> CprInfo -> NewDemand.StrictSig -mkNewStrictnessInfo id arity NoStrictnessInfo cpr - = NewDemand.mkStrictSig id - arity - (NewDemand.mkTopDmdType (replicate arity NewDemand.Lazy) (newRes False cpr)) - -mkNewStrictnessInfo id arity (StrictnessInfo ds res) cpr - = NewDemand.mkStrictSig id - arity - (NewDemand.mkTopDmdType (take arity (map newDemand ds)) (newRes res cpr)) +mkNewStrictnessInfo :: Id -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig +mkNewStrictnessInfo id arity Demand.NoStrictnessInfo cpr + = mkStrictSig id arity $ + mkTopDmdType (replicate arity lazyDmd) (newRes False cpr) + +mkNewStrictnessInfo id arity (Demand.StrictnessInfo ds res) cpr + = mkStrictSig id arity $ + mkTopDmdType (take arity (map newDemand ds)) (newRes res cpr) -- Sometimes the old strictness analyser has more -- demands than the arity justifies -newRes True _ = NewDemand.BotRes -newRes False ReturnsCPR = NewDemand.RetCPR -newRes False NoCPRInfo = NewDemand.TopRes - -newDemand :: Demand -> NewDemand.Demand -newDemand (WwLazy True) = NewDemand.Abs -newDemand (WwLazy False) = NewDemand.Lazy -newDemand WwStrict = NewDemand.Eval -newDemand (WwUnpack unpk ds) = NewDemand.Seq NewDemand.Drop NewDemand.Now (map newDemand ds) -newDemand WwPrim = NewDemand.Lazy -newDemand WwEnum = NewDemand.Eval +newRes True _ = BotRes +newRes False ReturnsCPR = RetCPR +newRes False NoCPRInfo = TopRes + +newDemand :: Demand.Demand -> NewDemand.Demand +newDemand (WwLazy True) = Abs +newDemand (WwLazy False) = Lazy +newDemand WwStrict = Eval +newDemand (WwUnpack unpk ds) = Seq Drop Now (map newDemand ds) +newDemand WwPrim = Lazy +newDemand WwEnum = Eval + +oldDemand :: NewDemand.Demand -> Demand.Demand +oldDemand Abs = WwLazy True +oldDemand Lazy = WwLazy False +oldDemand Eval = WwStrict +oldDemand (Seq _ _ ds) = WwUnpack True (map oldDemand ds) +oldDemand (Call _) = WwStrict \end{code} @@ -219,7 +228,7 @@ case. KSW 1999-04). data IdInfo = IdInfo { arityInfo :: ArityInfo, -- Its arity - demandInfo :: Demand, -- Whether or not it is definitely demanded + demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded specInfo :: CoreRules, -- Specialisations of this function which exist tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id strictnessInfo :: StrictnessInfo, -- Strictness properties @@ -231,8 +240,8 @@ data IdInfo inlinePragInfo :: InlinePragInfo, -- Inline pragma occInfo :: OccInfo, -- How it occurs - newStrictnessInfo :: Maybe NewDemand.StrictSig, - newDemandInfo :: NewDemand.Demand + newStrictnessInfo :: Maybe StrictSig, + newDemandInfo :: Demand } seqIdInfo :: IdInfo -> () @@ -295,7 +304,7 @@ setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } setNewDemandInfo info dd = info { newDemandInfo = dd } -setNewStrictnessInfo info dd = info { newStrictnessInfo = Just dd } +setNewStrictnessInfo info dd = info { newStrictnessInfo = dd } \end{code} @@ -315,7 +324,7 @@ vanillaIdInfo lbvarInfo = NoLBVarInfo, inlinePragInfo = NoInlinePragInfo, occInfo = NoOccInfo, - newDemandInfo = NewDemand.topDmd, + newDemandInfo = topDmd, newStrictnessInfo = Nothing } diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 69dec38..b3c6be3 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -31,7 +31,7 @@ module MkId ( #include "HsVersions.h" -import BasicTypes ( Arity ) +import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, intPrimTy, realWorldStatePrimTy ) @@ -58,8 +58,6 @@ import Name ( mkWiredInName, mkFCallName, Name ) import OccName ( mkVarOcc ) import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName ) import ForeignCall ( ForeignCall ) -import Demand ( wwStrict, wwPrim, mkStrictnessInfo, noStrictnessInfo, - StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) import DataCon ( DataCon, dataConFieldLabels, dataConRepArity, dataConTyCon, dataConArgTys, dataConRepType, dataConRepStrictness, @@ -70,16 +68,17 @@ import DataCon ( DataCon, ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkTemplateLocals, mkTemplateLocalsNum, - mkTemplateLocal, idCprInfo, idName + mkTemplateLocal, idNewStrictness, idName ) import IdInfo ( IdInfo, noCafNoTyGenIdInfo, exactArity, setUnfoldingInfo, setCprInfo, setArityInfo, setSpecInfo, setCgInfo, - setStrictnessInfo, mkNewStrictnessInfo, setNewStrictnessInfo, GlobalIdDetails(..), CafInfo(..), CprInfo(..), CgInfo(..), setCgArity ) +import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), + mkTopDmdType, topDmd, evalDmd ) import FieldLabel ( mkFieldLabel, fieldLabelName, firstFieldLabelTag, allFieldLabelTags, fieldLabelType ) @@ -143,22 +142,20 @@ mkDataConId work_name data_con where id = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info info = noCafNoTyGenIdInfo - `setCgArity` arity - `setArityInfo` arity - `setCprInfo` cpr_info - `setStrictnessInfo` strict_info - `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info cpr_info + `setCgArity` arity + `setArityInfo` arity + `setNewStrictnessInfo` Just strict_sig arity = dataConRepArity data_con - strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False) + strict_sig = mkStrictSig id arity (mkTopDmdType (dataConRepStrictness data_con) cpr_info) tycon = dataConTyCon data_con cpr_info | isProductTyCon tycon && isDataTyCon tycon && arity > 0 && - arity <= mAX_CPR_SIZE = ReturnsCPR - | otherwise = NoCPRInfo - -- ReturnsCPR is only true for products that are real data types; + arity <= mAX_CPR_SIZE = RetCPR + | otherwise = TopRes + -- RetCPR is only true for products that are real data types; -- that is, not unboxed tuples or [non-recursive] newtypes mAX_CPR_SIZE :: Arity @@ -219,21 +216,23 @@ mkDataConWrapId data_con info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs) - `setCprInfo` cpr_info - -- The Cpr info can be important inside INLINE rhss, where the - -- wrapper constructor isn't inlined `setCgArity` arity -- The NoCaf-ness is set by noCafNoTyGenIdInfo `setArityInfo` arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setNewStrictnessInfo` mkNewStrictnessInfo wrap_id arity noStrictnessInfo cpr_info + `setNewStrictnessInfo` Just wrap_sig wrap_ty = mkForAllTys all_tyvars $ mkFunTys all_arg_tys result_ty - cpr_info = idCprInfo work_id + res_info = strictSigResInfo (idNewStrictness work_id) + wrap_sig = mkStrictSig wrap_id arity (mkTopDmdType (replicate arity topDmd) res_info) + -- The Cpr info can be important inside INLINE rhss, where the + -- wrapper constructor isn't inlined + -- But we are sloppy about the argument demands, because we expect + -- to inline the constructor very vigorously. wrap_rhs | isNewTyCon tycon = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 ) @@ -606,8 +605,8 @@ mkPrimOpId prim_op `setSpecInfo` rules `setCgArity` arity `setArityInfo` arity - `setStrictnessInfo` strict_info - `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo + `setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo) + -- Until we modify the primop generation code rules = maybe emptyCoreRules (addRule emptyCoreRules id) (primOpRule prim_op) @@ -637,15 +636,14 @@ mkFCallId uniq fcall ty name = mkFCallName uniq occ_str info = noCafNoTyGenIdInfo - `setCgArity` arity - `setArityInfo` arity - `setStrictnessInfo` strict_info - `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo + `setCgArity` arity + `setArityInfo` arity + `setNewStrictnessInfo` Just strict_sig (_, tau) = tcSplitForAllTys ty (arg_tys, _) = tcSplitFunTys tau arity = length arg_tys - strict_info = mkStrictnessInfo (take arity (repeat wwPrim), False) + strict_sig = mkStrictSig id arity (mkTopDmdType (replicate arity evalDmd) TopRes) \end{code} @@ -838,12 +836,9 @@ pc_bottoming_Id key mod name ty = id where id = pcMiscPrelId key mod name ty bottoming_info - strict_info = mkStrictnessInfo ([wwStrict], True) - bottoming_info = noCafNoTyGenIdInfo - `setStrictnessInfo` strict_info - `setNewStrictnessInfo` mkNewStrictnessInfo id 1 strict_info NoCPRInfo - - + arity = 1 + strict_sig = mkStrictSig id arity (mkTopDmdType [evalDmd] BotRes) + bottoming_info = noCafNoTyGenIdInfo `setNewStrictnessInfo` Just strict_sig -- these "bottom" out, no matter what their arguments generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs index 1cd59ef..94d4aa2 100644 --- a/ghc/compiler/basicTypes/NewDemand.lhs +++ b/ghc/compiler/basicTypes/NewDemand.lhs @@ -5,11 +5,17 @@ \begin{code} module NewDemand( - Demand(..), Keepity(..), Deferredness(..), topDmd, - StrictSig(..), topSig, botSig, mkStrictSig, - DmdType(..), topDmdType, mkDmdType, mkTopDmdType, + Demand(..), Keepity(..), Deferredness(..), + topDmd, lazyDmd, seqDmd, evalDmd, isStrictDmd, + + DmdType(..), topDmdType, mkDmdType, mkTopDmdType, + dmdTypeDepth, dmdTypeRes, DmdEnv, emptyDmdEnv, - DmdResult(..), isBotRes + DmdResult(..), isBotRes, returnsCPR, + + StrictSig(..), mkStrictSig, topSig, botSig, + splitStrictSig, strictSigResInfo, + pprIfaceStrictSig, appIsBottom, isBottomingSig ) where #include "HsVersions.h" @@ -25,31 +31,6 @@ import Outputable %************************************************************************ %* * -\subsection{Strictness signatures -%* * -%************************************************************************ - -\begin{code} -data StrictSig = StrictSig Arity DmdType - deriving( Eq ) - -- Equality needed when comparing strictness - -- signatures for fixpoint finding - -topSig = StrictSig 0 topDmdType -botSig = StrictSig 0 botDmdType - -mkStrictSig :: Id -> Arity -> DmdType -> StrictSig -mkStrictSig id arity ty - = WARN( arity /= dmdTypeDepth ty, ppr id <+> (ppr arity $$ ppr ty) ) - StrictSig arity ty - -instance Outputable StrictSig where - ppr (StrictSig arity ty) = ppr ty -\end{code} - - -%************************************************************************ -%* * \subsection{Demand types} %* * %************************************************************************ @@ -71,7 +52,9 @@ type DmdEnv = VarEnv Demand data DmdResult = TopRes -- Nothing known | RetCPR -- Returns a constructed product | BotRes -- Diverges or errors - deriving( Eq ) + deriving( Eq, Show ) + -- Equality for fixpoints + -- Show needed for Show in Lex.Token (sigh) -- Equality needed for fixpoints in DmdAnal instance Eq DmdType where @@ -88,7 +71,7 @@ instance Outputable DmdType where pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd instance Outputable DmdResult where - ppr TopRes = char 'T' + ppr TopRes = empty ppr RetCPR = char 'M' ppr BotRes = char 'X' @@ -100,6 +83,10 @@ isBotRes :: DmdResult -> Bool isBotRes BotRes = True isBotRes other = False +returnsCPR :: DmdResult -> Bool +returnsCPR RetCPR = True +returnsCPR other = False + mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType mkDmdType fv ds res = DmdType fv ds res @@ -108,11 +95,83 @@ mkTopDmdType ds res = DmdType emptyDmdEnv ds res dmdTypeDepth :: DmdType -> Arity dmdTypeDepth (DmdType _ ds _) = length ds + +dmdTypeRes :: DmdType -> DmdResult +dmdTypeRes (DmdType _ _ res_ty) = res_ty \end{code} %************************************************************************ %* * +\subsection{Strictness signature +%* * +%************************************************************************ + +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand transfomer, +namely + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. + +For example, the demand transformer described by the DmdType + DmdType {x -> U(LL)} [V,A] Top +says that when the function is applied to two arguments, it +unleashes demand U(LL) on the free var x, V on the first arg, +and A on the second. + +If this same function is applied to one arg, all we can say is +that it uses x with U*(LL), and its arg with demand L. + +\begin{code} +newtype StrictSig = StrictSig DmdType + deriving( Eq ) + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +instance Show StrictSig where + show (StrictSig ty) = showSDoc (ppr ty) + +mkStrictSig :: Id -> Arity -> DmdType -> StrictSig +mkStrictSig id arity dmd_ty + = WARN( arity /= dmdTypeDepth dmd_ty, ppr id <+> (ppr arity $$ ppr dmd_ty) ) + StrictSig dmd_ty + +splitStrictSig :: StrictSig -> ([Demand], DmdResult) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +strictSigResInfo :: StrictSig -> DmdResult +strictSigResInfo (StrictSig (DmdType _ _ res)) = res + +topSig = StrictSig topDmdType +botSig = StrictSig botDmdType + +-- appIsBottom returns true if an application to n args would diverge +appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds +appIsBottom _ _ = False + +isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True +isBottomingSig _ = False + +pprIfaceStrictSig :: StrictSig -> SDoc +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res +\end{code} + + +%************************************************************************ +%* * \subsection{Demands} %* * %************************************************************************ @@ -138,8 +197,19 @@ data Deferredness = Now | Defer data Keepity = Keep | Drop deriving( Eq ) -topDmd :: Demand -- The most uninformative demand -topDmd = Lazy +topDmd, lazyDmd, seqDmd :: Demand +topDmd = Lazy -- The most uninformative demand +lazyDmd = Lazy +seqDmd = Seq Keep Now [] -- Polymorphic seq demand +evalDmd = Eval + +isStrictDmd :: Demand -> Bool +isStrictDmd Bot = True +isStrictDmd Err = True +isStrictDmd (Seq _ Now _) = True +isStrictDmd Eval = True +isStrictDmd (Call _) = True +isStrictDmd other = False instance Outputable Demand where ppr Lazy = char 'L' @@ -148,6 +218,7 @@ instance Outputable Demand where ppr Err = char 'X' ppr Bot = char 'B' ppr (Call d) = char 'C' <> parens (ppr d) + ppr (Seq k l []) = ppr k <> ppr l ppr (Seq k l ds) = ppr k <> ppr l <> parens (hcat (map ppr ds)) instance Outputable Deferredness where diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index f61c2d0..7d6cc24 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -17,14 +17,14 @@ import CoreSyn import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, isUnLiftedType, isUnboxedTupleType, repType, uaUTy, usOnce, usMany, eqUsage, seqType ) -import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) ) +import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) import PrimOp ( PrimOp(..) ) import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv -import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity, +import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdType, isPrimOpId_maybe, isFCallId, isLocalId, - hasNoBinding + hasNoBinding, idNewStrictness ) import HscTypes ( ModDetails(..) ) import UniqSupply @@ -284,8 +284,8 @@ corePrepExprFloat env expr@(App _ _) = collect_args fun (depth+1) `thenUs` \ (fun',hd,fun_ty,floats,ss) -> let (ss1, ss_rest) = case ss of - (ss1:ss_rest) -> (ss1, ss_rest) - [] -> (wwLazy, []) + (ss1:ss_rest) -> (ss1, ss_rest) + [] -> (lazyDmd, []) (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $ splitFunTy_maybe fun_ty in @@ -297,11 +297,10 @@ corePrepExprFloat env expr@(App _ _) let v2 = lookupVarEnv env v1 `orElse` v1 in returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts) where - stricts = case idStrictness v of - StrictnessInfo demands _ + stricts = case idNewStrictness v of + StrictSig (DmdType _ demands _) | depth >= length demands -> demands | otherwise -> [] - other -> [] -- If depth < length demands, then we have too few args to -- satisfy strictness info so we have to ignore all the -- strictness info, e.g. + (error "urk") @@ -381,7 +380,7 @@ mkNonRec bndr dem floats rhs -- because floating the case would make it evaluated too early returnUs (floats `snocOL` FloatLet (NonRec bndr rhs)) - | isUnLiftedType bndr_rep_ty || isStrictDem dem + | isUnLiftedType bndr_rep_ty || isStrict dem -- It's a strict let, or the binder is unlifted, -- so we definitely float all the bindings = ASSERT( not (isUnboxedTupleType bndr_rep_ty) ) @@ -519,15 +518,15 @@ mkCase scrut bndr alts = Case scrut bndr alts \begin{code} data RhsDemand - = RhsDemand { isStrictDem :: Bool, -- True => used at least once + = RhsDemand { isStrict :: Bool, -- True => used at least once isOnceDem :: Bool -- True => used at most once } mkDem :: Demand -> Bool -> RhsDemand -mkDem strict once = RhsDemand (isStrict strict) once +mkDem strict once = RhsDemand (isStrictDmd strict) once mkDemTy :: Demand -> Type -> RhsDemand -mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty) +mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty) isOnceTy :: Type -> Bool isOnceTy ty @@ -543,7 +542,7 @@ isOnceTy ty | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany bdrDem :: Id -> RhsDemand -bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id)) +bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id)) safeDem, onceDem :: RhsDemand safeDem = RhsDemand False False -- always safe to use this diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index d7ab114..d0234ce 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -25,6 +25,7 @@ import Id ( idType, idInfo, idName, isExportedId, setIdUnfolding, hasNoBinding, mkUserLocal ) import IdInfo {- loads of stuff -} +import NewDemand ( isBottomingSig, topSig ) import Name ( getOccName, nameOccName, globaliseName, setNameOcc, localiseName, isGlobalName, setNameUnique ) @@ -306,7 +307,7 @@ addExternal (id,rhs) needed idinfo = idInfo id dont_inline = isNeverInlinePrag (inlinePragInfo idinfo) loop_breaker = isLoopBreaker (occInfo idinfo) - bottoming_fn = isBottomingStrictness (strictnessInfo idinfo) + bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = rulesRhsFreeVars (specInfo idinfo) worker_info = workerInfo idinfo @@ -465,18 +466,17 @@ tidyIdInfo tidy_env is_external unfold_info cg_info id | opt_OmitInterfacePragmas || not is_external -- No IdInfo if the Id isn't external, or if we don't have -O = vanillaIdInfo - `setCgInfo` cg_info - `setStrictnessInfo` strictnessInfo core_idinfo + `setCgInfo` cg_info + `setNewStrictnessInfo` newStrictnessInfo core_idinfo -- Keep strictness; it's used by CorePrep | otherwise = vanillaIdInfo - `setCgInfo` cg_info - `setCprInfo` cprInfo core_idinfo - `setStrictnessInfo` strictnessInfo core_idinfo - `setInlinePragInfo` inlinePragInfo core_idinfo - `setUnfoldingInfo` unfold_info - `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo) + `setCgInfo` cg_info + `setNewStrictnessInfo` newStrictnessInfo core_idinfo + `setInlinePragInfo` inlinePragInfo core_idinfo + `setUnfoldingInfo` unfold_info + `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo) -- NB: we throw away the Rules -- They have already been extracted by findExternalRules where diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 49c5b7e..447768c 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -50,14 +50,14 @@ import Name ( hashName ) import Literal ( hashLiteral, literalType, litIsDupable ) import DataCon ( DataCon, dataConRepArity ) import PrimOp ( primOpOkForSpeculation, primOpIsCheap ) -import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo, +import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, isDataConId_maybe, mkSysLocal, hasNoBinding ) import IdInfo ( LBVarInfo(..), GlobalIdDetails(..), megaSeqIdInfo ) -import Demand ( appIsBottom ) +import NewDemand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, splitForAllTy_maybe, isForAllTy, splitNewType_maybe, eqType @@ -508,7 +508,7 @@ exprIsBottom e = go 0 e go n (Lam _ _) = False idAppIsBottom :: Id -> Int -> Bool -idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args +idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args \end{code} @exprIsValue@ returns true for expressions that are certainly *already* diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 81b2f9e..88c9f2a 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -131,6 +131,11 @@ ids decorated with their CprInfo pragmas. \begin{code} cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind] +#ifndef DEBUG +-- Omit unless DEBUG is on +cprAnalyse dflags binds = return binds + +#else cprAnalyse dflags binds = do { showPass dflags "Constructed Product analysis" ; @@ -306,4 +311,5 @@ getCprAbsVal v = case idCprInfo v of arity = idArity v -- Imported (non-nullary) constructors will have the CPR property -- in their IdInfo, so no need to look at their unfolding +#endif /* DEBUG */ \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 83dbd8b..3212202 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -33,13 +33,13 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, -- others: import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe ) import Var ( varType, isId ) -import IdInfo ( InlinePragInfo, pprInlinePragInfo, ppStrictnessInfo ) +import IdInfo ( InlinePragInfo, pprInlinePragInfo ) import Name ( Name, NamedThing(..), getName, toRdrName ) import RdrName ( RdrName, rdrNameOcc ) import OccName ( isTvOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) -import Demand ( StrictnessInfo ) +import NewDemand ( StrictSig, pprIfaceStrictSig ) import Literal ( Literal, maybeLitLit ) import ForeignCall ( ForeignCall ) import DataCon ( dataConTyCon, dataConSourceArity ) @@ -379,10 +379,9 @@ pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext data HsIdInfo name = HsArity Arity - | HsStrictness StrictnessInfo + | HsStrictness StrictSig | HsUnfold InlinePragInfo (UfExpr name) | HsNoCafRefs - | HsCprInfo | HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo -- for why we want arity here. deriving( Eq ) @@ -391,9 +390,8 @@ data HsIdInfo name ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf) ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity -ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str +ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> pprIfaceStrictSig str ppr_hs_info HsNoCafRefs = ptext SLIT("__C") -ppr_hs_info HsCprInfo = ptext SLIT("__M") ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index e305963..0b0c447 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -32,8 +32,7 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, eq_ufBinders, eq_ufExpr, pprUfExpr ) import CoreSyn ( CoreRule(..) ) -import BasicTypes ( NewOrData(..) ) -import Demand ( StrictnessMark(..) ) +import BasicTypes ( NewOrData(..), StrictnessMark(..) ) import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv ) -- others: diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 181863f..9a617e1 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -83,6 +83,7 @@ module CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_SimplExcessPrecision, + opt_MaxWorkerArgs, -- Unfolding control opt_UF_CreationThreshold, @@ -551,6 +552,7 @@ opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape") opt_UnfoldCasms = lookUp SLIT("-funfold-casms-in-hi-file") opt_UsageSPOn = lookUp SLIT("-fusagesp-on") opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields") +opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) {- The optional '-inpackage=P' flag tells what package @@ -652,6 +654,7 @@ isStaticHscFlag f = || any (flip prefixMatch f) [ "fcontext-stack", "fliberate-case-threshold", + "fmax-worker-args", "fhistory-size", "funfolding-creation-threshold", "funfolding-use-threshold", diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index ab5bf69..5d8f7c0 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -237,7 +237,7 @@ ifaceTyCls (AnId id) so_far caf_info = cgCafInfo cg_info hs_idinfo | opt_OmitInterfacePragmas = [] - | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++ + | otherwise = arity_hsinfo ++ caf_hsinfo ++ strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo ------------ Arity -------------- @@ -249,15 +249,10 @@ ifaceTyCls (AnId id) so_far NoCafRefs -> [HsNoCafRefs] otherwise -> [] - ------------ CPR Info -------------- - cpr_hsinfo = case cprInfo id_info of - ReturnsCPR -> [HsCprInfo] - NoCPRInfo -> [] - ------------ Strictness -------------- - strict_hsinfo = case strictnessInfo id_info of - NoStrictnessInfo -> [] - info -> [HsStrictness info] + strict_hsinfo = case newStrictnessInfo id_info of + Nothing -> [] + Just sig -> [HsStrictness sig] ------------ Worker -------------- work_info = workerInfo id_info diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 7aed428..bcafcb5 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -40,7 +40,8 @@ import IdInfo ( InlinePragInfo(..) ) import PrelNames ( mkTupNameStr ) import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck ) import ForeignCall ( Safety(..) ) -import Demand ( Demand(..) {- instance Read -} ) +import NewDemand ( StrictSig(..), Demand(..), Keepity(..), + DmdResult(..), Deferredness(..), mkTopDmdType ) import UniqFM ( listToUFM, lookupUFM ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine, @@ -152,7 +153,7 @@ data Token | ITspecialise | ITnocaf | ITunfold InlinePragInfo - | ITstrict ([Demand], Bool) + | ITstrict StrictSig | ITrules | ITcprinfo | ITdeprecated @@ -818,27 +819,36 @@ silly_escape_chars = [ lex_demand cont buf = case read_em [] buf of { (ls,buf') -> case currentChar# buf' of - 'B'# -> cont (ITstrict (ls, True )) (incLexeme buf') - _ -> cont (ITstrict (ls, False)) buf' + 'X'# -> cont (ITstrict (StrictSig (mkTopDmdType ls BotRes))) (incLexeme buf') + 'M'# -> cont (ITstrict (StrictSig (mkTopDmdType ls RetCPR))) (incLexeme buf') + _ -> cont (ITstrict (StrictSig (mkTopDmdType ls TopRes))) buf' } where -- code snatched from Demand.lhs read_em acc buf = case currentChar# buf of - 'L'# -> read_em (WwLazy False : acc) (stepOn buf) - 'A'# -> read_em (WwLazy True : acc) (stepOn buf) - 'S'# -> read_em (WwStrict : acc) (stepOn buf) - 'P'# -> read_em (WwPrim : acc) (stepOn buf) - 'E'# -> read_em (WwEnum : acc) (stepOn buf) + 'L'# -> read_em (Lazy : acc) (stepOn buf) + 'A'# -> read_em (Abs : acc) (stepOn buf) + 'V'# -> read_em (Eval : acc) (stepOn buf) ')'# -> (reverse acc, stepOn buf) - 'U'# -> do_unpack True acc (stepOnBy# buf 2#) - 'u'# -> do_unpack False acc (stepOnBy# buf 2#) + 'C'# -> do_call acc (stepOnBy# buf 2#) + 'U'# -> do_unpack1 Drop Now acc (stepOnBy# buf 1#) + 'S'# -> do_unpack1 Keep Now acc (stepOnBy# buf 1#) _ -> (reverse acc, buf) - do_unpack wrapper_unpacks acc buf - = case read_em [] buf of - (stuff, rest) -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest + do_unpack1 keepity defer acc buf + = case currentChar# buf of + '*'# -> do_unpack1 keepity Defer acc (stepOnBy# buf 1#) + '('# -> do_unpack2 keepity defer acc (stepOnBy# buf 1#) + _ -> read_em (Seq keepity defer [] : acc) buf + do_unpack2 keepity defer acc buf + = case read_em [] buf of + (stuff, rest) -> read_em (Seq keepity defer stuff : acc) rest + + do_call acc buf + = case read_em [] buf of + ([dmd], rest) -> read_em (Call dmd : acc) rest ------------------ lex_scc cont buf = diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 0edcedb..30a1950 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.71 2001/07/13 13:29:57 simonpj Exp $ +$Id: Parser.y,v 1.72 2001/07/23 10:54:48 simonpj Exp $ Haskell grammar. @@ -27,9 +27,8 @@ import ForeignCall ( Safety(..), CExportSpec(..), CCallSpec(..), import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module -import Demand ( StrictnessMark(..) ) import CmdLineOpts ( opt_SccProfilingOn ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..) ) +import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), NewOrData(..), StrictnessMark(..) ) import Panic import GlaExts diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index a76d650..ca4f950 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -98,13 +98,12 @@ import Name ( Name, nameRdrName, nameUnique, nameOccName, import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) import RdrName ( rdrNameOcc ) import DataCon ( DataCon, mkDataCon, dataConId ) -import Demand ( StrictnessMark(..) ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons, mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon ) -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, StrictnessMark(..) ) import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys, mkArrowKinds, liftedTypeKind, unliftedTypeKind, diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 9254ef2..c6f623d 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -36,13 +36,11 @@ import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms import HsTypes ( mkHsForAllTy, mkHsTupCon ) import HsCore -import Demand ( mkStrictnessInfo ) import Literal ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 ) -import BasicTypes ( Fixity(..), FixityDirection(..), +import BasicTypes ( Fixity(..), FixityDirection(..), StrictnessMark(..), NewOrData(..), Version, initialVersion, Boxity(..) ) import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) ) -import Demand ( StrictnessMark(..) ) import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind ) import IdInfo ( InlinePragInfo(..) ) import ForeignCall ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) ) @@ -746,8 +744,7 @@ id_info :: { [HsIdInfo RdrName] } id_info_item :: { HsIdInfo RdrName } : '__A' INTEGER { HsArity (fromInteger $2) } | '__U' inline_prag core_expr { HsUnfold $2 $3 } - | '__M' { HsCprInfo } - | '__S' { HsStrictness (mkStrictnessInfo $1) } + | '__S' { HsStrictness $1 } | '__C' { HsNoCafRefs } | '__P' qvar_name INTEGER { HsWorker $2 (fromInteger $3) } diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 6bb8bc0..50c9ee5 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -287,10 +287,10 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc where doc_str = text "In the interface signature for" <+> quotes (ppr name) -rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc}) +rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) = pushSrcLocRn loc $ lookupTopBndrRn name `thenRn` \ name' -> - returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc}) + returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, @@ -713,7 +713,6 @@ rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> rnIdInfo (HsStrictness str) = returnRn (HsStrictness str) rnIdInfo (HsArity arity) = returnRn (HsArity arity) rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs -rnIdInfo HsCprInfo = returnRn HsCprInfo \end{code} @UfCore@ expressions. diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 0f0cb76..836d2ab 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -30,13 +30,13 @@ import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, import Subst ( InScopeSet, mkSubst, substExpr ) import qualified Subst ( simplBndrs, simplBndr, simplLetId ) import Id ( idType, idName, - idUnfolding, idStrictness, + idUnfolding, idNewStrictness, mkLocalId, idInfo ) import IdInfo ( StrictnessInfo(..) ) import Maybes ( maybeToBool, catMaybes ) import Name ( setNameUnique ) -import Demand ( isStrict ) +import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad import Type ( Type, mkForAllTys, seqType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys, @@ -230,8 +230,8 @@ getContArgs fun orig_cont -- after that number of value args have been consumed -- Otherwise it's infinite, extended with False fun_stricts - = case idStrictness fun of - StrictnessInfo demands result_bot + = case splitStrictSig (idNewStrictness fun) of + (demands, result_info) | not (demands `lengthExceeds` countValArgs orig_cont) -> -- Enough args, use the strictness given. -- For bottoming functions we used to pretend that the arg @@ -240,10 +240,10 @@ getContArgs fun orig_cont -- top-level bindings for (say) strings into -- calls to error. But now we are more careful about -- inlining lone variables, so its ok (see SimplUtils.analyseCont) - if result_bot then - map isStrict demands -- Finite => result is bottom + if isBotRes result_info then + map isStrictDmd demands -- Finite => result is bottom else - map isStrict demands ++ vanilla_stricts + map isStrictDmd demands ++ vanilla_stricts other -> vanilla_stricts -- Not enough args, or no strictness diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 9058d0a..62389b7 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -25,7 +25,7 @@ import VarEnv import Literal ( Literal ) import Id ( Id, idType, idInfo, isDataConId, hasNoBinding, idUnfolding, setIdUnfolding, isExportedId, isDeadBinder, - idDemandInfo, setIdInfo, + idNewDemandInfo, setIdInfo, idOccInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) @@ -34,7 +34,7 @@ import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, setUnfoldingInfo, occInfo ) -import Demand ( isStrict ) +import NewDemand ( isStrictDmd ) import DataCon ( dataConNumInstArgs, dataConRepStrictness, dataConSig, dataConArgTys ) @@ -485,7 +485,7 @@ simplNonRecBind bndr rhs rhs_se cont_ty thing_inside -- has arisen from an application (\x. E) RHS, perhaps they aren't bndr'' = simplIdInfo bndr_subst (idInfo bndr) bndr' bndr_ty' = idType bndr' - is_strict = isStrict (idDemandInfo bndr) || isStrictType bndr_ty' + is_strict = isStrictDmd (idNewDemandInfo bndr) || isStrictType bndr_ty' in modifyInScope bndr'' bndr'' $ @@ -739,7 +739,7 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside -- we only float if arg' is a WHNF, -- and so there can't be any 'will be demanded' bindings in the floats. -- Hence the assert - WARN( any demanded_float (fromOL floats2), ppr (fromOL floats2) ) + WARN( any demanded_float (fromOL floats2), ppr (filter demanded_float (fromOL floats2)) ) -- Transform the RHS -- It's important that we do eta expansion on function *arguments* (which are @@ -767,7 +767,7 @@ simplRhs top_lvl float_ubx rhs_ty rhs rhs_se thing_inside -- Don't do the float thing_inside (wrapFloats floats1 rhs1) -demanded_float (NonRec b r) = isStrict (idDemandInfo b) && not (isUnLiftedType (idType b)) +demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) -- Unlifted-type (cheap-eagerness) lets may well have a demanded flag on them demanded_float (Rec _) = False @@ -1227,7 +1227,7 @@ canEliminateCase scrut bndr alts (rhs1:other_rhss) = rhssOfAlts alts binders_unused (_, bndrs, _) = all isDeadBinder bndrs - var_demanded_later (Var v) = isStrict (idDemandInfo bndr) -- It's going to be evaluated later + var_demanded_later (Var v) = isStrictDmd (idNewDemandInfo bndr) -- It's going to be evaluated later var_demanded_later other = False @@ -1469,9 +1469,9 @@ simplAlts zap_occ_info scrut_cons case_bndr' alts cont' cat_evals [] [] = [] cat_evals (v:vs) (str:strs) - | isTyVar v = v : cat_evals vs (str:strs) - | isStrict str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs - | otherwise = v' : cat_evals vs strs + | isTyVar v = v : cat_evals vs (str:strs) + | isStrictDmd str = (v' `setIdUnfolding` mkOtherCon []) : cat_evals vs strs + | otherwise = v' : cat_evals vs strs where v' = zap_occ_info v \end{code} diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index 1f5a3bc..818271a 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -11,17 +11,17 @@ module DmdAnal ( dmdAnalPgm ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..) ) +import CmdLineOpts ( DynFlags, DynFlag(..), opt_MaxWorkerArgs ) import NewDemand -- All of it import CoreSyn import CoreUtils ( exprIsValue, exprArity ) import DataCon ( dataConTyCon ) import TyCon ( isProductTyCon, isRecursiveTyCon ) -import Id ( Id, idType, idInfo, idArity, idStrictness, idCprInfo, idDemandInfo, - modifyIdInfo, isDataConId, isImplicitId, isGlobalId ) -import IdInfo ( newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, newDemand - ) +import Id ( Id, idType, idInfo, idArity, idCprInfo, idDemandInfo, + modifyIdInfo, isDataConId, isImplicitId, isGlobalId, + idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness, + idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld ) +import IdInfo ( newDemand ) import Var ( Var ) import VarEnv import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, @@ -36,7 +36,13 @@ import Outputable import FastTypes \end{code} -ToDo: set a noinline pragma on bottoming Ids +To think about + +* set a noinline pragma on bottoming Ids + +* Consider f x = x+1 `fatbar` error (show x) + We'd like to unbox x, even if that means reboxing it in the error case. + \begin{code} instance Outputable TopLevelFlag where ppr flag = empty @@ -50,12 +56,6 @@ instance Outputable TopLevelFlag where \begin{code} dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] -#ifndef DEBUG - -dmdAnalPgm dflags binds = return binds - -#else - dmdAnalPgm dflags binds = do { showPass dflags "Demand analysis" ; @@ -292,14 +292,25 @@ downRhs top_lvl sigs (id, rhs) where arity = exprArity rhs -- The idArity may not be up to date (rhs_ty, rhs') = dmdAnal sigs (vanillaCall arity) rhs - (lazy_fv, sig_ty) = mkSigTy rhs rhs_ty - sig = mkStrictSig id arity sig_ty - id' = id `setIdNewStrictness` sig - sigs' = extendSigEnv top_lvl sigs id sig + (lazy_fv, sig_ty) = mkSigTy id arity rhs rhs_ty + id' = id `setIdNewStrictness` sig_ty + sigs' = extendSigEnv top_lvl sigs id sig_ty +\end{code} -mkSigTy rhs (DmdType fv dmds res) - = (lazy_fv, DmdType strict_fv lazified_dmds res') +%************************************************************************ +%* * +\subsection{Strictness signatures and types} +%* * +%************************************************************************ + +\begin{code} +mkSigTy :: Id -> Arity -> CoreExpr -> DmdType -> (DmdEnv, StrictSig) +-- Take a DmdType and turn it into a StrictSig +mkSigTy id arity rhs (DmdType fv dmds res) + = (lazy_fv, mkStrictSig id arity dmd_ty) where + dmd_ty = DmdType strict_fv lazified_dmds res' + lazy_fv = filterUFM (not . isStrictDmd) fv strict_fv = filterUFM isStrictDmd fv -- We put the strict FVs in the DmdType of the Id, so @@ -334,7 +345,9 @@ mkSigTy rhs (DmdType fv dmds res) lazified_dmds = map lazify dmds -- Get rid of defers in the arguments - + final_dmds = setUnpackStrategy lazified_dmds + -- Set the unpacking strategy + res' = case (dmds, res) of ([], RetCPR) | not (exprIsValue rhs) -> TopRes other -> res @@ -354,6 +367,42 @@ mkSigTy rhs (DmdType fv dmds res) -- if r doesn't have the CPR property then neither does modInt \end{code} +The unpack strategy determines whether we'll *really* unpack the argument, +or whether we'll just remember its strictness. If unpacking would give +rise to a *lot* of worker args, we may decide not to unpack after all. + +\begin{code} +setUnpackStrategy :: [Demand] -> [Demand] +setUnpackStrategy ds + = snd (go (opt_MaxWorkerArgs - nonAbsentArgs ds) ds) + where + go :: Int -- Max number of args available for sub-components of [Demand] + -> [Demand] + -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked + + go n (Seq keep _ cs : ds) + | n' >= 0 = Seq keep Now cs' `cons` go n'' ds + | otherwise = Eval `cons` go n ds + where + (n'',cs') = go n' cs + n' = n + box - non_abs_args + box = case keep of + Keep -> 0 + Drop -> 1 -- Add one to the budget if we drop the top-level arg + non_abs_args = nonAbsentArgs cs + -- Delete # of non-absent args to which we'll now be committed + + go n (d:ds) = d `cons` go n ds + go n [] = (n,[]) + + cons d (n,ds) = (n, d:ds) + +nonAbsentArgs :: [Demand] -> Int +nonAbsentArgs [] = 0 +nonAbsentArgs (Abs : ds) = nonAbsentArgs ds +nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds +\end{code} + %************************************************************************ %* * @@ -362,6 +411,17 @@ mkSigTy rhs (DmdType fv dmds res) %************************************************************************ \begin{code} +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType fv [] TopRes) = (topDmd, ty) +splitDmdTy ty@(DmdType fv [] BotRes) = (Abs, ty) + -- We already have a suitable demand on all + -- free vars, so no need to add more! +splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy" +\end{code} + +\begin{code} unitVarDmd var dmd = DmdType (unitVarEnv var dmd) [] TopRes addVarDmd top_lvl dmd_ty@(DmdType fv ds res) var dmd @@ -401,28 +461,6 @@ removeFV fv var res = (fv', dmd) %************************************************************************ %* * -\subsection{Demand types} -%* * -%************************************************************************ - -\begin{code} -splitDmdTy :: DmdType -> (Demand, DmdType) --- Split off one function argument -splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) -splitDmdTy ty@(DmdType fv [] TopRes) = (topDmd, ty) -splitDmdTy ty@(DmdType fv [] BotRes) = (Abs, ty) - -- We already have a suitable demand on all - -- free vars, so no need to add more! -splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy" - -------------------------- -dmdTypeRes :: DmdType -> DmdResult -dmdTypeRes (DmdType _ _ res_ty) = res_ty -\end{code} - - -%************************************************************************ -%* * \subsection{Strictness signatures} %* * %************************************************************************ @@ -455,27 +493,27 @@ dmdTransform sigs var dmd ------ DATA CONSTRUCTOR | isDataConId var, -- Data constructor Seq k Now ds <- res_dmd, -- and the demand looks inside its fields - let StrictSig arity dmd_ty = idNewStrictness var -- It must have a strictness sig - = if arity == length ds then -- Saturated, so unleash the demand + let StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig + = if dmdTypeDepth dmd_ty == length ds then -- Saturated, so unleash the demand -- ds can be empty, when we are just seq'ing the thing mkDmdType emptyDmdEnv ds (dmdTypeRes dmd_ty) - -- Need to extract whether it's a product + -- Need to extract whether it's a product, hence dmdTypeRes else topDmdType ------ IMPORTED FUNCTION | isGlobalId var, -- Imported function - let StrictSig arity dmd_ty = getNewStrictness var - = if arity <= depth then -- Saturated, so unleash the demand + let StrictSig dmd_ty = getNewStrictness var + = if dmdTypeDepth dmd_ty <= call_depth then -- Saturated, so unleash the demand dmd_ty else topDmdType ------ LOCAL LET/REC BOUND THING - | Just (StrictSig arity dmd_ty, top_lvl) <- lookupVarEnv sigs var + | Just (StrictSig dmd_ty, top_lvl) <- lookupVarEnv sigs var = let - fn_ty | arity <= depth = dmd_ty - | otherwise = deferType dmd_ty + fn_ty | dmdTypeDepth dmd_ty <= call_depth = dmd_ty + | otherwise = deferType dmd_ty -- NB: it's important to use deferType, and not just return topDmdType -- Consider let { f x y = p + x } in f 1 -- The application isn't saturated, but we must nevertheless propagate @@ -488,17 +526,7 @@ dmdTransform sigs var dmd = unitVarDmd var dmd where - (depth, res_dmd) = splitCallDmd dmd -\end{code} - -\begin{code} -squashDmdEnv (StrictSig a (DmdType fv ds res)) = StrictSig a (DmdType emptyDmdEnv ds res) - -betterStrict :: StrictSig -> StrictSig -> Bool -betterStrict (StrictSig ar1 t1) (StrictSig ar2 t2) - = (ar1 >= ar2) && (t1 `betterDmdType` t2) - -betterDmdType t1 t2 = (t1 `lubType` t2) == t2 + (call_depth, res_dmd) = splitCallDmd dmd \end{code} @@ -530,24 +558,25 @@ defer Abs = Abs defer (Seq k _ ds) = Seq k Defer ds defer other = Lazy -isStrictDmd :: Demand -> Bool -isStrictDmd Bot = True -isStrictDmd Err = True -isStrictDmd (Seq _ Now _) = True -isStrictDmd Eval = True -isStrictDmd (Call _) = True -isStrictDmd other = False - lazify :: Demand -> Demand -- The 'Defer' demands are just Lazy at function boundaries lazify (Seq k Defer ds) = Lazy lazify (Seq k Now ds) = Seq k Now (map lazify ds) lazify Bot = Abs -- Don't pass args that are consumed by bottom lazify d = d +\end{code} + +\begin{code} +betterStrictness :: StrictSig -> StrictSig -> Bool +betterStrictness (StrictSig t1) (StrictSig t2) = betterDmdType t1 t2 + +betterDmdType t1 t2 = (t1 `lubType` t2) == t2 betterDemand :: Demand -> Demand -> Bool -- If d1 `better` d2, and d2 `better` d2, then d1==d2 betterDemand d1 d2 = (d1 `lub` d2) == d2 + +squashDmdEnv (StrictSig (DmdType fv ds res)) = StrictSig (DmdType emptyDmdEnv ds res) \end{code} @@ -704,33 +733,6 @@ modifyEnv need_to_modify zapper env1 env2 env \begin{code} --- Move these to Id.lhs -idNewStrictness_maybe :: Id -> Maybe StrictSig -idNewStrictness :: Id -> StrictSig - -idNewStrictness_maybe id = newStrictnessInfo (idInfo id) -idNewStrictness id = idNewStrictness_maybe id `orElse` topSig - -getNewStrictness :: Id -> StrictSig --- First tries the "new-strictness" field, and then --- reverts to the old one. This is just until we have --- cross-module info for new strictness -getNewStrictness id = idNewStrictness_maybe id `orElse` newStrictnessFromOld id - -newStrictnessFromOld :: Id -> StrictSig -newStrictnessFromOld id = mkNewStrictnessInfo id (idArity id) (idStrictness id) (idCprInfo id) - -setIdNewStrictness :: Id -> StrictSig -> Id -setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` sig) id - -idNewDemandInfo :: Id -> Demand -idNewDemandInfo id = newDemandInfo (idInfo id) - -setIdNewDemandInfo :: Id -> Demand -> Id -setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` dmd) id -\end{code} - -\begin{code} get_changes binds = vcat (map get_changes_bind binds) get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs) @@ -765,8 +767,8 @@ get_changes_str id info = (text "Old" <+> ppr old) $$ (text "New" <+> ppr new) new = squashDmdEnv (idNewStrictness id) -- Don't report diffs in the env old = newStrictnessFromOld id - old_better = old `betterStrict` new - new_better = new `betterStrict` old + old_better = old `betterStrictness` new + new_better = new `betterStrictness` old get_changes_dmd id | isUnLiftedType (idType id) = empty -- Not useful @@ -781,5 +783,4 @@ get_changes_dmd id old = newDemand (idDemandInfo id) new_better = new `betterDemand` old old_better = old `betterDemand` new -#endif /* DEBUG */ \end{code} diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index e413b48..82a2b47 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -4,6 +4,11 @@ \section[SaAbsInt]{Abstract interpreter for strictness analysis} \begin{code} +#ifndef DEBUG +-- If DEBUG is off, omit all exports +module SaAbsInt () where + +#else module SaAbsInt ( findStrictness, findDemand, findDemandAlts, @@ -12,7 +17,7 @@ module SaAbsInt ( fixpoint, isBot ) where - +#endif /* DEBUG */ #include "HsVersions.h" import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index ac9c267..8c443b5 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -6,6 +6,11 @@ See also: the ``library'' for the ``back end'' (@SaBackLib@). \begin{code} +#ifndef DEBUG +-- If DEBUG is off, omit all exports +module SaAbsInt () where + +#else module SaLib ( AbsVal(..), AnalysisKind(..), @@ -15,6 +20,7 @@ module SaLib ( lookupAbsValEnv, absValFromStrictness ) where +#endif /* DEBUG */ #include "HsVersions.h" diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index bac6b14..2218a6a 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -80,7 +80,12 @@ strict workers. \begin{code} saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] +#ifndef DEBUG +-- Omit strictness analyser if DEBUG is off +saBinds dflags binds = return binds + +#else saBinds dflags binds = do { showPass dflags "Strictness analysis"; @@ -483,4 +488,5 @@ sequenceSa [] = returnSa [] sequenceSa (m:ms) = m `thenSa` \ r -> sequenceSa ms `thenSa` \ rs -> returnSa (r:rs) +#endif /* DEBUG */ \end{code} diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 796488a..de60e75 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -12,16 +12,19 @@ import CoreSyn import CoreUnfold ( certainlyWillInline ) import CoreLint ( showPass, endPass ) import CoreUtils ( exprType ) -import Id ( Id, idType, idStrictness, idArity, isOneShotLambda, - setIdStrictness, idInlinePragma, mkWorkerId, +import Id ( Id, idType, idNewStrictness, idArity, isOneShotLambda, + setIdNewStrictness, idInlinePragma, mkWorkerId, setIdWorkerInfo, idCprInfo, setInlinePragma ) import Type ( Type ) import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..), CprInfo(..), InlinePragInfo(..), isNeverInlinePrag, WorkerInfo(..) ) -import Demand ( Demand ) +import NewDemand ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), + mkTopDmdType, isBotRes, returnsCPR + ) import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM ) +import BasicTypes ( RecFlag(..), isNonRec ) import CmdLineOpts import WwLib import Outputable @@ -99,20 +102,18 @@ wwBind :: CoreBind -- as appropriate. wwBind (NonRec binder rhs) - = wwExpr rhs `thenUs` \ new_rhs -> - tryWW True {- non-recursive -} binder new_rhs `thenUs` \ new_pairs -> + = wwExpr rhs `thenUs` \ new_rhs -> + tryWW NonRecursive binder new_rhs `thenUs` \ new_pairs -> returnUs [NonRec b e | (b,e) <- new_pairs] -- Generated bindings must be non-recursive -- because the original binding was. ------------------------------- - wwBind (Rec pairs) = mapUs do_one pairs `thenUs` \ new_pairs -> returnUs [Rec (concat new_pairs)] where do_one (binder, rhs) = wwExpr rhs `thenUs` \ new_rhs -> - tryWW False {- recursive -} binder new_rhs + tryWW Recursive binder new_rhs \end{code} @wwExpr@ basically just walks the tree, looking for appropriate @@ -174,7 +175,7 @@ reason), then we don't w-w it. The only reason this is monadised is for the unique supply. \begin{code} -tryWW :: Bool -- True <=> a non-recursive binding +tryWW :: RecFlag -> Id -- The fn binder -> CoreExpr -- The bound rhs; its innards -- are already ww'd @@ -183,12 +184,12 @@ tryWW :: Bool -- True <=> a non-recursive binding -- the orig "wrapper" lives on); -- if two, then a worker and a -- wrapper. -tryWW non_rec fn_id rhs - | isNeverInlinePrag inline_prag || arity == 0 - = -- Don't split things that will never be inlined - returnUs [ (fn_id, rhs) ] - - | non_rec && certainlyWillInline fn_id +tryWW is_rec fn_id rhs + | arity == 0 + -- Don't worker-wrapper thunks + || isNeverInlinePrag inline_prag + -- Don't split things that will never be inlined + || isNonRec is_rec && certainlyWillInline fn_id -- No point in worker/wrappering a function that is going to be -- INLINEd wholesale anyway. If the strictness analyser is run -- twice, this test also prevents wrappers (which are INLINEd) @@ -202,41 +203,27 @@ tryWW non_rec fn_id rhs -- fw = \ab -> (__inline (\x -> E)) (a,b) -- and the original __inline now vanishes, so E is no longer -- inside its __inline wrapper. Death! Disaster! - -- - -- OUT OF DATE NOTE: - -- [Out of date because the size calculation in CoreUnfold now - -- makes wrappers look very cheap even when they are inlined.] - -- In this case we add an INLINE pragma to the RHS. Why? - -- Because consider - -- f = \x -> g x x - -- g = \yz -> ... -- And g is strict - -- Then f is small, so we don't w/w it. But g is big, and we do, so - -- g's wrapper will get inlined in f's RHS, which makes f look big now. - -- So f doesn't get inlined, but it is strict and we have failed to w/w it. + || not (worthSplitting strict_sig) + -- Strictness info suggests not to w/w = returnUs [ (fn_id, rhs) ] - | not (do_strict_ww || do_cpr_ww) - = returnUs [ (fn_id, rhs) ] - - | otherwise -- Do w/w split - = mkWwBodies fun_ty arity wrap_dmds result_bot one_shots cpr_info `thenUs` \ (work_demands, wrap_fn, work_fn) -> - getUniqueUs `thenUs` \ work_uniq -> + | otherwise -- Do w/w split! + = WARN( arity /= length wrap_dmds, ppr fn_id <+> (ppr arity $$ ppr strict_sig) ) + -- The arity should match the signature + mkWwBodies fun_ty wrap_dmds res_info one_shots `thenUs` \ (work_demands, wrap_fn, work_fn) -> + getUniqueUs `thenUs` \ work_uniq -> let - work_rhs = work_fn rhs - proto_work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + work_rhs = work_fn rhs + work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) `setInlinePragma` inline_prag - - work_id | has_strictness = proto_work_id `setIdStrictness` mkStrictnessInfo (work_demands, result_bot) - | otherwise = proto_work_id + `setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info) + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv wrap_rhs = wrap_fn work_id - wrap_id = fn_id `setIdStrictness` wrapper_strictness - `setIdWorkerInfo` HasWorker work_id arity - `setInlinePragma` NoInlinePragInfo -- Put it on the worker instead - -- Add info to the wrapper: - -- (a) we want to set its arity - -- (b) we want to pin on its revised strictness info - -- (c) we pin on its worker id + wrap_id = fn_id `setIdWorkerInfo` HasWorker work_id arity + `setInlinePragma` NoInlinePragInfo -- Zap any inline pragma; + -- Put it on the worker instead in returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) -- Worker first, because wrapper mentions it @@ -246,38 +233,13 @@ tryWW non_rec fn_id rhs arity = idArity fn_id -- The arity is set by the simplifier using exprEtaExpandArity -- So it may be more than the number of top-level-visible lambdas - inline_prag = idInlinePragma fn_id - - strictness_info = idStrictness fn_id - has_strictness = case strictness_info of - StrictnessInfo _ _ -> True - NoStrictnessInfo -> False - (arg_demands, result_bot) = case strictness_info of - StrictnessInfo d r -> (d, r) - NoStrictnessInfo -> ([], False) - - wrap_dmds = setUnpackStrategy arg_demands - do_strict_ww = WARN( has_strictness && not result_bot && arity < length arg_demands && worthSplitting wrap_dmds result_bot, - text "Insufficient arity" <+> ppr fn_id <+> ppr arity <+> ppr arg_demands ) - (result_bot || arity >= length arg_demands) -- Only if there's enough visible arity - && -- (else strictness info isn't valid) - -- - worthSplitting wrap_dmds result_bot -- And it's useful - -- worthSplitting returns False for an empty list of demands, - -- and hence do_strict_ww is False if arity is zero - -- Also it's false if there is no strictness (arg_demands is []) - - wrapper_strictness | has_strictness = mkStrictnessInfo (wrap_dmds, result_bot) - | otherwise = noStrictnessInfo + inline_prag = idInlinePragma fn_id + strict_sig = idNewStrictness fn_id - ------------------------------------------------------------- - cpr_info = idCprInfo fn_id - do_cpr_ww = arity > 0 && - case cpr_info of - ReturnsCPR -> True - other -> False + StrictSig (DmdType _ wrap_dmds res_info) = strict_sig + work_res_info | isBotRes res_info = BotRes -- Cpr stuff done by wrapper + | otherwise = TopRes - ------------------------------------------------------------- one_shots = get_one_shots rhs -- If the original function has one-shot arguments, it is important to @@ -292,6 +254,37 @@ get_one_shots other = noOneShotInfo \end{code} +%************************************************************************ +%* * +\subsection{Functions over Demands} +%* * +%************************************************************************ + +\begin{code} +worthSplitting :: StrictSig -> Bool + -- True <=> the wrapper would not be an identity function +worthSplitting (StrictSig (DmdType _ ds res)) + = any worth_it ds || returnsCPR res + -- worthSplitting returns False for an empty list of demands, + -- and hence do_strict_ww is False if arity is zero + + -- We used not to split if the result is bottom. + -- [Justification: there's no efficiency to be gained.] + -- But it's sometimes bad not to make a wrapper. Consider + -- fw = \x# -> let x = I# x# in case e of + -- p1 -> error_fn x + -- p2 -> error_fn x + -- p3 -> the real stuff + -- The re-boxing code won't go away unless error_fn gets a wrapper too. + -- [We don't do reboxing now, but in general it's better to pass + -- an unboxed thing to f, and have it reboxed in the error cases....] + where + worth_it Abs = True -- Absent arg + worth_it (Seq _ _ ds) = True -- Arg to evaluate + worth_it other = False +\end{code} + + %************************************************************************ %* * @@ -304,14 +297,11 @@ the function and the name of its worker, and we want to make its body (the wrapp \begin{code} mkWrapper :: Type -- Wrapper type - -> Int -- Arity - -> [Demand] -- Wrapper strictness info - -> Bool -- Function returns bottom - -> CprInfo -- Wrapper cpr info + -> StrictSig -- Wrapper strictness info -> UniqSM (Id -> CoreExpr) -- Wrapper body, missing worker Id -mkWrapper fun_ty arity demands res_bot cpr_info - = mkWwBodies fun_ty arity demands res_bot noOneShotInfo cpr_info `thenUs` \ (_, wrap_fn, _) -> +mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) + = mkWwBodies fun_ty demands res_info noOneShotInfo `thenUs` \ (_, wrap_fn, _) -> returnUs wrap_fn noOneShotInfo = repeat False diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 994f4b2..f77a79d 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -4,22 +4,19 @@ \section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser} \begin{code} -module WwLib ( - mkWwBodies, - worthSplitting, setUnpackStrategy - ) where +module WwLib ( mkWwBodies ) where #include "HsVersions.h" import CoreSyn import CoreUtils ( exprType ) -import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo, +import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, isOneShotLambda, setOneShotLambda, setIdInfo ) -import IdInfo ( CprInfo(..), vanillaIdInfo ) -import DataCon ( splitProductType ) -import Demand ( Demand(..), wwLazy, wwPrim ) +import IdInfo ( vanillaIdInfo ) +import DataCon ( splitProductType_maybe, splitProductType ) +import NewDemand ( Demand(..), Keepity(..), DmdResult(..) ) import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID ) import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) @@ -41,54 +38,8 @@ import List ( zipWith4 ) %* * %************************************************************************ - ************ WARNING ****************** - these comments are rather out of date - ***************************************** - -@mkWrapperAndWorker@ is given: -\begin{enumerate} -\item -The {\em original function} \tr{f}, of the form: -\begin{verbatim} -f = /\ tyvars -> \ args -> body -\end{verbatim} -The original-binder \tr{f}, the \tr{tyvars}, \tr{args}, and \tr{body} -are given separately. - -We use the Id \tr{f} mostly to get its type. - -\item -Strictness information about \tr{f}, in the form of a list of -@Demands@. - -\item -A @UniqueSupply@. -\end{enumerate} - -@mkWrapperAndWorker@ produces (A BIT OUT-OF-DATE...): -\begin{enumerate} -\item -Maybe @Nothing@: no worker/wrappering going on in this case. This can -happen (a)~if the strictness info says that there is nothing -interesting to do or (b)~if *any* of the argument types corresponding -to ``active'' arg postitions is abstract or will be to the outside -world (i.e., {\em this} module can see the constructors, but nobody -else will be able to). An ``active'' arg position is one which the -wrapper has to unpack. An importing module can't do this unpacking, -so it simply has to give up and call the wrapper only. - -\item -Maybe \tr{Just (wrapper_Id, wrapper_body, worker_Id, worker_body)}. - -The @wrapper_Id@ is just the one that was passed in, with its -strictness IdInfo updated. -\end{enumerate} - -The \tr{body} of the original function may not be given (i.e., it's -BOTTOM), in which case you'd jolly well better not tug on the -worker-body output! - Here's an example. The original function is: + \begin{verbatim} g :: forall a . Int -> [a] -> a @@ -105,13 +56,13 @@ g :: forall a . Int -> [a] -> a g = /\ a -> \ x ys -> case x of - I# x# -> g.wrk a x# ys + I# x# -> $wg a x# ys -- call the worker; don't forget the type args! -- worker -g.wrk :: forall a . Int# -> [a] -> a +$wg :: forall a . Int# -> [a] -> a -g.wrk = /\ a -> \ x# ys -> +$wg = /\ a -> \ x# ys -> let x = I# x# in @@ -121,12 +72,14 @@ g.wrk = /\ a -> \ x# ys -> \end{verbatim} Something we have to be careful about: Here's an example: + \begin{verbatim} -- "f" strictness: U(P)U(P) f (I# a) (I# b) = a +# b g = f -- "g" strictness same as "f" \end{verbatim} + \tr{f} will get a worker all nice and friendly-like; that's good. {\em But we don't want a worker for \tr{g}}, even though it has the same strictness as \tr{f}. Doing so could break laziness, at best. @@ -140,72 +93,6 @@ the unusable strictness-info into the interfaces. %************************************************************************ %* * -\subsection{Functions over Demands} -%* * -%************************************************************************ - -\begin{code} -mAX_WORKER_ARGS :: Int -- ToDo: set via flag -mAX_WORKER_ARGS = 6 - -setUnpackStrategy :: [Demand] -> [Demand] -setUnpackStrategy ds - = snd (go (mAX_WORKER_ARGS - nonAbsentArgs ds) ds) - where - go :: Int -- Max number of args available for sub-components of [Demand] - -> [Demand] - -> (Int, [Demand]) -- Args remaining after subcomponents of [Demand] are unpacked - - go n (WwUnpack _ cs : ds) | n' >= 0 - = WwUnpack True cs' `cons` go n'' ds - | otherwise - = WwUnpack False cs `cons` go n ds - where - n' = n + 1 - nonAbsentArgs cs - -- Add one because we don't pass the top-level arg any more - -- Delete # of non-absent args to which we'll now be committed - (n'',cs') = go n' cs - - go n (d:ds) = d `cons` go n ds - go n [] = (n,[]) - - cons d (n,ds) = (n, d:ds) - -nonAbsentArgs :: [Demand] -> Int -nonAbsentArgs [] = 0 -nonAbsentArgs (WwLazy True : ds) = nonAbsentArgs ds -nonAbsentArgs (d : ds) = 1 + nonAbsentArgs ds - -worthSplitting :: [Demand] - -> Bool -- Result is bottom - -> Bool -- True <=> the wrapper would not be an identity function -worthSplitting ds result_bot = any worth_it ds - -- We used not to split if the result is bottom. - -- [Justification: there's no efficiency to be gained.] - -- But it's sometimes bad not to make a wrapper. Consider - -- fw = \x# -> let x = I# x# in case e of - -- p1 -> error_fn x - -- p2 -> error_fn x - -- p3 -> the real stuff - -- The re-boxing code won't go away unless error_fn gets a wrapper too. - - where - worth_it (WwLazy True) = True -- Absent arg - worth_it (WwUnpack True _) = True -- Arg to unpack - worth_it WwStrict = False -- Don't w/w just because of strictness - worth_it other = False - -allAbsent :: [Demand] -> Bool -allAbsent ds = all absent ds - where - absent (WwLazy is_absent) = is_absent - absent (WwUnpack True cs) = allAbsent cs - absent other = False -\end{code} - - -%************************************************************************ -%* * \subsection{The worker wrapper core} %* * %************************************************************************ @@ -214,11 +101,9 @@ allAbsent ds = all absent ds \begin{code} mkWwBodies :: Type -- Type of original function - -> Arity -- Arity of original function -> [Demand] -- Strictness of original function - -> Bool -- True <=> function returns bottom + -> DmdResult -- Info about function result -> [Bool] -- One-shot-ness of the function - -> CprInfo -- Result of CPR analysis -> UniqSM ([Demand], -- Demands for worker (value) args Id -> CoreExpr, -- Wrapper body, lacking only the worker Id CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs @@ -234,10 +119,10 @@ mkWwBodies :: Type -- Type of original function -- let x = (a,b) in -- E -mkWwBodies fun_ty arity demands res_bot one_shots cpr_info - = mkWWargs fun_ty arity demands' res_bot one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> - mkWWcpr res_ty cpr_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) -> - mkWWstr cpr_res_ty wrap_args `thenUs` \ (work_dmds, wrap_fn_str, work_fn_str) -> +mkWwBodies fun_ty demands res_info one_shots + = mkWWargs fun_ty demands one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + mkWWcpr res_ty res_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) -> + mkWWstr cpr_res_ty wrap_args `thenUs` \ (work_dmds, wrap_fn_str, work_fn_str) -> returnUs (work_dmds, Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . Var, @@ -250,7 +135,6 @@ mkWwBodies fun_ty arity demands res_bot one_shots cpr_info -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent -- fw from being inlined into f's RHS where - demands' = demands ++ repeat wwLazy one_shots' = one_shots ++ repeat False \end{code} @@ -292,43 +176,16 @@ the \x to get what we want. -- It chomps bites off foralls, arrows, newtypes -- and keeps repeating that until it's satisfied the supplied arity -mkWWargs :: Type -> Arity - -> [Demand] -> Bool -> [Bool] -- Both these will in due course be derived - -- from the type. The [Bool] is True for a one-shot arg. - -- ** Both are infinite, extended with neutral values if necy ** +mkWWargs :: Type + -> [Demand] + -> [Bool] -- True for a one-shot arg; ** may be infinite ** -> UniqSM ([Var], -- Wrapper args CoreExpr -> CoreExpr, -- Wrapper fn CoreExpr -> CoreExpr, -- Worker fn Type) -- Type of wrapper body -mkWWargs fun_ty arity demands res_bot one_shots - | (res_bot || arity > 0) && (not (null tyvars) || n_arg_tys > 0) - -- If the function returns bottom, we feel free to - -- build lots of wrapper args: - -- \x. let v=E in \y. bottom - -- = \xy. let v=E in bottom - = getUniquesUs `thenUs` \ wrap_uniqs -> - let - val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots - wrap_args = tyvars ++ val_args - n_args | res_bot = n_arg_tys - | otherwise = arity `min` n_arg_tys - new_fun_ty | n_args == n_arg_tys = body_ty - | otherwise = mkFunTys (drop n_args arg_tys) body_ty - in - mkWWargs new_fun_ty - (arity - n_args) - (drop n_args demands) - res_bot - (drop n_args one_shots) `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) -> - - returnUs (wrap_args ++ more_wrap_args, - mkLams wrap_args . wrap_fn_args, - work_fn_args . applyToVars wrap_args, - res_ty) - - | Just rep_ty <- splitNewType_maybe fun_ty, - arity >= 0 +mkWWargs fun_ty demands one_shots + | Just rep_ty <- splitNewType_maybe fun_ty -- The newtype case is for when the function has -- a recursive newtype after the arrow (rare) -- We check for arity >= 0 to avoid looping in the case @@ -339,26 +196,48 @@ mkWWargs fun_ty arity demands res_bot one_shots -- wrapped in a recursive newtype, at least if CPR analysis can look -- through such newtypes, which it probably can since they are -- simply coerces. - = mkWWargs rep_ty arity demands res_bot one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + = mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) -> returnUs (wrap_args, Note (Coerce fun_ty rep_ty) . wrap_fn_args, work_fn_args . Note (Coerce rep_ty fun_ty), res_ty) + | not (null demands) + = getUniquesUs `thenUs` \ wrap_uniqs -> + let + (tyvars, tau) = splitForAllTys fun_ty + (arg_tys, body_ty) = splitFunTys tau + + n_demands = length demands + n_arg_tys = length arg_tys + n_args = n_demands `min` n_arg_tys + + new_fun_ty = mkFunTys (drop n_demands arg_tys) body_ty + new_demands = drop n_arg_tys demands + new_one_shots = drop n_args one_shots + + val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots + wrap_args = tyvars ++ val_args + in + ASSERT( not (null tyvars) || not (null arg_tys) ) + mkWWargs new_fun_ty + new_demands + new_one_shots `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) -> + + returnUs (wrap_args ++ more_wrap_args, + mkLams wrap_args . wrap_fn_args, + work_fn_args . applyToVars wrap_args, + res_ty) + | otherwise = returnUs ([], id, id, fun_ty) - where - (tyvars, tau) = splitForAllTys fun_ty - (arg_tys, body_ty) = splitFunTys tau - n_arg_tys = length arg_tys - applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars mk_wrap_arg uniq ty dmd one_shot - = set_one_shot one_shot (setIdDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd) + = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd) where set_one_shot True id = setOneShotLambda id set_one_shot False id = id @@ -387,12 +266,12 @@ mkWWstr :: Type -- Result type mkWWstr res_ty wrap_args = mk_ww_str wrap_args `thenUs` \ (work_args, take_apart, put_together) -> let - work_dmds = [idDemandInfo v | v <- work_args, isId v] + work_dmds = [idNewDemandInfo v | v <- work_args, isId v] apply_to args fn = mkVarApps fn args in if not (null work_dmds && isUnLiftedType res_ty) then returnUs ( work_dmds, - take_apart . apply_to work_args, + take_apart . applyToVars work_args, mkLams work_args . put_together) else -- Horrid special case. If the worker would have no arguments, and the @@ -407,8 +286,8 @@ mkWWstr res_ty wrap_args let void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy in - returnUs ([wwPrim], - take_apart . apply_to [realWorldPrimId] . apply_to work_args, + returnUs ([Lazy], + take_apart . applyToVars [realWorldPrimId] . apply_to work_args, mkLams work_args . Lam void_arg . put_together) -- Empty case @@ -424,26 +303,47 @@ mk_ww_str (arg : ds) returnUs (arg : worker_args, wrap_fn, work_fn) | otherwise - = case idDemandInfo arg of + = case idNewDemandInfo arg of - -- Absent case - WwLazy True -> + -- Absent case. We don't deal with absence for unlifted types, + -- though, because it's not so easy to manufacture a placeholder + -- We'll see if this turns out to be a problem + Abs | not (isUnLiftedType (idType arg)) -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn) + -- Seq and keep + Seq Keep _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> + returnUs (arg : worker_args, mk_seq_case arg . wrap_fn, work_fn) + -- Pass the arg, no need to rebox + + -- Seq and discard + Seq Drop _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> + returnUs (worker_args, mk_seq_case arg . wrap_fn, mk_absent_let arg . work_fn) + -- Don't pass the arg, build absent arg + -- Unpack case - WwUnpack True cs -> - getUniquesUs `thenUs` \ uniqs -> - let - unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys - unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs - in - mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) -> - returnUs (worker_args, - mk_unpk_case arg unpk_args data_con arg_tycon . wrap_fn, - work_fn . mk_pk_let arg data_con tycon_arg_tys unpk_args) - where - (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww_str" (idType arg) + Seq keep _ cs + | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) + <- splitProductType_maybe (idType arg) + -> getUniquesUs `thenUs` \ uniqs -> + let + unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys + unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs + unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon + rebox_fn = mk_pk_let arg data_con tycon_arg_tys unpk_args + in + mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) -> + case keep of + Keep -> returnUs (arg : worker_args, unbox_fn . wrap_fn, work_fn) + -- Pass the arg, no need to rebox + Drop -> returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) + -- Don't pass the arg, rebox instead + + | otherwise -> + WARN( True, ppr arg ) + mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) -> + returnUs (arg : worker_args, wrap_fn, work_fn) -- Other cases other_demand -> @@ -453,7 +353,7 @@ mk_ww_str (arg : ds) -- If the wrapper argument is a one-shot lambda, then -- so should (all) the corresponding worker arguments be -- This bites when we do w/w on a case join point - set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand) + set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand) set_one_shot | isOneShotLambda arg = setOneShotLambda | otherwise = \x -> x @@ -478,15 +378,12 @@ left-to-right traversal of the result structure. \begin{code} mkWWcpr :: Type -- function body type - -> CprInfo -- CPR analysis results + -> DmdResult -- CPR analysis results -> UniqSM (CoreExpr -> CoreExpr, -- New wrapper CoreExpr -> CoreExpr, -- New worker Type) -- Type of worker's body -mkWWcpr body_ty NoCPRInfo - = returnUs (id, id, body_ty) -- Must be just the strictness transf. - -mkWWcpr body_ty ReturnsCPR +mkWWcpr body_ty RetCPR | not (isAlgType body_ty) = WARN( True, text "mkWWcpr: non-algebraic body type" <+> ppr body_ty ) returnUs (id, id, body_ty) @@ -520,6 +417,9 @@ mkWWcpr body_ty ReturnsCPR n_con_args = length con_arg_tys con_arg_ty1 = head con_arg_tys +mkWWcpr body_ty other -- No CPR info + = returnUs (id, id, body_ty) + -- If the original function looked like -- f = \ x -> _scc_ "foo" E -- @@ -558,6 +458,8 @@ mk_unpk_case arg unpk_args boxing_con boxing_tycon body (sanitiseCaseBndr arg) [(DataAlt boxing_con, unpk_args, body)] +mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) [(DEFAULT, [], body)] + sanitiseCaseBndr :: Id -> Id -- The argument we are scrutinising has the right type to be -- a case binder, so it's convenient to re-use it for that purpose. @@ -574,7 +476,5 @@ mk_pk_let arg boxing_con con_tys unpk_args body where con_args = map Type con_tys ++ map Var unpk_args - mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty - \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 81e6077..70f99fd 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -16,7 +16,7 @@ import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), isClassOpSig, isPragSig, getClassDeclSysNames, placeHolderType ) -import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) +import BasicTypes ( TopLevelFlag(..), RecFlag(..), StrictnessMark(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedClassOpSig, RenamedMonoBinds, RenamedContext, RenamedSig, @@ -42,7 +42,6 @@ import Class ( classTyVars, classBigSig, classTyCon, Class, ClassOpItem, DefMeth (..) ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon ) -import Demand ( StrictnessMark(..) ) import Id ( Id, idType, idName ) import Module ( Module ) import Name ( Name, NamedThing(..) ) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 486976d..8601331 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -15,8 +15,7 @@ import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) import TcHsSyn ( TcExpr, TcRecordBinds, mkHsLet ) import TcMonad -import BasicTypes ( RecFlag(..) ) - +import BasicTypes ( RecFlag(..), isMarkedStrict ) import Inst ( InstOrigin(..), LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit, newMethod, newIPDict, @@ -50,7 +49,6 @@ import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) import DataCon ( dataConFieldLabels, dataConSig, dataConStrictMarks ) -import Demand ( isMarkedStrict ) import Name ( Name ) import TyCon ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 8b255e4..0d4824d 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -35,7 +35,6 @@ import Type ( mkTyVarTys, splitTyConApp ) import TysWiredIn ( tupleCon ) import Var ( mkTyVar, tyVarKind ) import Name ( Name, nameIsLocalOrFrom ) -import Demand ( wwLazy ) import ErrUtils ( pprBagOfErrors ) import Outputable import Util ( zipWithEqual ) @@ -87,7 +86,6 @@ tcIdInfo unf_env in_scope_vars name ty info_ins init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) - tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity @@ -107,7 +105,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins returnTc info2 tcPrag info (HsStrictness strict_info) - = returnTc (info `setStrictnessInfo` strict_info) + = returnTc (info `setNewStrictnessInfo` Just strict_info) tcPrag info (HsWorker nm arity) = tcWorkerInfo unf_env ty info nm arity @@ -115,7 +113,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins \begin{code} tcWorkerInfo unf_env ty info worker_name arity - = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn -> + = uniqSMToTcM (mkWrapper ty strict_sig) `thenNF_Tc` \ wrap_fn -> let -- Watch out! We can't pull on unf_env too eagerly! info' = case tcLookupRecId_maybe unf_env worker_name of @@ -128,15 +126,11 @@ tcWorkerInfo unf_env ty info worker_name arity in returnTc info' where - -- We are relying here on cpr and strictness info always appearing + -- We are relying here on strictness info always appearing -- before worker info, fingers crossed .... - cpr_info = cprInfo info - - (demands, res_bot) - = case strictnessInfo info of - StrictnessInfo d r -> (d,r) - _ -> (take arity (repeat wwLazy),False) - -- Noncommittal + strict_sig = case newStrictnessInfo info of + Just sig -> sig + Nothing -> pprPanic "Worker info but no strictness for" (ppr worker_name) \end{code} For unfoldings we try to do the job lazily, so that we never type check -- 1.7.10.4