X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=d53bf5627d99638a48f0f07e57eb846b4e0dc65a;hb=c5b03909e7c630a874f6f1abf76d28baf4b19d55;hp=25bd150bddd97e8a611d9c8673e59d4b2613adde;hpb=dcef38bab91d45b56f7cf3ceeec96303d93728bb;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 25bd150..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-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % \section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} @@ -7,75 +7,271 @@ Haskell. [WDP 94/11]) \begin{code} -#include "HsVersions.h" - module IdInfo ( + GlobalIdDetails(..), notGlobalId, -- Not abstract + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + seqIdInfo, megaSeqIdInfo, + + -- Zapping + zapLamInfo, zapDemandInfo, + + -- Arity + ArityInfo, + 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 - noIdInfo, - ppIdInfo, - applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please + -- Worker + WorkerInfo(..), workerExists, wrapperArity, workerId, + workerInfo, setWorkerInfo, ppWorkerInfo, - ArityInfo(..), - exactArity, atLeastArity, unknownArity, - arityInfo, addArityInfo, ppArityInfo, + -- Unfolding + unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, - DemandInfo, - noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded, +#ifdef OLD_STRICTNESS + -- Old DemandInfo and StrictnessInfo + demandInfo, setDemandInfo, + strictnessInfo, setStrictnessInfo, + cprInfoFromNewStrictness, + oldStrictnessFromNew, newStrictnessFromOld, + oldDemand, newDemand, - StrictnessInfo(..), -- Non-abstract - Demand(..), -- Non-abstract - wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum, + -- Constructed Product Result Info + CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo, +#endif - getWorkerId_maybe, - workerExists, - mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed, - strictnessInfo, ppStrictnessInfo, addStrictnessInfo, + -- Inline prags + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, - unfoldInfo, addUnfoldInfo, + -- Occurrence info + OccInfo(..), isFragileOcc, isDeadOcc, isLoopBreaker, + InsideLam, OneBranch, insideLam, notInsideLam, oneBranch, notOneBranch, + occInfo, setOccInfo, - specInfo, addSpecInfo, + -- Specialisation + SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, + specInfoFreeVars, specInfoRules, seqSpecInfo, - UpdateInfo, SYN_IE(UpdateSpec), - mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo, + -- CAF info + CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, - DeforestInfo(..), - deforestInfo, ppDeforestInfo, addDeforestInfo, + -- Lambda-bound variable info + LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo + ) where - ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType), - mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage, +#include "HsVersions.h" - FBTypeInfo, FBType(..), FBConsum(..), FBProd(..), - fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType - ) where -IMP_Ubiq() -IMPORT_1_3(Char(toLower)) +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 -IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and - -- we break those loops by using IdLoop and - -- *not* importing much of anything else, - -- except from the very general "utils". +-- 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} -import Type ( eqSimpleTy, splitFunTyExpandingDicts ) -import CmdLineOpts ( opt_OmitInterfacePragmas ) +%************************************************************************ +%* * +\subsection{New strictness info} +%* * +%************************************************************************ -import Demand -import Maybes ( firstJust ) -import Outputable ( ifPprInterface, Outputable(..){-instances-} ) -import PprStyle ( PprStyle(..) ) -import Pretty -import Unique ( pprUnique ) -import Util ( mapAccumL, panic, assertPanic, pprPanic ) +To be removed later -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int +\begin{code} +-- 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 + } + +setAllStrictnessInfo info (Just sig) + = info { newStrictnessInfo = Just sig +#ifdef OLD_STRICTNESS + , strictnessInfo = oldStrictnessFromNew sig + , cprInfo = cprInfoFromNewStrictness sig #endif + } + +seqNewStrictnessInfo Nothing = () +seqNewStrictnessInfo (Just ty) = seqStrictSig ty + +pprNewStrictness Nothing = empty +pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig + +#ifdef OLD_STRICTNESS +oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo +oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) + where + (dmds, res_info) = splitStrictSig sig + +cprInfoFromNewStrictness :: StrictSig -> CprInfo +cprInfoFromNewStrictness sig = case strictSigResInfo sig of + RetCPR -> ReturnsCPR + other -> NoCPRInfo + +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) + +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) + +mk_strict_sig name arity dmd_ty + = WARN( arity /= dmdTypeDepth dmd_ty, ppr name <+> (ppr arity $$ ppr dmd_ty) ) + mkStrictSig dmd_ty + +newRes True _ = BotRes +newRes False ReturnsCPR = retCPR +newRes False NoCPRInfo = TopRes + +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} + + +\begin{code} +seqNewDemandInfo Nothing = () +seqNewDemandInfo (Just dmd) = seqDemand dmd +\end{code} + + +%************************************************************************ +%* * +\subsection{GlobalIdDetails +%* * +%************************************************************************ -applySubstToTy = panic "IdInfo.applySubstToTy" -showTypeCategory = panic "IdInfo.showTypeCategory" +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} +data GlobalIdDetails + = VanillaGlobal -- Imported from elsewhere, a default method Id. + + | 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 + + | 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] + + | ClassOpId Class -- An operation of a class + + | PrimOpId PrimOp -- The Id for a primitive operator + | FCallId ForeignCall -- The Id for a foreign call + + | NotGlobalId -- Used as a convenient extra return value from globalIdDetails + +notGlobalId = NotGlobalId + +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{The main IdInfo type} +%* * +%************************************************************************ + 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. @@ -86,137 +282,130 @@ the properties attached to the other. 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). +(except for @DemandInfo@? ToDo). (@lbvarInfo@ is also a marginal +case. KSW 1999-04). \begin{code} data IdInfo - = IdInfo - ArityInfo -- Its arity + = 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 + } + +seqIdInfo :: IdInfo -> () +seqIdInfo (IdInfo {}) = () + +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqSpecInfo (specInfo info) `seq` + seqWorker (workerInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqNewDemandInfo (newDemandInfo info) `seq` + seqNewStrictnessInfo (newStrictnessInfo info) `seq` + +#ifdef OLD_STRICTNESS + Demand.seqDemand (demandInfo info) `seq` + seqStrictnessInfo (strictnessInfo info) `seq` + seqCpr (cprInfo info) `seq` +#endif - DemandInfo -- Whether or not it is definitely - -- demanded + seqCaf (cafInfo info) `seq` + seqLBVar (lbvarInfo info) `seq` + seqOccInfo (occInfo info) +\end{code} - SpecEnv - -- Specialisations of this function which exist +Setters - (StrictnessInfo Id) - -- Strictness properties, notably - -- how to conjure up "worker" functions +\begin{code} +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 - Unfolding - -- Its unfolding; for locally-defined - -- things, this can *only* be NoUnfolding +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.) - UpdateInfo -- Which args should be updated +setUnfoldingInfo info uf + -- We do *not* seq on the unfolding info, For some reason, doing so + -- actually increases residency significantly. + = info { unfoldingInfo = uf } - DeforestInfo -- Whether its definition should be - -- unfolded during deforestation +#ifdef OLD_STRICTNESS +setDemandInfo info dd = info { demandInfo = dd } +setCprInfo info cp = info { cprInfo = cp } +#endif - ArgUsageInfo -- how this Id uses its arguments +setArityInfo info ar = info { arityInfo = ar } +setCafInfo info caf = info { cafInfo = caf } - FBTypeInfo -- the Foldr/Build W/W property of this function. -\end{code} +setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } -\begin{code} -noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding - NoUpdateInfo Don'tDeforest NoArgUsageInfo NoFBTypeInfo +setNewDemandInfo info dd = dd `seq` info { newDemandInfo = dd } +setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } \end{code} -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@(IdInfo arity demand spec strictness unfold - update deforest arg_usage fb_ww) - | isNullSpecEnv spec - = idinfo - | otherwise - = panic "IdInfo:apply_to_IdInfo" -{- LATER: - 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 - 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} -Variant of the same thing for the typechecker. \begin{code} -applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold - update deforest arg_usage fb_ww) - = panic "IdInfo:applySubstToIdInfo" -{- LATER: - case (apply_spec s0 spec) of { (s1, new_spec) -> - (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww) } - 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) } --} +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 + } + +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in MkId. \end{code} -\begin{code} -ppIdInfo :: PprStyle - -> Bool -- True <=> print specialisations, please - -> IdInfo - -> Doc - -ppIdInfo sty specs_please - (IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype) - = hsep [ - -- order is important!: - ppArityInfo sty arity, - ppUpdateInfo sty update, - ppDeforestInfo sty deforest, - - ppStrictnessInfo sty strictness, - - if specs_please - then empty -- ToDo -- sty (not (isDataCon for_this_id)) - -- better_id_fn inline_env (mEnvToList specenv) - else empty, - - -- DemandInfo needn't be printed since it has no effect on interfaces - ppDemandInfo sty demand, - ppFBTypeInfo sty fbtype - ] -\end{code} %************************************************************************ %* * @@ -224,329 +413,287 @@ ppIdInfo sty specs_please %* * %************************************************************************ -\begin{code} -data ArityInfo - = UnknownArity -- No idea - | ArityExactly Int -- Arity is exactly this - | ArityAtLeast Int -- Arity is this or greater -\end{code} +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} -exactArity = ArityExactly -atLeastArity = ArityAtLeast -unknownArity = UnknownArity +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. -arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity + -- The arity might increase later in the compilation process, if + -- an extra lambda floats up to the binding site. -addArityInfo (IdInfo _ a c d e f g h i) arity = IdInfo arity a c d e f g h i +unknownArity = 0 :: Arity -ppArityInfo sty UnknownArity = empty -ppArityInfo sty (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity] -ppArityInfo sty (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity] +ppArityInfo 0 = empty +ppArityInfo n = hsep [ptext SLIT("Arity"), int n] \end{code} %************************************************************************ %* * -\subsection[demand-IdInfo]{Demand info about an @Id@} +\subsection{Inline-pragma information} %* * %************************************************************************ -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.) - -This information is only used within a module, it is not exported -(obviously). - -\begin{code} -data DemandInfo - = UnknownDemand - | DemandedAsPer Demand -\end{code} - \begin{code} -noDemandInfo = UnknownDemand - -mkDemandInfo :: Demand -> DemandInfo -mkDemandInfo demand = DemandedAsPer demand - -willBeDemanded :: DemandInfo -> Bool -willBeDemanded (DemandedAsPer demand) = isStrict demand -willBeDemanded _ = False +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 + + -- The default InlinePragInfo is AlwaysActive, so the info serves + -- entirely as a way to inhibit inlining until we want it \end{code} -\begin{code} -demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand - -addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i - -ppDemandInfo PprInterface _ = empty -ppDemandInfo sty UnknownDemand = text "{-# L #-}" -ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"] -\end{code} %************************************************************************ %* * -\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} + SpecInfo %* * %************************************************************************ -See SpecEnv.lhs - \begin{code} -specInfo (IdInfo _ _ spec _ _ _ _ _ _) = spec +-- CoreRules is used only in an idSpecialisation (move to IdInfo?) +data SpecInfo + = SpecInfo [CoreRule] VarSet -- Locally-defined free vars of RHSs + +emptySpecInfo :: SpecInfo +emptySpecInfo = SpecInfo [] emptyVarSet + +isEmptySpecInfo :: SpecInfo -> Bool +isEmptySpecInfo (SpecInfo rs _) = null rs + +specInfoFreeVars :: SpecInfo -> VarSet +specInfoFreeVars (SpecInfo _ fvs) = fvs -addSpecInfo id_info spec | isNullSpecEnv spec = id_info -addSpecInfo (IdInfo a b _ d e f g h i) spec = IdInfo a b spec d e f g h i +specInfoRules :: SpecInfo -> [CoreRule] +specInfoRules (SpecInfo rules _) = rules + +seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs \end{code} + %************************************************************************ %* * -\subsection[strictness-IdInfo]{Strictness info about an @Id@} +\subsection[worker-IdInfo]{Worker 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). +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. -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. +There might not be a worker, even for a strict function, because: +(a) the function might be small enough to inline, so no need + for w/w split +(b) the strictness info might be "SSS" or something, so no w/w split. -\begin{code} -data StrictnessInfo bdee - = NoStrictnessInfo - - | BottomGuaranteed -- This Id guarantees never to return; - -- it is bottom regardless of its arguments. - -- Useful for "error" and other disguised - -- variants thereof. - - | StrictnessInfo [Demand] -- The main stuff; see below. - (Maybe bdee) -- Worker's Id, if applicable. - -- (It may not be applicable because the strictness info - -- might say just "SSS" or something; so there's no w/w split.) -\end{code} - -\begin{code} -mkStrictnessInfo :: [Demand] -> Maybe bdee -> StrictnessInfo bdee +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. -mkStrictnessInfo xs wrkr - | all is_lazy xs = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs wrkr - where - is_lazy (WwLazy False) = True -- NB "Absent" args do *not* count! - is_lazy _ = False -- (as they imply a worker) +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). -noStrictnessInfo = NoStrictnessInfo -mkBottomStrictnessInfo = BottomGuaranteed +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". -bottomIsGuaranteed BottomGuaranteed = True -bottomIsGuaranteed other = False - -strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict +\begin{code} -addStrictnessInfo id_info NoStrictnessInfo = id_info -addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i +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. -ppStrictnessInfo sty NoStrictnessInfo = empty -ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_") +seqWorker :: WorkerInfo -> () +seqWorker (HasWorker id a) = id `seq` a `seq` () +seqWorker NoWorker = () -ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe) - = hsep [ptext SLIT("_S_"), text (showList wrapper_args ""), pp_wrkr] - where - pp_wrkr = case wrkr_maybe of - Nothing -> empty - Just wrkr -> ppr sty wrkr -\end{code} +ppWorkerInfo NoWorker = empty +ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id +workerExists :: WorkerInfo -> Bool +workerExists NoWorker = False +workerExists (HasWorker _ _) = True -\begin{code} -workerExists :: StrictnessInfo bdee -> Bool -workerExists (StrictnessInfo _ (Just worker_id)) = True -workerExists other = False +workerId :: WorkerInfo -> Id +workerId (HasWorker id _) = id -getWorkerId_maybe :: StrictnessInfo bdee -> Maybe bdee -getWorkerId_maybe (StrictnessInfo _ maybe_worker_id) = maybe_worker_id -getWorkerId_maybe other = Nothing +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} -unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _ _) = unfolding +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). + +data CafInfo + = MayHaveCafRefs -- either: + -- (1) A function or static constructor + -- that refers to one or more CAFs, + -- (2) A real live CAF + + | NoCafRefs -- A function or static constructor + -- that refers to no CAFs. + +vanillaCafInfo = MayHaveCafRefs -- Definitely safe + +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +seqCaf c = c `seq` () -addUnfoldInfo (IdInfo a b d e _ f g h i) uf = IdInfo a b d e uf f g h i +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} -#ifdef REALLY_HASKELL_1_3 -instance Read UpdateInfo where -#else -instance Text UpdateInfo where -#endif - 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 -updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update + -- We used to keep nested info about sub-components, but + -- we never used it so I threw it away -addUpdateInfo id_info NoUpdateInfo = id_info -addUpdateInfo (IdInfo a b d e f _ g h i) upd_info = IdInfo a b d e f upd_info g h i +seqCpr :: CprInfo -> () +seqCpr ReturnsCPR = () +seqCpr NoCPRInfo = () -ppUpdateInfo sty NoUpdateInfo = empty -ppUpdateInfo sty (SomeUpdateInfo []) = empty -ppUpdateInfo sty (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec)) -\end{code} +noCprInfo = NoCPRInfo -%************************************************************************ -%* * -\subsection[deforest-IdInfo]{Deforestation info about an @Id@} -%* * -%************************************************************************ +ppCprInfo NoCPRInfo = empty +ppCprInfo ReturnsCPR = ptext SLIT("__M") -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} -deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest - -addDeforestInfo id_info Don'tDeforest = id_info -addDeforestInfo (IdInfo a b d e f g _ h i) deforest = IdInfo a b d e f g deforest h i - -ppDeforestInfo sty Don'tDeforest = empty -ppDeforestInfo sty DoDeforest = ptext 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 [] = NoArgUsageInfo -mkArgUsageInfo au = SomeArgUsageInfo au +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} -argUsageInfo (IdInfo _ _ _ _ _ _ _ au _) = au +hasNoLBVarInfo NoLBVarInfo = True +hasNoLBVarInfo IsOneShotLambda = False -addArgUsageInfo id_info NoArgUsageInfo = id_info -addArgUsageInfo (IdInfo a b d e f g h _ i) au_info = IdInfo a b d e f g h au_info i +noLBVarInfo = NoLBVarInfo -ppArgUsageInfo sty NoArgUsageInfo = empty -ppArgUsageInfo sty (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut) +pprLBVarInfo NoLBVarInfo = empty +pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot") -ppArgUsage (ArgUsage n) = int n -ppArgUsage (UnknownArgUsage) = char '-' +instance Outputable LBVarInfo where + ppr = pprLBVarInfo -ppArgUsageType aut = hcat - [ char '"' , - hcat (punctuate comma (map ppArgUsage aut)), - char '"' ] +instance Show LBVarInfo where + showsPrec p c = showsPrecSDoc p (ppr c) \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 +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} -fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb - -addFBTypeInfo id_info NoFBTypeInfo = id_info -addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info - -ppFBTypeInfo sty NoFBTypeInfo = empty -ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod)) - = (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod) - -ppFBType cons prod = hcat - ([ char '"' ] ++ map ppCons cons ++ [ char '-', ppProd prod, char '"' ]) - where - ppCons FBGoodConsum = char 'G' - ppCons FBBadConsum = char 'B' - ppProd FBGoodProd = char 'G' - ppProd FBBadProd = char 'B' -\end{code}