X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=d53bf5627d99638a48f0f07e57eb846b4e0dc65a;hb=c5b03909e7c630a874f6f1abf76d28baf4b19d55;hp=47ce3a8129065cae7faa2641df50557fa97fe038;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 47ce3a8..d53bf56 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} @@ -7,1166 +7,693 @@ Haskell. [WDP 94/11]) \begin{code} -#include "HsVersions.h" - module IdInfo ( - IdInfo, -- abstract - noIdInfo, - boringIdInfo, - ppIdInfo, - applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please + GlobalIdDetails(..), notGlobalId, -- Not abstract + + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + seqIdInfo, megaSeqIdInfo, - OptIdInfo(..), -- class; for convenience only, really - -- all the *Infos herein are instances of it + -- Zapping + zapLamInfo, zapDemandInfo, - -- component "id infos"; also abstract: + -- Arity ArityInfo, - mkArityInfo, unknownArity, arityMaybe, - - DemandInfo, - mkDemandInfo, - willBeDemanded, - - SpecEnv, SpecInfo(..), - nullSpecEnv, mkSpecEnv, addOneToSpecEnv, - lookupSpecId, lookupSpecEnv, lookupConstMethodId, - - SrcLoc, - getSrcLocIdInfo, - - StrictnessInfo(..), -- non-abstract - Demand(..), -- non-abstract - wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, ---UNUSED: isStrict, absentArg, - indicatesWorker, nonAbsentArgs, - mkStrictnessInfo, mkBottomStrictnessInfo, - getWrapperArgTypeCategories, - getWorkerId, - workerExists, - bottomIsGuaranteed, - - UnfoldingDetails(..), -- non-abstract! re-exported - UnfoldingGuidance(..), -- non-abstract; ditto - mkUnfolding, ---OLD: mkUnfolding_NoGuideGiven, -- a convenient interface; for imported things only - iWantToBeINLINEd, mkMagicUnfolding, ---UNUSED: haveUnfolding, - noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus ---UNUSED: clearInfo_UF, - - UpdateInfo, - mkUpdateInfo, - UpdateSpec(..), - updateInfoMaybe, - - DeforestInfo(..), - - ArgUsageInfo, - ArgUsage(..), - ArgUsageType(..), - mkArgUsageInfo, - getArgUsage, - - FBTypeInfo, - FBType(..), - FBConsum(..), - FBProd(..), - mkFBTypeInfo, - getFBType, - - -- and to make the interface self-sufficient... - Bag, BasicLit, BinderInfo, CoreAtom, CoreExpr, Id, - IdEnv(..), UniqFM, Unique, IdVal, FormSummary, - InstTemplate, MagicUnfoldingFun, Maybe, UniType, UniqSM(..), - SimplifiableBinder(..), SimplifiableCoreExpr(..), - PlainCoreExpr(..), PlainCoreAtom(..), PprStyle, Pretty(..), - PrettyRep, UniqueSupply, InExpr(..), OutAtom(..), OutExpr(..), - OutId(..), Subst - - -- and to make sure pragmas work... - IF_ATTACK_PRAGMAS(COMMA mkUnknownSrcLoc) - ) where + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + -- New demand and strictness info + newStrictnessInfo, setNewStrictnessInfo, + newDemandInfo, setNewDemandInfo, pprNewStrictness, + setAllStrictnessInfo, + +#ifdef OLD_STRICTNESS + -- Strictness; imported from Demand + StrictnessInfo(..), + mkStrictnessInfo, noStrictnessInfo, + ppStrictnessInfo,isBottomingStrictness, +#endif -IMPORT_Trace -- ToDo: rm (debugging) + -- Worker + WorkerInfo(..), workerExists, wrapperArity, workerId, + workerInfo, setWorkerInfo, ppWorkerInfo, -import AbsPrel ( mkFunTy, nilDataCon{-HACK-} - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AbsUniType -import Bag ( emptyBag, Bag ) -import CmdLineOpts ( GlobalSwitch(..) ) -import Id ( getIdUniType, getDataConSig, - getInstantiatedDataConSig, getIdInfo, - externallyVisibleId, isDataCon, - unfoldingUnfriendlyId, isWorkerId, - isWrapperId, DataCon(..) - IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToId) - IF_ATTACK_PRAGMAS(COMMA getIdStrictness) -- profiling - ) -import IdEnv -- ( nullIdEnv, lookupIdEnv ) -import Inst ( apply_to_Inst, applySubstToInst, Inst ) -import MagicUFs -import Maybes -import Outputable -import PlainCore -import Pretty -import SimplEnv -- UnfoldingDetails(..), UnfoldingGuidance(..) -import SrcLoc -import Subst ( applySubstToTy, Subst ) -import OccurAnal ( occurAnalyseGlobalExpr ) -import TaggedCore -- SimplifiableCore* ... -import Unique -import Util -import WwLib ( mAX_WORKER_ARGS ) -\end{code} + -- Unfolding + unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, -An @IdInfo@ gives {\em optional} information about an @Id@. If -present it never lies, but it may not be present, in which case there -is always a conservative assumption which can be made. +#ifdef OLD_STRICTNESS + -- Old DemandInfo and StrictnessInfo + demandInfo, setDemandInfo, + strictnessInfo, setStrictnessInfo, + cprInfoFromNewStrictness, + oldStrictnessFromNew, newStrictnessFromOld, + oldDemand, newDemand, -Two @Id@s may have different info even though they have the same -@Unique@ (and are hence the same @Id@); for example, one might lack -the properties attached to the other. + -- Constructed Product Result Info + CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, +#endif -The @IdInfo@ gives information about the value, or definition, of the -@Id@. It does {\em not} contain information about the @Id@'s usage -(except for @DemandInfo@? ToDo). + -- Inline prags + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, -\begin{code} -data IdInfo - = IdInfo - ArityInfo -- Its arity - - DemandInfo -- Whether or not it is definitely - -- demanded + -- Occurrence info + OccInfo(..), isFragileOcc, isDeadOcc, isLoopBreaker, + InsideLam, OneBranch, insideLam, notInsideLam, oneBranch, notOneBranch, + occInfo, setOccInfo, - SpecEnv -- Specialisations of this function which exist + -- Specialisation + SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, + specInfoFreeVars, specInfoRules, seqSpecInfo, - StrictnessInfo -- Strictness properties, notably - -- how to conjure up "worker" functions + -- CAF info + CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, - UnfoldingDetails -- Its unfolding; for locally-defined - -- things, this can *only* be NoUnfoldingDetails - -- or IWantToBeINLINEd (i.e., INLINE pragma). + -- Lambda-bound variable info + LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo + ) where - UpdateInfo -- Which args should be updated +#include "HsVersions.h" - DeforestInfo -- Whether its definition should be - -- unfolded during deforestation - ArgUsageInfo -- how this Id uses its arguments +import CoreSyn +import Class ( Class ) +import PrimOp ( PrimOp ) +import Var ( Id ) +import VarSet ( VarSet, emptyVarSet, seqVarSet ) +import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch, + Arity, + Activation(..) + ) +import DataCon ( DataCon ) +import TyCon ( TyCon, FieldLabel ) +import ForeignCall ( ForeignCall ) +import NewDemand +import Outputable +import Maybe ( isJust ) + +#ifdef OLD_STRICTNESS +import Name ( Name ) +import Demand hiding( Demand, seqDemand ) +import qualified Demand +import Util ( listLengthCmp ) +import List ( replicate ) +#endif - FBTypeInfo -- the Foldr/Build W/W property of this function. +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setSpecInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setWorkerInfo`, + `setLBVarInfo`, + `setOccInfo`, + `setCafInfo`, + `setNewStrictnessInfo`, + `setAllStrictnessInfo`, + `setNewDemandInfo` +#ifdef OLD_STRICTNESS + , `setCprInfo` + , `setDemandInfo` + , `setStrictnessInfo` +#endif +\end{code} - SrcLoc -- Source location of definition +%************************************************************************ +%* * +\subsection{New strictness info} +%* * +%************************************************************************ - -- ToDo: SrcLoc is in FullNames too (could rm?) but it - -- is needed here too for things like ConstMethodIds and the - -- like, which don't have full-names of their own Mind you, - -- perhaps the FullName for a constant method could give the - -- class/type involved? -\end{code} +To be removed later \begin{code} -noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF - noInfo noInfo noInfo noInfo mkUnknownSrcLoc - --- "boring" means: nothing to put an interface -boringIdInfo (IdInfo UnknownArity - UnknownDemand - nullSpecEnv - strictness - unfolding - NoUpdateInfo - Don'tDeforest - _ {- arg_usage: currently no interface effect -} - _ {- no f/b w/w -} - _ {- src_loc: no effect on interfaces-}) - | boring_strictness strictness - && boring_unfolding unfolding - = True - where - boring_strictness NoStrictnessInfo = True - boring_strictness BottomGuaranteed = False - boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args +-- setAllStrictnessInfo :: IdInfo -> Maybe StrictSig -> IdInfo +-- Set old and new strictness info +setAllStrictnessInfo info Nothing + = info { newStrictnessInfo = Nothing +#ifdef OLD_STRICTNESS + , strictnessInfo = NoStrictnessInfo + , cprInfo = NoCPRInfo +#endif + } - boring_unfolding NoUnfoldingDetails = True - boring_unfolding _ = False +setAllStrictnessInfo info (Just sig) + = info { newStrictnessInfo = Just sig +#ifdef OLD_STRICTNESS + , strictnessInfo = oldStrictnessFromNew sig + , cprInfo = cprInfoFromNewStrictness sig +#endif + } -boringIdInfo _ = False +seqNewStrictnessInfo Nothing = () +seqNewStrictnessInfo (Just ty) = seqStrictSig ty -pp_NONE = ppPStr SLIT("_N_") -\end{code} +pprNewStrictness Nothing = empty +pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig -Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@ -will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very -nasty loop, friends...) -\begin{code} -apply_to_IdInfo ty_fn - (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc) - = let - new_spec = apply_spec spec - - -- NOT a good idea: - -- apply_strict strictness `thenLft` \ new_strict -> - -- apply_wrap wrap `thenLft` \ new_wrap -> - in - IdInfo arity demand - new_spec strictness unfold - update deforest arg_usage fb_ww srcloc - where - apply_spec (SpecEnv is) - = SpecEnv (map do_one is) - where - do_one (SpecInfo ty_maybes ds spec_id) - = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id -> - SpecInfo (map apply_to_maybe ty_maybes) ds spec_id - where - apply_to_maybe Nothing = Nothing - apply_to_maybe (Just ty) = Just (ty_fn ty) - -{- NOT a good idea; - apply_strict info@NoStrictnessInfo = returnLft info - apply_strict BottomGuaranteed = ??? - apply_strict (StrictnessInfo wrap_arg_info id_maybe) - = (case id_maybe of - Nothing -> returnLft Nothing - Just xx -> applySubstToId subst xx `thenLft` \ new_xx -> - returnLft (Just new_xx) - ) `thenLft` \ new_id_maybe -> - returnLft (StrictnessInfo wrap_arg_info new_id_maybe) --} -\end{code} +#ifdef OLD_STRICTNESS +oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo +oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) + where + (dmds, res_info) = splitStrictSig sig -Variant of the same thing for the typechecker. -\begin{code} -applySubstToIdInfo s0 - (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww srcloc) - = case (apply_spec s0 spec) of { (s1, new_spec) -> - (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) } - where - apply_spec s0 (SpecEnv is) - = case (mapAccumL do_one s0 is) of { (s1, new_is) -> - (s1, SpecEnv new_is) } - where - do_one s0 (SpecInfo ty_maybes ds spec_id) - = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) -> - (s1, SpecInfo new_maybes ds spec_id) } - where - apply_to_maybe s0 Nothing = (s0, Nothing) - apply_to_maybe s0 (Just ty) - = case (applySubstToTy s0 ty) of { (s1, new_ty) -> - (s1, Just new_ty) } -\end{code} +cprInfoFromNewStrictness :: StrictSig -> CprInfo +cprInfoFromNewStrictness sig = case strictSigResInfo sig of + RetCPR -> ReturnsCPR + other -> NoCPRInfo -\begin{code} -ppIdInfo :: PprStyle - -> Id -- The Id for which we're printing this IdInfo - -> Bool -- True <=> print specialisations, please - -> (Id -> Id) -- to look up "better Ids" w/ better IdInfos; - -> IdEnv UnfoldingDetails - -- inlining info for top-level fns in this module - -> IdInfo -- see MkIface notes - -> Pretty - -ppIdInfo sty for_this_id specs_please better_id_fn inline_env - i@(IdInfo arity demand specialise strictness unfold update deforest arg_usage fbtype srcloc) - | boringIdInfo i - = ppPStr SLIT("_NI_") +newStrictnessFromOld :: Name -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig +newStrictnessFromOld name arity (Demand.StrictnessInfo ds res) cpr + | listLengthCmp ds arity /= GT -- length ds <= arity + -- Sometimes the old strictness analyser has more + -- demands than the arity justifies + = mk_strict_sig name arity $ + mkTopDmdType (map newDemand ds) (newRes res cpr) - | otherwise - = let - stuff = ppCat [ - -- order is important!: - ppInfo sty better_id_fn arity, - ppInfo sty better_id_fn update, - ppInfo sty better_id_fn deforest, - pp_strictness sty (Just for_this_id) - better_id_fn inline_env strictness, - pp_unfolding sty for_this_id inline_env unfold, - if specs_please - then pp_specs sty (not (isDataCon for_this_id)) - better_id_fn inline_env specialise - else pp_NONE, - - -- DemandInfo needn't be printed since it has no effect on interfaces - ppInfo sty better_id_fn demand, - ppInfo sty better_id_fn fbtype - ] - in - case sty of - PprInterface sw_chker -> if sw_chker OmitInterfacePragmas - then ppNil - else stuff - _ -> stuff -\end{code} +newStrictnessFromOld name arity other cpr + = -- Either no strictness info, or arity is too small + -- In either case we can't say anything useful + mk_strict_sig name arity $ + mkTopDmdType (replicate arity lazyDmd) (newRes False cpr) -\begin{code} -{- OLD: -pp_info_op :: String -> Pretty -- like pprNonOp - -pp_info_op name - = if isAvarop name || isAconop name - then ppBesides [ppLparen, ppStr name, ppRparen] - else ppStr name --} -\end{code} +mk_strict_sig name arity dmd_ty + = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) ) + mkStrictSig dmd_ty -%************************************************************************ -%* * -\subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)} -%* * -%************************************************************************ +newRes True _ = BotRes +newRes False ReturnsCPR = retCPR +newRes False NoCPRInfo = TopRes -\begin{code} -class OptIdInfo a where - noInfo :: a - getInfo :: IdInfo -> a - addInfo :: IdInfo -> a -> IdInfo - -- By default, "addInfo" will not overwrite - -- "info" with "non-info"; look at any instance - -- to see an example. - ppInfo :: PprStyle -> (Id -> Id) -> a -> Pretty +newDemand :: Demand.Demand -> NewDemand.Demand +newDemand (WwLazy True) = Abs +newDemand (WwLazy False) = lazyDmd +newDemand WwStrict = evalDmd +newDemand (WwUnpack unpk ds) = Eval (Prod (map newDemand ds)) +newDemand WwPrim = lazyDmd +newDemand WwEnum = evalDmd + +oldDemand :: NewDemand.Demand -> Demand.Demand +oldDemand Abs = WwLazy True +oldDemand Top = WwLazy False +oldDemand Bot = WwStrict +oldDemand (Box Bot) = WwStrict +oldDemand (Box Abs) = WwLazy False +oldDemand (Box (Eval _)) = WwStrict -- Pass box only +oldDemand (Defer d) = WwLazy False +oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) +oldDemand (Eval (Poly _)) = WwStrict +oldDemand (Call _) = WwStrict + +#endif /* OLD_STRICTNESS */ \end{code} -%************************************************************************ -%* * -\subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@} -%* * -%************************************************************************ -Not used much, but... \begin{code} -getSrcLocIdInfo (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc +seqNewDemandInfo Nothing = () +seqNewDemandInfo (Just dmd) = seqDemand dmd \end{code} + %************************************************************************ %* * -\subsection[arity-IdInfo]{Arity info about an @Id@} +\subsection{GlobalIdDetails %* * %************************************************************************ -\begin{code} -data ArityInfo - = UnknownArity -- no idea - | ArityExactly Int -- arity is exactly this -\end{code} +This type is here (rather than in Id.lhs) mainly because there's +an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported +(recursively) by Var.lhs. \begin{code} -mkArityInfo = ArityExactly -unknownArity = UnknownArity +data GlobalIdDetails + = VanillaGlobal -- Imported from elsewhere, a default method Id. -arityMaybe :: ArityInfo -> Maybe Int + | RecordSelId -- The Id for a record selector + { sel_tycon :: TyCon + , sel_label :: FieldLabel + , sel_naughty :: Bool -- True <=> naughty + } -- See Note [Naughty record selectors] + -- with MkId.mkRecordSelectorId -arityMaybe UnknownArity = Nothing -arityMaybe (ArityExactly i) = Just i -\end{code} + | DataConWorkId DataCon -- The Id for a data constructor *worker* + | DataConWrapId DataCon -- The Id for a data constructor *wrapper* + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] -\begin{code} -instance OptIdInfo ArityInfo where - noInfo = UnknownArity + | ClassOpId Class -- An operation of a class - getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity + | PrimOpId PrimOp -- The Id for a primitive operator + | FCallId ForeignCall -- The Id for a foreign call - addInfo id_info UnknownArity = id_info - addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j + | NotGlobalId -- Used as a convenient extra return value from globalIdDetails + +notGlobalId = NotGlobalId - ppInfo sty _ UnknownArity = ifPprInterface sty pp_NONE - ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity] +instance Outputable GlobalIdDetails where + ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") + ppr VanillaGlobal = ptext SLIT("[GlobalId]") + ppr (DataConWorkId _) = ptext SLIT("[DataCon]") + ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]") + ppr (ClassOpId _) = ptext SLIT("[ClassOp]") + ppr (PrimOpId _) = ptext SLIT("[PrimOp]") + ppr (FCallId _) = ptext SLIT("[ForeignCall]") + ppr (RecordSelId {}) = ptext SLIT("[RecSel]") \end{code} + %************************************************************************ %* * -\subsection[demand-IdInfo]{Demand info about an @Id@} +\subsection{The main IdInfo type} %* * %************************************************************************ -Whether a value is certain to be demanded or not. (This is the -information that is computed by the ``front-end'' of the strictness -analyser.) +An @IdInfo@ gives {\em optional} information about an @Id@. If +present it never lies, but it may not be present, in which case there +is always a conservative assumption which can be made. + +Two @Id@s may have different info even though they have the same +@Unique@ (and are hence the same @Id@); for example, one might lack +the properties attached to the other. -This information is only used within a module, it is not exported -(obviously). +The @IdInfo@ gives information about the value, or definition, of the +@Id@. It does {\em not} contain information about the @Id@'s usage +(except for @DemandInfo@? ToDo). (@lbvarInfo@ is also a marginal +case. KSW 1999-04). \begin{code} -data DemandInfo - = UnknownDemand - | DemandedAsPer Demand -\end{code} +data IdInfo + = IdInfo { + arityInfo :: !ArityInfo, -- Its arity + specInfo :: SpecInfo, -- Specialisations of this function which exist +#ifdef OLD_STRICTNESS + 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 + -- Within one module this is irrelevant; the + -- inlining of a worker is handled via the Unfolding + -- WorkerInfo is used *only* to indicate the form of + -- the RHS, so that interface files don't actually + -- need to contain the RHS; it can be derived from + -- the strictness info + + unfoldingInfo :: Unfolding, -- Its unfolding + cafInfo :: CafInfo, -- CAF info + lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable + inlinePragInfo :: InlinePragInfo, -- Inline pragma + occInfo :: OccInfo, -- How it occurs + + newStrictnessInfo :: Maybe StrictSig, -- Reason for Maybe: the DmdAnal phase needs to + -- know whether whether this is the first visit, + -- so it can assign botSig. Other customers want + -- topSig. So Nothing is good. + + newDemandInfo :: Maybe Demand -- Similarly we want to know if there's no + -- known demand yet, for when we are looking for + -- CPR info + } -\begin{code} -mkDemandInfo :: Demand -> DemandInfo -mkDemandInfo demand = DemandedAsPer demand +seqIdInfo :: IdInfo -> () +seqIdInfo (IdInfo {}) = () -willBeDemanded :: DemandInfo -> Bool -willBeDemanded (DemandedAsPer demand) = isStrict demand -willBeDemanded _ = False -\end{code} +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqSpecInfo (specInfo info) `seq` + seqWorker (workerInfo info) `seq` -\begin{code} -instance OptIdInfo DemandInfo where - noInfo = UnknownDemand - - getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand - -{- DELETED! If this line is in, there is no way to - nuke a DemandInfo, and we have to be able to do that - when floating let-bindings around - addInfo id_info UnknownDemand = id_info --} - addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j - - ppInfo (PprInterface _) _ _ = ppNil - ppInfo sty _ UnknownDemand = ppStr "{-# L #-}" - ppInfo sty _ (DemandedAsPer info) - = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"] -\end{code} +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` -%************************************************************************ -%* * -\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} -%* * -%************************************************************************ + seqNewDemandInfo (newDemandInfo info) `seq` + seqNewStrictnessInfo (newStrictnessInfo info) `seq` -The details of one specialisation, held in an @Id@'s -@SpecEnv@ are as follows: -\begin{code} -data SpecInfo - = SpecInfo [Maybe UniType] -- Instance types; no free type variables in here - Int -- No. of dictionaries to eat - Id -- Specialised version +#ifdef OLD_STRICTNESS + Demand.seqDemand (demandInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` + seqCpr (cprInfo info) `seq` +#endif + + seqCaf (cafInfo info) `seq` + seqLBVar (lbvarInfo info) `seq` + seqOccInfo (occInfo info) \end{code} -For example, if \tr{f} has this @SpecInfo@: -\begin{verbatim} - SpecInfo [Just t1, Nothing, Just t3] 2 f' -\end{verbatim} -then -\begin{verbatim} - f t1 t2 t3 d1 d2 ===> f t2 -\end{verbatim} -The \tr{Nothings} identify type arguments in which the specialised -version is polymorphic. +Setters \begin{code} -data SpecEnv = SpecEnv [SpecInfo] - -mkSpecEnv = SpecEnv -nullSpecEnv = SpecEnv [] -addOneToSpecEnv (SpecEnv xs) x = SpecEnv (x : xs) - -lookupConstMethodId :: SpecEnv -> UniType -> Maybe Id - -- slight variant on "lookupSpecEnv" below +setWorkerInfo info wk = wk `seq` info { workerInfo = wk } +setSpecInfo info sp = sp `seq` info { specInfo = sp } +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo info oc = oc `seq` info { occInfo = oc } +#ifdef OLD_STRICTNESS +setStrictnessInfo info st = st `seq` info { strictnessInfo = st } +#endif + -- Try to avoid spack leaks by seq'ing -lookupConstMethodId (SpecEnv spec_infos) spec_ty - = firstJust (map try spec_infos) - where - try (SpecInfo (Just ty:nothings) _ const_meth_id) - = ASSERT(all nothing_is_nothing nothings) - case (cmpUniType True{-properly-} ty spec_ty) of - EQ_ -> Just const_meth_id - _ -> Nothing +setUnfoldingInfoLazily info uf -- Lazy variant to avoid looking at the + = -- unfolding of an imported Id unless necessary + info { unfoldingInfo = uf } -- (In this case the demand-zapping is redundant.) - nothing_is_nothing Nothing = True -- debugging only - nothing_is_nothing _ = panic "nothing_is_nothing!" +setUnfoldingInfo info uf + -- We do *not* seq on the unfolding info, For some reason, doing so + -- actually increases residency significantly. + = info { unfoldingInfo = uf } -lookupSpecId :: Id -- *un*specialised Id - -> [Maybe UniType] -- types to which it is to be specialised - -> Id -- specialised Id +#ifdef OLD_STRICTNESS +setDemandInfo info dd = info { demandInfo = dd } +setCprInfo info cp = info { cprInfo = cp } +#endif -lookupSpecId unspec_id ty_maybes - = case (getInfo (getIdInfo unspec_id)) of { SpecEnv spec_infos -> +setArityInfo info ar = info { arityInfo = ar } +setCafInfo info caf = info { cafInfo = caf } - case (firstJust (map try spec_infos)) of - Just id -> id - Nothing -> error ("ERROR: There is some confusion about a value specialised to a type;\ndetails follow (and more info in the User's Guide):\n\t"++(ppShow 80 (ppr PprDebug unspec_id))) - } - where - try (SpecInfo template_maybes _ id) - | and (zipWith same template_maybes ty_maybes) - && length template_maybes == length ty_maybes = Just id - | otherwise = Nothing - - same Nothing Nothing = True - same (Just ty1) (Just ty2) = ty1 == ty2 - same _ _ = False - -lookupSpecEnv :: SpecEnv - -> [UniType] - -> Maybe (Id, - [UniType], - Int) - -lookupSpecEnv (SpecEnv []) _ = Nothing -- rather common case - -lookupSpecEnv spec_env [] = Nothing -- another common case - - -- This can happen even if there is a non-empty spec_env, because - -- of eta reduction. For example, we might have a defn - -- - -- f = /\a -> \d -> g a d - -- which gets transformed to - -- f = g - -- - -- Now g isn't applied to any arguments +setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } -lookupSpecEnv se@(SpecEnv spec_infos) spec_tys - = select_match spec_infos - where - select_match [] -- no matching spec_infos - = Nothing - select_match (SpecInfo ty_maybes toss spec_id : rest) - = case (match ty_maybes spec_tys) of - Nothing -> select_match rest - Just tys_left -> select_next [(spec_id,tys_left,toss)] (length tys_left) toss rest - - -- Ambiguity can only arise as a result of specialisations with - -- an explicit spec_id. The best match is deemed to be the match - -- with least polymorphism i.e. has the least number of tys left. - -- This is a non-critical approximation. The only type arguments - -- where there may be some discretion is for non-overloaded boxed - -- types. Unboxed types must be matched and we insist that we - -- always specialise on overloaded types (and discard all the dicts). - - select_next best _ toss [] - = case best of - [match] -> Just match -- Unique best match - ambig -> pprPanic "Ambiguous Specialisation:\n" - (ppAboves [ppStr "(check specialisations with explicit spec ids)", - ppCat (ppStr "between spec ids:" : - map (ppr PprDebug) [id | (id, _, _) <- ambig]), - pp_stuff]) - - select_next best tnum dnum (SpecInfo ty_maybes toss spec_id : rest) - = ASSERT(dnum == toss) - case (match ty_maybes spec_tys) of - Nothing -> select_next best tnum dnum rest - Just tys_left -> - let tys_len = length tys_left in - case _tagCmp tnum tys_len of - _LT -> select_next [(spec_id,tys_left,toss)] tys_len dnum rest -- better match - _EQ -> select_next ((spec_id,tys_left,toss):best) tnum dnum rest -- equivalent match - _GT -> select_next best tnum dnum rest -- worse match - - - match [{-out of templates-}] [] = Just [] - - match (Nothing:ty_maybes) (spec_ty:spec_tys) - = case (isUnboxedDataType spec_ty) of - True -> Nothing -- Can only match boxed type against - -- type argument which has not been - -- specialised on - False -> case match ty_maybes spec_tys of - Nothing -> Nothing - Just tys -> Just (spec_ty:tys) - - match (Just ty:ty_maybes) (spec_ty:spec_tys) - = case (cmpUniType True{-properly-} ty spec_ty) of - EQ_ -> match ty_maybes spec_tys - other -> Nothing - - match [] _ = pprPanic "lookupSpecEnv1\n" pp_stuff - -- This is a Real Problem - - match _ [] = pprPanic "lookupSpecEnv2\n" pp_stuff - -- Partial eta abstraction might make this happen; - -- meanwhile let's leave in the check - - pp_stuff = ppAbove (pp_specs PprDebug True (\x->x) nullIdEnv se) (ppr PprDebug spec_tys) +setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd } +setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } \end{code} \begin{code} -instance OptIdInfo SpecEnv where - noInfo = nullSpecEnv - - getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec - - addInfo (IdInfo a b (SpecEnv old_spec) d e f g h i j) (SpecEnv new_spec) - = IdInfo a b (SpecEnv (new_spec ++ old_spec)) d e f g h i j - -- We *add* the new specialisation info rather than just replacing it - -- so that we don't lose old specialisation details. - - ppInfo sty better_id_fn spec_env - = pp_specs sty True better_id_fn nullIdEnv spec_env - -pp_specs sty _ _ _ (SpecEnv []) = pp_NONE -pp_specs sty print_spec_ids better_id_fn inline_env (SpecEnv specs) - = ppBeside (ppPStr SLIT("_SPECIALISE_ ")) (pp_the_list [ - ppCat [ppLbrack, ppIntersperse pp'SP{-'-} (map pp_maybe ty_maybes), ppRbrack, - ppInt numds, - let - better_spec_id = better_id_fn spec_id - spec_id_info = getIdInfo better_spec_id - in - if not print_spec_ids || boringIdInfo spec_id_info then - ppNil - else - ppCat [ppChar '{', - ppIdInfo sty better_spec_id True{-wrkr specs too!-} better_id_fn inline_env spec_id_info, - ppChar '}'] - ] - | (SpecInfo ty_maybes numds spec_id) <- specs ]) - where - pp_the_list [p] = p - pp_the_list (p:ps) = ppBesides [p, pp'SP{-'-}, pp_the_list ps] +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + cafInfo = vanillaCafInfo, + arityInfo = unknownArity, +#ifdef OLD_STRICTNESS + cprInfo = NoCPRInfo, + demandInfo = wwLazy, + strictnessInfo = NoStrictnessInfo, +#endif + specInfo = emptySpecInfo, + workerInfo = NoWorker, + unfoldingInfo = noUnfolding, + lbvarInfo = NoLBVarInfo, + inlinePragInfo = AlwaysActive, + occInfo = NoOccInfo, + newDemandInfo = Nothing, + newStrictnessInfo = Nothing + } - pp_maybe Nothing = ifPprInterface sty pp_NONE - pp_maybe (Just t) = pprParendUniType sty t +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in MkId. \end{code} + %************************************************************************ %* * -\subsection[strictness-IdInfo]{Strictness info about an @Id@} +\subsection[arity-IdInfo]{Arity info about an @Id@} %* * %************************************************************************ -We specify the strictness of a function by giving information about -each of the ``wrapper's'' arguments (see the description about -worker/wrapper-style transformations in the PJ/Launchbury paper on -unboxed types). - -The list of @Demands@ specifies: (a)~the strictness properties -of a function's arguments; (b)~the {\em existence} of a ``worker'' -version of the function; and (c)~the type signature of that worker (if -it exists); i.e. its calling convention. +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) \begin{code} -data StrictnessInfo - = NoStrictnessInfo +type ArityInfo = Arity + -- A partial application of this Id to up to n-1 value arguments + -- does essentially no work. That is not necessarily the + -- same as saying that it has n leading lambdas, because coerces + -- may get in the way. - | BottomGuaranteed -- This Id guarantees never to return; - -- it is bottom regardless of its arguments. - -- Useful for "error" and other disguised - -- variants thereof. + -- The arity might increase later in the compilation process, if + -- an extra lambda floats up to the binding site. - | StrictnessInfo [Demand] -- the main stuff; see below. - (Maybe Id) -- worker's Id, if applicable. -\end{code} +unknownArity = 0 :: Arity -This type is also actually used in the strictness analyser: -\begin{code} -data Demand - = WwLazy -- Argument is lazy as far as we know - MaybeAbsent -- (does not imply worker's existence [etc]). - -- If MaybeAbsent == True, then it is - -- *definitely* lazy. (NB: Absence implies - -- a worker...) - - | WwStrict -- Argument is strict but that's all we know - -- (does not imply worker's existence or any - -- calling-convention magic) - - | WwUnpack -- Argument is strict & a single-constructor - [Demand] -- type; its constituent parts (whose StrictInfos - -- are in the list) should be passed - -- as arguments to the worker. - - | WwPrim -- Argument is of primitive type, therefore - -- strict; doesn't imply existence of a worker; - -- argument should be passed as is to worker. - - | WwEnum -- Argument is strict & an enumeration type; - -- an Int# representing the tag (start counting - -- at zero) should be passed to the worker. - deriving (Eq, Ord) - -- we need Eq/Ord to cross-chk update infos in interfaces - -type MaybeAbsent = Bool -- True <=> not even used - --- versions that don't worry about Absence: -wwLazy = WwLazy False -wwStrict = WwStrict -wwUnpack xs = WwUnpack xs -wwPrim = WwPrim -wwEnum = WwEnum +ppArityInfo 0 = empty +ppArityInfo n = hsep [ptext SLIT("Arity"), int n] \end{code} +%************************************************************************ +%* * +\subsection{Inline-pragma information} +%* * +%************************************************************************ + \begin{code} -mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo +type InlinePragInfo = Activation + -- Tells when the inlining is active + -- When it is active the thing may be inlined, depending on how + -- big it is. + -- + -- If there was an INLINE pragma, then as a separate matter, the + -- RHS will have been made to look small with a CoreSyn Inline Note -mkStrictnessInfo [] _ = NoStrictnessInfo -mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr + -- The default InlinePragInfo is AlwaysActive, so the info serves + -- entirely as a way to inhibit inlining until we want it +\end{code} -mkBottomStrictnessInfo = BottomGuaranteed -bottomIsGuaranteed BottomGuaranteed = True -bottomIsGuaranteed other = False +%************************************************************************ +%* * + SpecInfo +%* * +%************************************************************************ -getWrapperArgTypeCategories - :: UniType -- wrapper's type - -> StrictnessInfo -- strictness info about its args - -> Maybe String +\begin{code} +-- CoreRules is used only in an idSpecialisation (move to IdInfo?) +data SpecInfo + = SpecInfo [CoreRule] VarSet -- Locally-defined free vars of RHSs -getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing -getWrapperArgTypeCategories _ BottomGuaranteed - = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong -getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing +emptySpecInfo :: SpecInfo +emptySpecInfo = SpecInfo [] emptyVarSet -getWrapperArgTypeCategories ty (StrictnessInfo arg_info _) - = Just (mkWrapperArgTypeCategories ty arg_info) +isEmptySpecInfo :: SpecInfo -> Bool +isEmptySpecInfo (SpecInfo rs _) = null rs -workerExists :: StrictnessInfo -> Bool -workerExists (StrictnessInfo _ (Just worker_id)) = True -workerExists other = False +specInfoFreeVars :: SpecInfo -> VarSet +specInfoFreeVars (SpecInfo _ fvs) = fvs -getWorkerId :: StrictnessInfo -> Id +specInfoRules :: SpecInfo -> [CoreRule] +specInfoRules (SpecInfo rules _) = rules -getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id -#ifdef DEBUG -getWorkerId junk = pprPanic "getWorkerId: Nothing" (ppInfo PprDebug (\x->x) junk) -#endif +seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs \end{code} -\begin{code} -isStrict :: Demand -> Bool -isStrict WwStrict = True -isStrict (WwUnpack _) = True -isStrict WwPrim = True -isStrict WwEnum = True -isStrict _ = False +%************************************************************************ +%* * +\subsection[worker-IdInfo]{Worker info about an @Id@} +%* * +%************************************************************************ -{- UNUSED: -absentArg :: Demand -> Bool +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 strictness analysis. -absentArg (WwLazy absentp) = absentp -absentArg other = False --} +There might not be a worker, even for a strict function, because: +(a) the function might be small enough to inline, so no need + for w/w split +(b) the strictness info might be "SSS" or something, so no w/w split. -nonAbsentArgs :: [Demand] -> Int +Sometimes the arity of a wrapper changes from the original arity from +which it was generated, so we always emit the "original" arity into +the interface file, as part of the worker info. -nonAbsentArgs cmpts - = foldr tick_non 0 cmpts - where - tick_non (WwLazy True) acc = acc - tick_non other acc = acc + 1 +How can this happen? Sometimes we get + f = coerce t (\x y -> $wf x y) +at the moment of w/w split; but the eta reducer turns it into + f = coerce t $wf +which is perfectly fine except that the exposed arity so far as +the code generator is concerned (zero) differs from the arity +when we did the split (2). -all_present_WwLazies :: [Demand] -> Bool -all_present_WwLazies infos - = and (map is_L infos) - where - is_L (WwLazy False) = True -- False <=> "Absent" args do *not* count! - is_L _ = False -- (as they imply a worker) -\end{code} +All this arises because we use 'arity' to mean "exactly how many +top level lambdas are there" in interface files; but during the +compilation of this module it means "how many things can I apply +this to". -WDP 95/04: It is no longer enough to look at a list of @Demands@ for -an ``Unpack'' or an ``Absent'' and declare a worker. We also have to -check that @mAX_WORKER_ARGS@ hasn't been exceeded. Therefore, -@indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@ -in \tr{WwLib.lhs}. A worker is ``indicated'' when we hit an Unpack -or an Absent {\em that we accept}. \begin{code} -indicatesWorker :: [Demand] -> Bool -indicatesWorker dems - = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems - where - fake_mk_ww _ [] = False - fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent - fake_mk_ww extra_args (WwUnpack cmpnts : dems) - | extra_args_now > 0 = True -- we accepted an Unpack - where - extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts - - fake_mk_ww extra_args (_ : dems) - = fake_mk_ww extra_args dems -\end{code} +data WorkerInfo = NoWorker + | HasWorker Id Arity + -- The Arity is the arity of the *wrapper* at the moment of the + -- w/w split. See notes above. -\begin{code} -mkWrapperArgTypeCategories - :: UniType -- wrapper's type - -> [Demand] -- info about its arguments - -> String -- a string saying lots about the args - -mkWrapperArgTypeCategories wrapper_ty wrap_info - = case (splitTypeWithDictsAsArgs wrapper_ty) of { (_,arg_tys,_) -> - map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) - } - where - -- ToDo: this needs FIXING UP (it was a hack anyway...) - do_one (WwPrim, _) = 'P' - do_one (WwEnum, _) = 'E' - do_one (WwStrict, arg_ty_char) = arg_ty_char - do_one (WwUnpack _, arg_ty_char) - = if arg_ty_char `elem` "CIJFDTS" - then toLower arg_ty_char - else if arg_ty_char == '+' then 't' - else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-' - do_one (other_wrap_info, _) = '-' -\end{code} +seqWorker :: WorkerInfo -> () +seqWorker (HasWorker id a) = id `seq` a `seq` () +seqWorker NoWorker = () -Whether a worker exists depends on whether the worker has an -absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments. +ppWorkerInfo NoWorker = empty +ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id -If a @WwUnpack@ argument is for an {\em abstract} type (or one that -will be abstract outside this module), which might happen for an -imported function, then we can't (or don't want to...) unpack the arg -as the worker requires. Hence we have to give up altogether, and call -the wrapper only; so under these circumstances we return \tr{False}. +workerExists :: WorkerInfo -> Bool +workerExists NoWorker = False +workerExists (HasWorker _ _) = True -\begin{code} -instance Text Demand where - readList str = read_em [{-acc-}] str - where - read_em acc [] = [(reverse acc, "")] - -- lower case indicates absence... - read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs - read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs - read_em acc ('S' : xs) = read_em (WwStrict : acc) xs - read_em acc ('P' : xs) = read_em (WwPrim : acc) xs - read_em acc ('E' : xs) = read_em (WwEnum : acc) xs - - read_em acc (')' : xs) = [(reverse acc, xs)] - read_em acc ( 'U' : '(' : xs) - = case (read_em [] xs) of - [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest - _ -> panic ("Text.Demand:"++str++"::"++xs) - - read_em acc other = panic ("IdInfo.readem:"++other) - - showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest - where - show1 (WwLazy False) = "L" - show1 (WwLazy True) = "A" - show1 WwStrict = "S" - show1 WwPrim = "P" - show1 WwEnum = "E" - show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")" - -instance Outputable Demand where - ppr sty si = ppStr (showList [si] "") - -instance OptIdInfo StrictnessInfo where - noInfo = NoStrictnessInfo - - getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict - - addInfo id_info NoStrictnessInfo = id_info - addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j - - ppInfo sty better_id_fn strictness_info - = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info -\end{code} +workerId :: WorkerInfo -> Id +workerId (HasWorker id _) = id -We'll omit the worker info if the thing has an explicit unfolding -already. -\begin{code} -pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE - -pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_") - -pp_strictness sty for_this_id_maybe better_id_fn inline_env - info@(StrictnessInfo wrapper_args wrkr_maybe) - = let - (have_wrkr, wrkr_id) = case wrkr_maybe of - Nothing -> (False, panic "ppInfo(Strictness)") - Just xx -> (True, xx) - - wrkr_to_print = better_id_fn wrkr_id - wrkr_info = getIdInfo wrkr_to_print - - -- if we aren't going to be able to *read* the strictness info - -- in TcPragmas, we need not even print it. - wrapper_args_to_use - = if not (indicatesWorker wrapper_args) then - wrapper_args -- no worker/wrappering in any case - else - case for_this_id_maybe of - Nothing -> wrapper_args - Just id -> if externallyVisibleId id - && (unfoldingUnfriendlyId id || not have_wrkr) then - -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) ( - map un_workerise wrapper_args - -- ) - else - wrapper_args - - id_is_worker - = case for_this_id_maybe of - Nothing -> False - Just id -> isWorkerId id - - am_printing_iface - = case sty of - PprInterface _ -> True - _ -> False - - pp_basic_info - = ppBesides [ppStr "_S_ \"", - ppStr (showList wrapper_args_to_use ""), ppStr "\""] - - pp_with_worker - = ppBesides [ ppSP, ppChar '{', - ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info, - ppChar '}' ] - in - if all_present_WwLazies wrapper_args_to_use then -- too boring - ifPprInterface sty pp_NONE - - else if id_is_worker && am_printing_iface then - pp_NONE -- we don't put worker strictness in interfaces - -- (it can be deduced) - - else if not (indicatesWorker wrapper_args_to_use) - || not have_wrkr - || boringIdInfo wrkr_info then - ppBeside pp_basic_info ppNil - else - ppBeside pp_basic_info pp_with_worker - where - un_workerise (WwLazy _) = WwLazy False -- avoid absence - un_workerise (WwUnpack _) = WwStrict - un_workerise other = other +wrapperArity :: WorkerInfo -> Arity +wrapperArity (HasWorker _ a) = a \end{code} + %************************************************************************ %* * -\subsection[unfolding-IdInfo]{Unfolding info about an @Id@} +\subsection[CG-IdInfo]{Code generator-related information} %* * %************************************************************************ \begin{code} -mkUnfolding :: UnfoldingGuidance -> PlainCoreExpr -> UnfoldingDetails -iWantToBeINLINEd :: UnfoldingGuidance -> UnfoldingDetails -mkMagicUnfolding :: FAST_STRING -> UnfoldingDetails - -mkUnfolding guide expr - = GeneralForm False (mkFormSummary NoStrictnessInfo{-NB:lying-} expr) - (BSCC("OccurExpr") occurAnalyseGlobalExpr expr ESCC) - guide -\end{code} +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). -\begin{code} -iWantToBeINLINEd guide = IWantToBeINLINEd guide - -mkMagicUnfolding tag = MagicForm tag (mkMagicUnfoldingFun tag) - -{- UNUSED: -haveUnfolding NoUnfoldingDetails = False -haveUnfolding (IWantToBeINLINEd _) = False -- don't have the unfolding *YET* -haveUnfolding _ = True --} -\end{code} - -\begin{code} -noInfo_UF = NoUnfoldingDetails +data CafInfo + = MayHaveCafRefs -- either: + -- (1) A function or static constructor + -- that refers to one or more CAFs, + -- (2) A real live CAF -getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding - -addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info -addInfo_UF (IdInfo a b d e xxx f g h i j) uf = IdInfo a b d e uf f g h i j - ---UNUSED:clearInfo_UF (IdInfo a b d e xxx f g h i j) = IdInfo a b d e noInfo_UF f g h i j -\end{code} - -\begin{code} -pp_unfolding sty for_this_id inline_env uf_details - = case (lookupIdEnv inline_env for_this_id) of - Nothing -> pp uf_details - Just dt -> pp dt - where - pp NoUnfoldingDetails = pp_NONE + | NoCafRefs -- A function or static constructor + -- that refers to no CAFs. - pp (IWantToBeINLINEd guide) -- not in interfaces - = if isWrapperId for_this_id - then pp_NONE -- wrapper: don't complain or mutter - else ppCat [ppStr "{-IWantToBeINLINEd", ppr sty guide, ppStr "-}", pp_NONE] +vanillaCafInfo = MayHaveCafRefs -- Definitely safe - pp (MagicForm tag _) - = ppCat [ppPStr SLIT("_MF_"), ppPStr tag] +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False - pp (GeneralForm _ _ template guide) - = let - untagged = unTagBinders template - in - if untagged `isWrapperFor` for_this_id - then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged)) - pp_NONE - else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged] +seqCaf c = c `seq` () +ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs") +ppCafInfo MayHaveCafRefs = empty \end{code} %************************************************************************ %* * -\subsection[update-IdInfo]{Update-analysis info about an @Id@} +\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@} %* * %************************************************************************ -\begin{code} -data UpdateInfo - = NoUpdateInfo - | SomeUpdateInfo UpdateSpec - deriving (Eq, Ord) - -- we need Eq/Ord to cross-chk update infos in interfaces - --- the form in which we pass update-analysis info between modules: -type UpdateSpec = [Int] -\end{code} - -\begin{code} -mkUpdateInfo = SomeUpdateInfo +If the @Id@ is a function then it may have CPR info. A CPR analysis +phase detects whether: -updateInfoMaybe NoUpdateInfo = Nothing -updateInfoMaybe (SomeUpdateInfo []) = Nothing -updateInfoMaybe (SomeUpdateInfo u) = Just u -\end{code} +\begin{enumerate} +\item +The function's return value has a product type, i.e. an algebraic type +with a single constructor. Examples of such types are tuples and boxed +primitive values. +\item +The function always 'constructs' the value that it is returning. It +must do this on every path through, and it's OK if it calls another +function which constructs the result. +\end{enumerate} -Text instance so that the update annotations can be read in. +If this is the case then we store a template which tells us the +function has the CPR property and which components of the result are +also CPRs. \begin{code} -instance Text UpdateInfo where - readsPrec p s | null s = panic "IdInfo: empty update pragma?!" - | otherwise = [(SomeUpdateInfo (map ok_digit s),"")] - where - ok_digit c | c >= '0' && c <= '2' = ord c - ord '0' - | otherwise = panic "IdInfo: not a digit while reading update pragma" +#ifdef OLD_STRICTNESS +data CprInfo + = NoCPRInfo + | ReturnsCPR -- Yes, this function returns a constructed product + -- Implicitly, this means "after the function has been applied + -- to all its arguments", so the worker/wrapper builder in + -- WwLib.mkWWcpr checks that that it is indeed saturated before + -- making use of the CPR info -instance OptIdInfo UpdateInfo where - noInfo = NoUpdateInfo + -- We used to keep nested info about sub-components, but + -- we never used it so I threw it away - getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update +seqCpr :: CprInfo -> () +seqCpr ReturnsCPR = () +seqCpr NoCPRInfo = () - addInfo id_info NoUpdateInfo = id_info - addInfo (IdInfo a b d e f _ g h i j) upd_info = IdInfo a b d e f upd_info g h i j +noCprInfo = NoCPRInfo - ppInfo sty better_id_fn NoUpdateInfo = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeUpdateInfo spec) - = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec)) -\end{code} +ppCprInfo NoCPRInfo = empty +ppCprInfo ReturnsCPR = ptext SLIT("__M") -%************************************************************************ -%* * -\subsection[deforest-IdInfo]{Deforestation info about an @Id@} -%* * -%************************************************************************ - -The deforest info says whether this Id is to be unfolded during -deforestation. Therefore, when the deforest pragma is true, we must -also have the unfolding information available for this Id. +instance Outputable CprInfo where + ppr = ppCprInfo -\begin{code} -data DeforestInfo - = Don'tDeforest -- just a bool, might extend this - | DoDeforest -- later. - -- deriving (Eq, Ord) +instance Show CprInfo where + showsPrec p c = showsPrecSDoc p (ppr c) +#endif \end{code} -\begin{code} -instance OptIdInfo DeforestInfo where - noInfo = Don'tDeforest - - getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest - - addInfo id_info Don'tDeforest = id_info - addInfo (IdInfo a b d e f g _ h i j) deforest = - IdInfo a b d e f g deforest h i j - - ppInfo sty better_id_fn Don'tDeforest - = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn DoDeforest - = ppPStr SLIT("_DEFOREST_") -\end{code} %************************************************************************ %* * -\subsection[argUsage-IdInfo]{Argument Usage info about an @Id@} +\subsection[lbvar-IdInfo]{Lambda-bound var info about an @Id@} %* * %************************************************************************ -\begin{code} -data ArgUsageInfo - = NoArgUsageInfo - | SomeArgUsageInfo ArgUsageType - -- ??? deriving (Eq, Ord) - -data ArgUsage = ArgUsage Int -- number of arguments (is linear!) - | UnknownArgUsage -type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB -\end{code} +If the @Id@ is a lambda-bound variable then it may have lambda-bound +var info. Sometimes we know whether the lambda binding this var is a +``one-shot'' lambda; that is, whether it is applied at most once. + +This information may be useful in optimisation, as computations may +safely be floated inside such a lambda without risk of duplicating +work. \begin{code} -mkArgUsageInfo = SomeArgUsageInfo +data LBVarInfo = NoLBVarInfo + | IsOneShotLambda -- The lambda is applied at most once). -getArgUsage :: ArgUsageInfo -> ArgUsageType -getArgUsage NoArgUsageInfo = [] -getArgUsage (SomeArgUsageInfo u) = u +seqLBVar l = l `seq` () \end{code} \begin{code} -instance OptIdInfo ArgUsageInfo where - noInfo = NoArgUsageInfo +hasNoLBVarInfo NoLBVarInfo = True +hasNoLBVarInfo IsOneShotLambda = False - getInfo (IdInfo _ _ _ _ _ _ _ au _ _) = au +noLBVarInfo = NoLBVarInfo - addInfo id_info NoArgUsageInfo = id_info - addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j +pprLBVarInfo NoLBVarInfo = empty +pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot") - ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeArgUsageInfo aut) - = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut) +instance Outputable LBVarInfo where + ppr = pprLBVarInfo +instance Show LBVarInfo where + showsPrec p c = showsPrecSDoc p (ppr c) +\end{code} -ppArgUsage (ArgUsage n) = ppInt n -ppArgUsage (UnknownArgUsage) = ppChar '-' -ppArgUsageType aut = ppBesides - [ ppChar '"' , - ppIntersperse ppComma (map ppArgUsage aut), - ppChar '"' ] -\end{code} %************************************************************************ %* * -\subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes} +\subsection{Bulk operations on IdInfo} %* * %************************************************************************ +@zapLamInfo@ is used for lambda binders that turn out to to be +part of an unsaturated lambda + \begin{code} -data FBTypeInfo - = NoFBTypeInfo - | SomeFBTypeInfo FBType - -- ??? deriving (Eq, Ord) +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, newDemandInfo = Nothing}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ (OneOcc in_lam _ _) = in_lam + is_safe_occ other = True -data FBType = FBType [FBConsum] FBProd deriving (Eq) + safe_occ = case occ of + OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt + other -> occ -data FBConsum = FBGoodConsum | FBBadConsum deriving(Eq) -data FBProd = FBGoodProd | FBBadProd deriving(Eq) + is_safe_dmd Nothing = True + is_safe_dmd (Just dmd) = not (isStrictDmd dmd) \end{code} \begin{code} -mkFBTypeInfo = SomeFBTypeInfo - -getFBType :: FBTypeInfo -> Maybe FBType -getFBType NoFBTypeInfo = Nothing -getFBType (SomeFBTypeInfo u) = Just u +zapDemandInfo :: IdInfo -> Maybe IdInfo +zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) + | isJust dmd = Just (info {newDemandInfo = Nothing}) + | otherwise = Nothing \end{code} -\begin{code} -instance OptIdInfo FBTypeInfo where - noInfo = NoFBTypeInfo - - getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb - - addInfo id_info NoFBTypeInfo = id_info - addInfo (IdInfo a b d e f g h i _ j) fb_info = IdInfo a b d e f g h i fb_info j - - ppInfo (PprInterface _) better_id_fn NoFBTypeInfo = ppNil - ppInfo sty better_id_fn NoFBTypeInfo = ifPprInterface sty pp_NONE - ppInfo sty better_id_fn (SomeFBTypeInfo (FBType cons prod)) - = ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod) - ---ppFBType (FBType n) = ppBesides [ppInt n] ---ppFBType (UnknownFBType) = ppBesides [ppStr "-"] --- - -ppFBType cons prod = ppBesides - ([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ]) - where - ppCons FBGoodConsum = ppChar 'G' - ppCons FBBadConsum = ppChar 'B' - ppProd FBGoodProd = ppChar 'G' - ppProd FBBadProd = ppChar 'B' -\end{code}