From 973539a893ff512a3e9ac408c1583a080de0abf4 Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 10 Dec 2001 14:07:31 +0000 Subject: [PATCH] [project @ 2001-12-10 14:07:30 by simonmar] Make the inclusion of the old strictness analyser, CPR analyser, and the relevant IdInfo components, conditional on DEBUG. This makes IdInfo smaller by three fields in a non-DEBUG compiler, and reduces the risk that the unused fields could harbour space leaks. Eventually these passes will go away altogether. --- ghc/compiler/basicTypes/Id.lhs | 45 ++++++++---- ghc/compiler/basicTypes/IdInfo.lhs | 118 +++++++++++++++++++------------ ghc/compiler/basicTypes/MkId.lhs | 9 ++- ghc/compiler/coreSyn/PprCore.lhs | 29 +++++--- ghc/compiler/cprAnalysis/CprAnalyse.lhs | 10 +-- ghc/compiler/prelude/PrimOp.lhs | 6 +- ghc/compiler/prelude/primops.txt.pp | 27 ++----- ghc/compiler/simplCore/SimplCore.lhs | 11 ++- ghc/compiler/stranal/DmdAnal.lhs | 24 +++++-- ghc/compiler/stranal/StrictAnal.lhs | 12 ++-- 10 files changed, 174 insertions(+), 117 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 9047cd7..75cce86 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -44,29 +44,38 @@ module Id ( -- IdInfo stuff setIdUnfolding, setIdArity, - setIdDemandInfo, setIdNewDemandInfo, - setIdStrictness, setIdNewStrictness, zapIdNewStrictness, + setIdNewDemandInfo, + setIdNewStrictness, zapIdNewStrictness, setIdTyGenInfo, setIdWorkerInfo, setIdSpecialisation, setIdCgInfo, - setIdCprInfo, setIdOccInfo, +#ifdef DEBUG + idDemandInfo, + idStrictness, + idCprInfo, + setIdStrictness, + setIdDemandInfo, + setIdCprInfo, +#endif + idArity, - idDemandInfo, idNewDemandInfo, - idStrictness, idNewStrictness, idNewStrictness_maybe, + idNewDemandInfo, + idNewStrictness, idNewStrictness_maybe, idTyGenInfo, idWorkerInfo, idUnfolding, idSpecialisation, idCgInfo, idCafInfo, - idCprInfo, idLBVarInfo, idOccInfo, +#ifdef DEBUG newStrictnessFromOld -- Temporary +#endif ) where @@ -104,20 +113,21 @@ import SrcLoc ( SrcLoc ) import Outputable import Unique ( Unique, mkBuiltinUnique ) +-- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfolding`, `setIdArity`, - `setIdDemandInfo`, - `setIdStrictness`, `setIdNewDemandInfo`, `setIdNewStrictness`, `setIdTyGenInfo`, `setIdWorkerInfo`, `setIdSpecialisation`, `setInlinePragma`, - `idCafInfo`, - `idCprInfo` - - -- infixl so you can say (id `set` a `set` b) + `idCafInfo` +#ifdef DEBUG + ,`idCprInfo` + ,`setIdStrictness` + ,`setIdDemandInfo` +#endif \end{code} @@ -311,13 +321,15 @@ idArity id = arityInfo (idInfo id) setIdArity :: Id -> Arity -> Id setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id +#ifdef DEBUG --------------------------------- - -- STRICTNESS + -- (OLD) STRICTNESS idStrictness :: Id -> StrictnessInfo idStrictness id = strictnessInfo (idInfo id) setIdStrictness :: Id -> StrictnessInfo -> Id setIdStrictness id strict_info = modifyIdInfo (`setStrictnessInfo` strict_info) id +#endif -- isBottomingId returns true if an application to n args would diverge isBottomingId :: Id -> Bool @@ -359,13 +371,15 @@ idUnfolding id = unfoldingInfo (idInfo id) setIdUnfolding :: Id -> Unfolding -> Id setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id +#ifdef DEBUG --------------------------------- - -- DEMAND + -- (OLD) DEMAND idDemandInfo :: Id -> Demand.Demand idDemandInfo id = demandInfo (idInfo id) setIdDemandInfo :: Id -> Demand.Demand -> Id setIdDemandInfo id demand_info = modifyIdInfo (`setDemandInfo` demand_info) id +#endif idNewDemandInfo :: Id -> NewDemand.Demand idNewDemandInfo id = newDemandInfo (idInfo id) @@ -405,14 +419,15 @@ idCafInfo id = case cgInfo (idInfo id) of #else idCafInfo id = cgCafInfo (idCgInfo id) #endif - --------------------------------- -- CPR INFO +#ifdef DEBUG idCprInfo :: Id -> CprInfo idCprInfo id = cprInfo (idInfo id) setIdCprInfo :: Id -> CprInfo -> Id setIdCprInfo id cpr_info = modifyIdInfo (`setCprInfo` cpr_info) id +#endif --------------------------------- -- Occcurrence INFO diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 7541f74..f6fb587 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -25,14 +25,13 @@ module IdInfo ( -- New demand and strictness info newStrictnessInfo, setNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, newDemand, oldDemand, + newDemandInfo, setNewDemandInfo, -- Strictness; imported from Demand StrictnessInfo(..), mkStrictnessInfo, noStrictnessInfo, ppStrictnessInfo,isBottomingStrictness, - strictnessInfo, setStrictnessInfo, setAllStrictnessInfo, - oldStrictnessFromNew, newStrictnessFromOld, cprInfoFromNewStrictness, + setAllStrictnessInfo, -- Usage generalisation TyGenInfo(..), @@ -46,8 +45,17 @@ module IdInfo ( -- Unfolding unfoldingInfo, setUnfoldingInfo, - -- DemandInfo +#ifdef DEBUG + -- Old DemandInfo and StrictnessInfo demandInfo, setDemandInfo, + strictnessInfo, setStrictnessInfo, + cprInfoFromNewStrictness, + oldStrictnessFromNew, newStrictnessFromOld, + oldDemand, newDemand, + + -- Constructed Product Result Info + CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, +#endif -- Inline prags InlinePragInfo, @@ -69,9 +77,6 @@ module IdInfo ( -- CAF info CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs, - -- Constructed Product Result Info - CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, - -- Lambda-bound variable info LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo ) where @@ -95,25 +100,19 @@ import DataCon ( DataCon ) import ForeignCall ( ForeignCall ) import FieldLabel ( FieldLabel ) import Type ( usOnce, usMany ) -import Demand hiding( Demand ) +import Demand hiding( Demand, seqDemand ) import qualified Demand -import NewDemand ( Demand(..), DmdResult(..), Demands(..), - lazyDmd, topDmd, dmdTypeDepth, isStrictDmd, isBotRes, - splitStrictSig, strictSigResInfo, - StrictSig, mkStrictSig, mkTopDmdType, evalDmd, lazyDmd - ) +import NewDemand import Outputable import Util ( seqList, listLengthCmp ) import List ( replicate ) -infixl 1 `setDemandInfo`, - `setTyGenInfo`, - `setStrictnessInfo`, +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setTyGenInfo`, `setSpecInfo`, `setArityInfo`, `setInlinePragInfo`, `setUnfoldingInfo`, - `setCprInfo`, `setWorkerInfo`, `setLBVarInfo`, `setOccInfo`, @@ -122,7 +121,11 @@ infixl 1 `setDemandInfo`, `setNewStrictnessInfo`, `setAllStrictnessInfo`, `setNewDemandInfo` - -- infixl so you can say (id `set` a `set` b) +#ifdef DEBUG + `setCprInfo`, + `setDemandInfo`, + `setStrictnessInfo`, +#endif \end{code} %************************************************************************ @@ -138,13 +141,23 @@ setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo -- Set old and new strictness info setAllStrictnessInfo info Nothing = info { newStrictnessInfo = Nothing, +#ifdef DEBUG strictnessInfo = NoStrictnessInfo, - cprInfo = NoCPRInfo } + cprInfo = NoCPRInfo, +#endif + } setAllStrictnessInfo info (Just sig) = info { newStrictnessInfo = Just sig, +#ifdef DEBUG strictnessInfo = oldStrictnessFromNew sig, - cprInfo = cprInfoFromNewStrictness sig } + cprInfo = cprInfoFromNewStrictness sig, +#endif + } + +seqNewStrictnessInfo Nothing = () +seqNewStrictnessInfo (Just ty) = seqStrictSig ty +#ifdef DEBUG oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) where @@ -196,6 +209,8 @@ oldDemand (Defer d) = WwLazy False oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) oldDemand (Eval (Poly _)) = WwStrict oldDemand (Call _) = WwStrict + +#endif /* DEBUG */ \end{code} @@ -261,15 +276,17 @@ case. KSW 1999-04). \begin{code} data IdInfo = IdInfo { - arityInfo :: ArityInfo, -- Its arity - demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded + arityInfo :: !ArityInfo, -- Its arity specInfo :: CoreRules, -- Specialisations of this function which exist tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id +#ifdef DEBUG + cprInfo :: CprInfo, -- Function always constructs a product result + demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded strictnessInfo :: StrictnessInfo, -- Strictness properties +#endif workerInfo :: WorkerInfo, -- Pointer to Worker Function unfoldingInfo :: Unfolding, -- Its unfolding cgInfo :: CgInfo, -- Code generator info (arity, CAF info) - cprInfo :: CprInfo, -- Function always constructs a product result lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable inlinePragInfo :: InlinePragInfo, -- Inline pragma occInfo :: OccInfo, -- How it occurs @@ -286,21 +303,26 @@ seqIdInfo (IdInfo {}) = () megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info - = seqArity (arityInfo info) `seq` - seqDemand (demandInfo info) `seq` - seqRules (specInfo info) `seq` + = seqRules (specInfo info) `seq` seqTyGenInfo (tyGenInfo info) `seq` - seqStrictnessInfo (strictnessInfo info) `seq` seqWorker (workerInfo info) `seq` --- seqUnfolding (unfoldingInfo info) `seq` -- Omitting this improves runtimes a little, presumably because -- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqDemand (newDemandInfo info) `seq` + seqNewStrictnessInfo (newStrictnessInfo info) `seq` + +#ifdef DEBUG + Demand.seqDemand (demandInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` + seqCpr (cprInfo info) `seq` +#endif -- CgInfo is involved in a loop, so we have to be careful not to seq it -- too early. -- seqCg (cgInfo info) `seq` - seqCpr (cprInfo info) `seq` seqLBVar (lbvarInfo info) `seq` seqOccInfo (occInfo info) \end{code} @@ -313,7 +335,9 @@ setSpecInfo info sp = sp `seq` info { specInfo = sp } setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg } setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setOccInfo info oc = oc `seq` info { occInfo = oc } +#ifdef DEBUG setStrictnessInfo info st = st `seq` info { strictnessInfo = st } +#endif -- Try to avoid spack leaks by seq'ing setUnfoldingInfo info uf @@ -334,14 +358,18 @@ setUnfoldingInfo info uf -- actually increases residency significantly. = info { unfoldingInfo = uf } +#ifdef DEBUG setDemandInfo info dd = info { demandInfo = dd } +setCprInfo info cp = info { cprInfo = cp } +#endif + setArityInfo info ar = info { arityInfo = ar } setCgInfo info cg = info { cgInfo = cg } -setCprInfo info cp = info { cprInfo = cp } -setLBVarInfo info lb = info { lbvarInfo = lb } -setNewDemandInfo info dd = info { newDemandInfo = dd } -setNewStrictnessInfo info dd = info { newStrictnessInfo = dd } +setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } + +setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd } +setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } \end{code} @@ -351,13 +379,15 @@ vanillaIdInfo = IdInfo { cgInfo = noCgInfo, arityInfo = unknownArity, +#ifdef DEBUG + cprInfo = NoCPRInfo, demandInfo = wwLazy, + strictnessInfo = NoStrictnessInfo, +#endif specInfo = emptyCoreRules, tyGenInfo = noTyGenInfo, workerInfo = NoWorker, - strictnessInfo = NoStrictnessInfo, unfoldingInfo = noUnfolding, - cprInfo = NoCPRInfo, lbvarInfo = NoLBVarInfo, inlinePragInfo = AlwaysActive, occInfo = NoOccInfo, @@ -393,9 +423,6 @@ type ArityInfo = Arity -- The arity might increase later in the compilation process, if -- an extra lambda floats up to the binding site. -seqArity :: ArityInfo -> () -seqArity a = a `seq` () - unknownArity = 0 :: Arity ppArityInfo 0 = empty @@ -502,7 +529,7 @@ instance Show TyGenInfo where If this Id has a worker then we store a reference to it. Worker functions are generated by the worker/wrapper pass. This uses -information from the strictness and CPR analyses. +information from strictness analysis. There might not be a worker, even for a strict function, because: (a) the function might be small enough to inline, so no need @@ -534,7 +561,7 @@ data WorkerInfo = NoWorker -- w/w split. See comments in MkIface.ifaceId, with the 'Worker' code. seqWorker :: WorkerInfo -> () -seqWorker (HasWorker id _) = id `seq` () +seqWorker (HasWorker id a) = id `seq` a `seq` () seqWorker NoWorker = () ppWorkerInfo NoWorker = empty @@ -643,6 +670,7 @@ function has the CPR property and which components of the result are also CPRs. \begin{code} +#ifdef DEBUG data CprInfo = NoCPRInfo | ReturnsCPR -- Yes, this function returns a constructed product @@ -653,9 +681,7 @@ data CprInfo -- We used to keep nested info about sub-components, but -- we never used it so I threw it away -\end{code} -\begin{code} seqCpr :: CprInfo -> () seqCpr ReturnsCPR = () seqCpr NoCPRInfo = () @@ -670,6 +696,7 @@ instance Outputable CprInfo where instance Show CprInfo where showsPrec p c = showsPrecSDoc p (ppr c) +#endif \end{code} @@ -823,8 +850,11 @@ shortableIdInfo info = isEmptyCoreRules (specInfo info) copyIdInfo :: IdInfo -- f_local -> IdInfo -- f (the exported one) -> IdInfo -- New info for f -copyIdInfo f_local f = f { strictnessInfo = strictnessInfo f_local, - workerInfo = workerInfo f_local, +copyIdInfo f_local f = f { newStrictnessInfo = newStrictnessInfo f_local, +#ifdef DEBUG + strictnessInfo = strictnessInfo f_local, cprInfo = cprInfo f_local +#endif + workerInfo = workerInfo f_local, } \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index c112a2a..8562ea7 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -72,8 +72,8 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, import IdInfo ( IdInfo, noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo, setSpecInfo, setCafInfo, - newStrictnessFromOld, setAllStrictnessInfo, - GlobalIdDetails(..), CafInfo(..), CprInfo(..) + setAllStrictnessInfo, + GlobalIdDetails(..), CafInfo(..) ) import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), mkTopDmdType, topDmd, evalDmd, lazyDmd, @@ -640,7 +640,7 @@ mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op = id where - (tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkPrimOpIdName prim_op id = mkGlobalId (PrimOpId prim_op) name ty info @@ -648,8 +648,7 @@ mkPrimOpId prim_op info = noCafNoTyGenIdInfo `setSpecInfo` rules `setArityInfo` arity - `setAllStrictnessInfo` Just (newStrictnessFromOld name arity strict_info NoCPRInfo) - -- Until we modify the primop generation code + `setAllStrictnessInfo` Just strict_sig rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op) diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 85fd027..3a27b2b 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -20,18 +20,24 @@ module PprCore ( import CoreSyn import CostCentre ( pprCostCentreCore ) import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, - idInfo, idInlinePragma, idDemandInfo, idOccInfo, - globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId + idInfo, idInlinePragma, idOccInfo, +#ifdef DEBUG + idDemandInfo, +#endif + globalIdDetails, isGlobalId, isExportedId, + isSpecPragmaId, idNewDemandInfo ) import Var ( isTyVar ) import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, - specInfo, cprInfo, ppCprInfo, - strictnessInfo, ppStrictnessInfo, - cprInfo, ppCprInfo, + specInfo, ppStrictnessInfo, workerInfo, ppWorkerInfo, tyGenInfo, ppTyGenInfo, - newDemandInfo, newStrictnessInfo + newStrictnessInfo, +#ifdef DEBUG + cprInfo, ppCprInfo, + strictnessInfo, +#endif ) import DataCon ( dataConTyCon ) import TyCon ( tupleTyConBoxity, isTupleTyCon ) @@ -330,8 +336,11 @@ pprIdBndr id = ppr id <+> (megaSeqIdInfo (idInfo id) `seq` -- Useful for poking on black holes ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+> - ppr (idDemandInfo id)) <+> ppr (newDemandInfo (idInfo id)) <+> - ppr (idLBVarInfo id)) +#ifdef DEBUG + ppr (idDemandInfo id) <+> +#endif + ppr (idNewDemandInfo id) <+> + ppr (idLBVarInfo id))) \end{code} @@ -347,8 +356,10 @@ ppIdInfo b info = hsep [ ppArityInfo a, ppTyGenInfo g, ppWorkerInfo (workerInfo info), +#ifdef DEBUG ppStrictnessInfo s, ppCprInfo m, +#endif ppr (newStrictnessInfo info), pprCoreRules b p -- Inline pragma, occ, demand, lbvar info @@ -358,8 +369,10 @@ ppIdInfo b info where a = arityInfo info g = tyGenInfo info +#ifdef DEBUG s = strictnessInfo info m = cprInfo info +#endif p = specInfo info \end{code} diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index 88c9f2a..17c4f58 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -2,6 +2,11 @@ constructed product result} \begin{code} +#ifndef DEBUG +module CprAnalyse ( ) where + +#else + module CprAnalyse ( cprAnalyse ) where #include "HsVersions.h" @@ -131,11 +136,6 @@ 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" ; diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 628e28a..5259fc1 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -24,7 +24,7 @@ import PrimRep -- most of it import TysPrim import TysWiredIn -import Demand ( wwLazy, wwPrim, wwStrict, StrictnessInfo(..) ) +import NewDemand import Var ( TyVar ) import Name ( Name, mkWiredInName ) import RdrName ( RdrName, mkRdrOrig ) @@ -140,7 +140,7 @@ mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOcc str) tvs tys ty Not all primops are strict! \begin{code} -primOpStrictness :: PrimOp -> Arity -> StrictnessInfo +primOpStrictness :: PrimOp -> Arity -> StrictSig -- See Demand.StrictnessInfo for discussion of what the results -- The arity should be the arity of the primop; that's why -- this function isn't exported. @@ -415,7 +415,7 @@ primOpOcc op = case (primOpInfo op) of -- (type variables, argument types, result type) -- It also gives arity, strictness info -primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictnessInfo) +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) primOpSig op = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) where diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index 8d12268..8228ebb 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.11 2001/12/07 11:34:48 sewardj Exp $ +-- $Id: primops.txt.pp,v 1.12 2001/12/10 14:07:30 simonmar Exp $ -- -- Primitive Operations -- @@ -57,7 +57,7 @@ defaults commutable = False needs_wrapper = False can_fail = False - strictness = { \ arity -> StrictnessInfo (replicate arity wwPrim) False } + strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) } usage = { nomangle other } -- Currently, documentation is produced using latex, so contents of @@ -686,7 +686,6 @@ primop NewArrayOp "newArray#" GenPrimOp in the specified state thread, with each element containing the specified initial value.} with - strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } usage = { mangle NewArrayOp [mkP, mkM, mkP] mkM } out_of_line = True @@ -706,7 +705,6 @@ primop WriteArrayOp "writeArray#" GenPrimOp {Write to specified index of mutable array.} with usage = { mangle WriteArrayOp [mkM, mkP, mkM, mkP] mkR } - strictness = { \ arity -> StrictnessInfo [wwPrim, wwPrim, wwLazy, wwPrim] False } has_side_effects = True primop IndexArrayOp "indexArray#" GenPrimOp @@ -1164,7 +1162,6 @@ primop TouchOp "touch#" GenPrimOp o -> State# RealWorld -> State# RealWorld with has_side_effects = True - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } primop EqForeignObj "eqForeignObj#" GenPrimOp ForeignObj# -> ForeignObj# -> Bool @@ -1232,7 +1229,6 @@ primop NewMutVarOp "newMutVar#" GenPrimOp {Create MutVar\# with specified initial value in specified state thread.} with usage = { mangle NewMutVarOp [mkM, mkP] mkM } - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } out_of_line = True primop ReadMutVarOp "readMutVar#" GenPrimOp @@ -1245,7 +1241,6 @@ primop WriteMutVarOp "writeMutVar#" GenPrimOp MutVar# s a -> a -> State# s -> State# s {Write contents of MutVar\#.} with - strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } usage = { mangle WriteMutVarOp [mkM, mkM, mkP] mkR } has_side_effects = True @@ -1264,7 +1259,6 @@ primop CatchOp "catch#" GenPrimOp -> State# RealWorld -> (# State# RealWorld, a #) with - strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwPrim] False } -- Catch is actually strict in its first argument -- but we don't want to tell the strictness -- analyser about that! @@ -1276,8 +1270,8 @@ primop CatchOp "catch#" GenPrimOp primop RaiseOp "raise#" GenPrimOp a -> b with - strictness = { \ arity -> StrictnessInfo [wwLazy] True } - -- NB: True => result is bottom + strictness = { \ arity -> mkStrictSig (mkTopDmdType [lazyDmd] BotRes) } + -- NB: result is bottom usage = { mangle RaiseOp [mkM] mkM } out_of_line = True @@ -1285,14 +1279,12 @@ primop BlockAsyncExceptionsOp "blockAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } out_of_line = True primop UnblockAsyncExceptionsOp "unblockAsyncExceptions#" GenPrimOp (State# RealWorld -> (# State# RealWorld, a #)) -> (State# RealWorld -> (# State# RealWorld, a #)) with - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } out_of_line = True ------------------------------------------------------------------------ @@ -1333,7 +1325,6 @@ primop PutMVarOp "putMVar#" GenPrimOp {If mvar is full, block until it becomes empty. Then store value arg as its new contents.} with - strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } usage = { mangle PutMVarOp [mkM, mkM, mkP] mkR } has_side_effects = True out_of_line = True @@ -1343,7 +1334,6 @@ primop TryPutMVarOp "tryPutMVar#" GenPrimOp {If mvar is full, immediately return with integer 0. Otherwise, store value arg as mvar's new contents, and return with integer 1.} with - strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } usage = { mangle TryPutMVarOp [mkM, mkM, mkP] mkR } has_side_effects = True out_of_line = True @@ -1399,7 +1389,6 @@ primop ForkOp "fork#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, ThreadId# #) with usage = { mangle ForkOp [mkO, mkP] mkR } - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } has_side_effects = True out_of_line = True @@ -1430,7 +1419,6 @@ section "Weak pointers" primop MkWeakOp "mkWeak#" GenPrimOp o -> b -> c -> State# RealWorld -> (# State# RealWorld, Weak# b #) with - strictness = { \ arity -> StrictnessInfo [wwLazy, wwLazy, wwLazy, wwPrim] False } usage = { mangle MkWeakOp [mkZ, mkM, mkM, mkP] mkM } has_side_effects = True out_of_line = True @@ -1459,7 +1447,6 @@ section "Stable pointers and names" primop MakeStablePtrOp "makeStablePtr#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) with - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } usage = { mangle MakeStablePtrOp [mkM, mkP] mkM } has_side_effects = True out_of_line = True @@ -1482,7 +1469,6 @@ primop MakeStableNameOp "makeStableName#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, StableName# a #) with usage = { mangle MakeStableNameOp [mkZ, mkP] mkR } - strictness = { \ arity -> StrictnessInfo [wwLazy, wwPrim] False } needs_wrapper = True has_side_effects = True out_of_line = True @@ -1505,7 +1491,7 @@ primop SeqOp "seq#" GenPrimOp a -> Int# with usage = { mangle SeqOp [mkO] mkR } - strictness = { \ arity -> StrictnessInfo [wwStrict] False } + strictness = { \ arity -> mkStrictSig (mkTopDmdType [evalDmd] TopRes) } -- Seq is strict in its argument; see notes in ConFold.lhs has_side_effects = True @@ -1513,7 +1499,6 @@ primop ParOp "par#" GenPrimOp a -> Int# with usage = { mangle ParOp [mkO] mkR } - strictness = { \ arity -> StrictnessInfo [wwLazy] False } -- Note that Par is lazy to avoid that the sparked thing -- gets evaluted strictly, which it should *not* be has_side_effects = True @@ -1583,8 +1568,6 @@ section "Tag to enum stuff" primop DataToTagOp "dataToTag#" GenPrimOp a -> Int# - with - strictness = { \ arity -> StrictnessInfo [wwLazy] False } primop TagToEnumOp "tagToEnum#" GenPrimOp Int# -> a diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index f5fb7c9..2ff3caa 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -151,16 +151,17 @@ doCorePass dfs rb us binds (CoreDoFloatOutwards f) doCorePass dfs rb us binds CoreDoStaticArgs = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds) doCorePass dfs rb us binds CoreDoStrictness - = _scc_ "Stranal" noStats dfs (do { binds1 <- saBinds dfs binds ; - dmdAnalPgm dfs binds1 }) + = _scc_ "Stranal" noStats dfs (strictAnal dfs binds) doCorePass dfs rb us binds CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds) doCorePass dfs rb us binds CoreDoSpecialising = _scc_ "Specialise" noStats dfs (specProgram dfs us binds) doCorePass dfs rb us binds CoreDoSpecConstr = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds) +#ifdef DEBUG doCorePass dfs rb us binds CoreDoCPResult = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds) +#endif doCorePass dfs rb us binds CoreDoPrintCore = _scc_ "PrintCore" noStats dfs (printCore binds) doCorePass dfs rb us binds CoreDoUSPInf @@ -172,6 +173,12 @@ doCorePass dfs rb us binds (CoreDoRuleCheck phase pat) doCorePass dfs rb us binds CoreDoNothing = noStats dfs (return binds) +strictAnal dfs binds = do +#ifdef DEBUG + binds <- saBinds dfs binds +#endif + dmdAnalPgm dfs binds + printCore binds = do dumpIfSet True "Print Core" (pprCoreBindings binds) return binds diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index f23802e..20b07fb 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -20,11 +20,18 @@ import PprCore import CoreUtils ( exprIsValue, exprArity ) import DataCon ( dataConTyCon ) import TyCon ( isProductTyCon, isRecursiveTyCon ) -import Id ( Id, idType, idDemandInfo, idInlinePragma, +import Id ( Id, idType, idInlinePragma, isDataConId, isGlobalId, idArity, - idNewStrictness, idNewStrictness_maybe, setIdNewStrictness, - idNewDemandInfo, setIdNewDemandInfo, idName, idStrictness, idCprInfo ) -import IdInfo ( newDemand, newStrictnessFromOld ) +#ifdef DEBUG + idDemandInfo, idStrictness, idCprInfo, +#endif + idNewStrictness, idNewStrictness_maybe, + setIdNewStrictness, idNewDemandInfo, + setIdNewDemandInfo, idName + ) +#ifdef DEBUG +import IdInfo ( newStrictnessFromOld, newDemand ) +#endif import Var ( Var ) import VarEnv import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, @@ -60,12 +67,13 @@ dmdAnalPgm :: DynFlags -> [CoreBind] -> IO [CoreBind] dmdAnalPgm dflags binds = do { showPass dflags "Demand analysis" ; - let { binds_plus_dmds = do_prog binds ; - dmd_changes = get_changes binds_plus_dmds } ; + let { binds_plus_dmds = do_prog binds } ; endPass dflags "Demand analysis" Opt_D_dump_stranal binds_plus_dmds ; #ifdef DEBUG - -- Only if DEBUG is on, because only then is the old strictness analyser run + -- Only if DEBUG is on, because only then is the old + -- strictness analyser run + let dmd_changes = get_changes binds_plus_dmds ; printDump (text "Changes in demands" $$ dmd_changes) ; #endif return binds_plus_dmds @@ -996,6 +1004,7 @@ boths = zipWithDmds both \begin{code} +#ifdef DEBUG get_changes binds = vcat (map get_changes_bind binds) get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs) @@ -1047,6 +1056,7 @@ get_changes_dmd id old = newDemand (idDemandInfo id) new_better = new `betterDemand` old old_better = old `betterDemand` new +#endif squashSig (StrictSig (DmdType fv ds res)) = StrictSig (DmdType emptyDmdEnv (map squashDmd ds) res) diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index fce4fbd..85aec7c 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -7,6 +7,11 @@ The original version(s) of all strictness-analyser code (except the Semantique analyser) was written by Andy Gill. \begin{code} +#ifndef DEBUG +module StrictAnal ( ) where + +#else + module StrictAnal ( saBinds ) where #include "HsVersions.h" @@ -80,12 +85,6 @@ 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"; @@ -490,5 +489,6 @@ sequenceSa [] = returnSa [] sequenceSa (m:ms) = m `thenSa` \ r -> sequenceSa ms `thenSa` \ rs -> returnSa (r:rs) + #endif /* DEBUG */ \end{code} -- 1.7.10.4