X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FIdInfo.lhs;h=d53bf5627d99638a48f0f07e57eb846b4e0dc65a;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=b39b60c2568199f3231f095cea37d2734eae630f;hpb=0e8e53db37d75d506d3a5b2804342442a5142d59;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index b39b60c..d53bf56 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -11,12 +11,11 @@ module IdInfo ( GlobalIdDetails(..), notGlobalId, -- Not abstract IdInfo, -- Abstract - vanillaIdInfo, noCafNoTyGenIdInfo, + vanillaIdInfo, noCafIdInfo, seqIdInfo, megaSeqIdInfo, -- Zapping zapLamInfo, zapDemandInfo, - shortableIdInfo, copyIdInfo, -- Arity ArityInfo, @@ -25,27 +24,24 @@ module IdInfo ( -- New demand and strictness info newStrictnessInfo, setNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, + newDemandInfo, setNewDemandInfo, pprNewStrictness, + setAllStrictnessInfo, +#ifdef OLD_STRICTNESS -- Strictness; imported from Demand StrictnessInfo(..), mkStrictnessInfo, noStrictnessInfo, ppStrictnessInfo,isBottomingStrictness, - setAllStrictnessInfo, - - -- Usage generalisation - TyGenInfo(..), - tyGenInfo, setTyGenInfo, - noTyGenInfo, isNoTyGenInfo, ppTyGenInfo, tyGenInfoString, +#endif -- Worker WorkerInfo(..), workerExists, wrapperArity, workerId, workerInfo, setWorkerInfo, ppWorkerInfo, -- Unfolding - unfoldingInfo, setUnfoldingInfo, + unfoldingInfo, setUnfoldingInfo, setUnfoldingInfoLazily, -#ifdef DEBUG +#ifdef OLD_STRICTNESS -- Old DemandInfo and StrictnessInfo demandInfo, setDemandInfo, strictnessInfo, setStrictnessInfo, @@ -67,15 +63,11 @@ module IdInfo ( occInfo, setOccInfo, -- Specialisation - specInfo, setSpecInfo, - - -- CG info - CgInfo(..), cgInfo, setCgInfo, pprCgInfo, - cgCafInfo, vanillaCgInfo, - CgInfoEnv, lookupCgInfo, + SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, + specInfoFreeVars, specInfoRules, seqSpecInfo, -- CAF info - CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs, + CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, -- Lambda-bound variable info LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo @@ -85,11 +77,10 @@ module IdInfo ( import CoreSyn -import Type ( Type, usOnce, eqUsage ) +import Class ( Class ) import PrimOp ( PrimOp ) -import NameEnv ( NameEnv, lookupNameEnv ) -import Name ( Name ) import Var ( Id ) +import VarSet ( VarSet, emptyVarSet, seqVarSet ) import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -97,31 +88,33 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea Activation(..) ) import DataCon ( DataCon ) +import TyCon ( TyCon, FieldLabel ) import ForeignCall ( ForeignCall ) -import FieldLabel ( FieldLabel ) -import Type ( usOnce, usMany ) -import Demand hiding( Demand, seqDemand ) -import qualified Demand import NewDemand import Outputable -import Util ( seqList, listLengthCmp ) +import Maybe ( isJust ) + +#ifdef OLD_STRICTNESS +import Name ( Name ) +import Demand hiding( Demand, seqDemand ) +import qualified Demand +import Util ( listLengthCmp ) import List ( replicate ) +#endif -- infixl so you can say (id `set` a `set` b) -infixl 1 `setTyGenInfo`, - `setSpecInfo`, +infixl 1 `setSpecInfo`, `setArityInfo`, `setInlinePragInfo`, `setUnfoldingInfo`, `setWorkerInfo`, `setLBVarInfo`, `setOccInfo`, - `setCgInfo`, `setCafInfo`, `setNewStrictnessInfo`, `setAllStrictnessInfo`, `setNewDemandInfo` -#ifdef DEBUG +#ifdef OLD_STRICTNESS , `setCprInfo` , `setDemandInfo` , `setStrictnessInfo` @@ -141,7 +134,7 @@ To be removed later -- Set old and new strictness info setAllStrictnessInfo info Nothing = info { newStrictnessInfo = Nothing -#ifdef DEBUG +#ifdef OLD_STRICTNESS , strictnessInfo = NoStrictnessInfo , cprInfo = NoCPRInfo #endif @@ -149,7 +142,7 @@ setAllStrictnessInfo info Nothing setAllStrictnessInfo info (Just sig) = info { newStrictnessInfo = Just sig -#ifdef DEBUG +#ifdef OLD_STRICTNESS , strictnessInfo = oldStrictnessFromNew sig , cprInfo = cprInfoFromNewStrictness sig #endif @@ -158,7 +151,10 @@ setAllStrictnessInfo info (Just sig) seqNewStrictnessInfo Nothing = () seqNewStrictnessInfo (Just ty) = seqStrictSig ty -#ifdef DEBUG +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 @@ -188,7 +184,7 @@ mk_strict_sig name arity dmd_ty mkStrictSig dmd_ty newRes True _ = BotRes -newRes False ReturnsCPR = RetCPR +newRes False ReturnsCPR = retCPR newRes False NoCPRInfo = TopRes newDemand :: Demand.Demand -> NewDemand.Demand @@ -211,7 +207,13 @@ oldDemand (Eval (Prod ds)) = WwUnpack True (map oldDemand ds) oldDemand (Eval (Poly _)) = WwStrict oldDemand (Call _) = WwStrict -#endif /* DEBUG */ +#endif /* OLD_STRICTNESS */ +\end{code} + + +\begin{code} +seqNewDemandInfo Nothing = () +seqNewDemandInfo (Just dmd) = seqDemand dmd \end{code} @@ -229,13 +231,21 @@ an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported data GlobalIdDetails = VanillaGlobal -- Imported from elsewhere, a default method Id. - | RecordSelId FieldLabel -- The Id for a record selector - | DataConId DataCon -- The Id for a data constructor *worker* + | 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) we can suppress printing a definition in the interface file - -- b) when typechecking a pattern we can get from the - -- Id back to the data con] + -- 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 @@ -247,11 +257,12 @@ notGlobalId = NotGlobalId instance Outputable GlobalIdDetails where ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]") ppr VanillaGlobal = ptext SLIT("[GlobalId]") - ppr (DataConId _) = ptext SLIT("[DataCon]") + 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]") + ppr (RecordSelId {}) = ptext SLIT("[RecSel]") \end{code} @@ -278,16 +289,22 @@ case. KSW 1999-04). data IdInfo = IdInfo { arityInfo :: !ArityInfo, -- Its arity - specInfo :: CoreRules, -- Specialisations of this function which exist - tyGenInfo :: TyGenInfo, -- Restrictions on usage-generalisation of this Id -#ifdef DEBUG + 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 - cgInfo :: CgInfo, -- Code generator info (arity, CAF info) + cafInfo :: CafInfo, -- CAF info lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable inlinePragInfo :: InlinePragInfo, -- Inline pragma occInfo :: OccInfo, -- How it occurs @@ -296,7 +313,10 @@ data IdInfo -- know whether whether this is the first visit, -- so it can assign botSig. Other customers want -- topSig. So Nothing is good. - newDemandInfo :: Demand + + 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 -> () @@ -304,27 +324,24 @@ seqIdInfo (IdInfo {}) = () megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info - = seqRules (specInfo info) `seq` - seqTyGenInfo (tyGenInfo info) `seq` + = 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` - seqDemand (newDemandInfo info) `seq` + seqNewDemandInfo (newDemandInfo info) `seq` seqNewStrictnessInfo (newStrictnessInfo info) `seq` -#ifdef DEBUG +#ifdef OLD_STRICTNESS 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` - seqLBVar (lbvarInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqLBVar (lbvarInfo info) `seq` seqOccInfo (occInfo info) \end{code} @@ -333,39 +350,29 @@ Setters \begin{code} setWorkerInfo info wk = wk `seq` info { workerInfo = wk } 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 +#ifdef OLD_STRICTNESS setStrictnessInfo info st = st `seq` info { strictnessInfo = st } #endif -- Try to avoid spack leaks by seq'ing -setUnfoldingInfo info uf - | isEvaldUnfolding uf - -- If the unfolding is a value, the demand info may - -- go pear-shaped, so we nuke it. Example: - -- let x = (a,b) in - -- case x of (p,q) -> h p q x - -- Here x is certainly demanded. But after we've nuked - -- the case, we'll get just - -- let x = (a,b) in h a b x - -- and now x is not demanded (I'm assuming h is lazy) - -- This really happens. The solution here is a bit ad hoc... - = info { unfoldingInfo = uf, newDemandInfo = Top } +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.) - | otherwise +setUnfoldingInfo info uf -- We do *not* seq on the unfolding info, For some reason, doing so -- actually increases residency significantly. = info { unfoldingInfo = uf } -#ifdef DEBUG +#ifdef OLD_STRICTNESS 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 } +setArityInfo info ar = info { arityInfo = ar } +setCafInfo info caf = info { cafInfo = caf } setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb } @@ -378,29 +385,25 @@ setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd } vanillaIdInfo :: IdInfo vanillaIdInfo = IdInfo { - cgInfo = noCgInfo, + cafInfo = vanillaCafInfo, arityInfo = unknownArity, -#ifdef DEBUG +#ifdef OLD_STRICTNESS cprInfo = NoCPRInfo, demandInfo = wwLazy, strictnessInfo = NoStrictnessInfo, #endif - specInfo = emptyCoreRules, - tyGenInfo = noTyGenInfo, + specInfo = emptySpecInfo, workerInfo = NoWorker, unfoldingInfo = noUnfolding, lbvarInfo = NoLBVarInfo, inlinePragInfo = AlwaysActive, occInfo = NoOccInfo, - newDemandInfo = topDmd, + newDemandInfo = Nothing, newStrictnessInfo = Nothing } -noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever - `setCgInfo` CgInfo NoCafRefs +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs -- Used for built-in type Ids in MkId. - -- Many built-in things have fixed types, so we shouldn't - -- run around generalising them \end{code} @@ -444,81 +447,36 @@ type InlinePragInfo = Activation -- -- 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} %************************************************************************ -%* * -\subsection[TyGen-IdInfo]{Type generalisation info about an @Id@} -%* * +%* * + SpecInfo +%* * %************************************************************************ -Certain passes (notably usage inference) may change the type of an -identifier, modifying all in-scope uses of that identifier -appropriately to maintain type safety. - -However, some identifiers must not have their types changed in this -way, because their types are conjured up in the front end of the -compiler rather than being read from the interface file. Default -methods, dictionary functions, record selectors, and others are in -this category. (see comment at TcClassDcl.tcClassSig). - -To indicate this property, such identifiers are marked TyGenNever. - -Furthermore, if the usage inference generates a usage-specialised -variant of a function, we must NOT re-infer a fully-generalised type -at the next inference. This finer property is indicated by a -TyGenUInfo on the identifier. - \begin{code} -data TyGenInfo - = NoTyGenInfo -- no restriction on type generalisation +-- CoreRules is used only in an idSpecialisation (move to IdInfo?) +data SpecInfo + = SpecInfo [CoreRule] VarSet -- Locally-defined free vars of RHSs - | TyGenUInfo [Maybe Type] -- restrict generalisation of this Id to - -- preserve specified usage annotations +emptySpecInfo :: SpecInfo +emptySpecInfo = SpecInfo [] emptyVarSet - | TyGenNever -- never generalise the type of this Id -\end{code} +isEmptySpecInfo :: SpecInfo -> Bool +isEmptySpecInfo (SpecInfo rs _) = null rs -For TyGenUInfo, the list has one entry for each usage annotation on -the type of the Id, in left-to-right pre-order (annotations come -before the type they annotate). Nothing means no restriction; Just -usOnce or Just usMany forces that annotation to that value. Other -usage annotations are illegal. +specInfoFreeVars :: SpecInfo -> VarSet +specInfoFreeVars (SpecInfo _ fvs) = fvs -\begin{code} -seqTyGenInfo :: TyGenInfo -> () -seqTyGenInfo NoTyGenInfo = () -seqTyGenInfo (TyGenUInfo us) = seqList us () -seqTyGenInfo TyGenNever = () - -noTyGenInfo :: TyGenInfo -noTyGenInfo = NoTyGenInfo - -isNoTyGenInfo :: TyGenInfo -> Bool -isNoTyGenInfo NoTyGenInfo = True -isNoTyGenInfo _ = False - --- NB: There's probably no need to write this information out to the interface file. --- Why? Simply because imported identifiers never get their types re-inferred. --- But it's definitely nice to see in dumps, it for debugging purposes. - -ppTyGenInfo :: TyGenInfo -> SDoc -ppTyGenInfo NoTyGenInfo = empty -ppTyGenInfo (TyGenUInfo us) = ptext SLIT("__G") <+> text (tyGenInfoString us) -ppTyGenInfo TyGenNever = ptext SLIT("__G N") - -tyGenInfoString us = map go us - where go Nothing = 'x' -- for legibility, choose - go (Just u) | u `eqUsage` usOnce = '1' -- chars with identity - | u `eqUsage` usMany = 'M' -- Z-encoding. - go other = pprPanic "IdInfo.tyGenInfoString: unexpected annotation" (ppr other) - -instance Outputable TyGenInfo where - ppr = ppTyGenInfo - -instance Show TyGenInfo where - showsPrec p c = showsPrecSDoc p (ppr c) +specInfoRules :: SpecInfo -> [CoreRule] +specInfoRules (SpecInfo rules _) = rules + +seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs \end{code} @@ -559,14 +517,14 @@ this to". data WorkerInfo = NoWorker | HasWorker Id Arity -- The Arity is the arity of the *wrapper* at the moment of the - -- w/w split. See comments in MkIface.ifaceId, with the 'Worker' code. + -- w/w split. See notes above. seqWorker :: WorkerInfo -> () seqWorker (HasWorker id a) = id `seq` a `seq` () seqWorker NoWorker = () ppWorkerInfo NoWorker = empty -ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("__P") <+> ppr wk_id +ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("Worker") <+> ppr wk_id workerExists :: WorkerInfo -> Bool workerExists NoWorker = False @@ -586,31 +544,7 @@ wrapperArity (HasWorker _ a) = a %* * %************************************************************************ -CgInfo encapsulates calling-convention information produced by the code -generator. It is pasted into the IdInfo of each emitted Id by CoreTidy, -but only as a thunk --- the information is only actually produced further -downstream, by the code generator. - \begin{code} -#ifndef DEBUG -newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo -noCgInfo = panic "NoCgInfo!" -#else -data CgInfo = CgInfo CafInfo - | NoCgInfo -- In debug mode we don't want a black hole here - -- See Id.idCgInfo - -- noCgInfo is used for local Ids, which shouldn't need any CgInfo -noCgInfo = NoCgInfo -#endif - -cgCafInfo (CgInfo caf_info) = caf_info - -setCafInfo info caf_info = info `setCgInfo` CgInfo caf_info - -seqCg c = c `seq` () -- fields are strict anyhow - -vanillaCgInfo = CgInfo MayHaveCafRefs -- Definitely safe - -- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). data CafInfo @@ -622,30 +556,17 @@ data CafInfo | NoCafRefs -- A function or static constructor -- that refers to no CAFs. +vanillaCafInfo = MayHaveCafRefs -- Definitely safe + mayHaveCafRefs MayHaveCafRefs = True mayHaveCafRefs _ = False seqCaf c = c `seq` () -pprCgInfo (CgInfo caf_info) = ppCafInfo caf_info - -ppArity 0 = empty -ppArity n = hsep [ptext SLIT("__A"), int n] - -ppCafInfo NoCafRefs = ptext SLIT("__C") +ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs") ppCafInfo MayHaveCafRefs = empty \end{code} -\begin{code} -type CgInfoEnv = NameEnv CgInfo - -lookupCgInfo :: NameEnv CgInfo -> Name -> CgInfo -lookupCgInfo env n = case lookupNameEnv env n of - Just info -> info - Nothing -> pprTrace "Urk! Not in CgInfo env" (ppr n) vanillaCgInfo -\end{code} - - %************************************************************************ %* * \subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@} @@ -671,7 +592,7 @@ function has the CPR property and which components of the result are also CPRs. \begin{code} -#ifdef DEBUG +#ifdef OLD_STRICTNESS data CprInfo = NoCPRInfo | ReturnsCPR -- Yes, this function returns a constructed product @@ -708,42 +629,28 @@ instance Show CprInfo where %************************************************************************ If the @Id@ is a lambda-bound variable then it may have lambda-bound -var info. The usage analysis (UsageSP) detects whether the lambda -binding this var is a ``one-shot'' lambda; that is, whether it is -applied at most once. +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} -data LBVarInfo - = NoLBVarInfo - - | LBVarInfo Type -- The lambda that binds this Id has this usage - -- annotation (i.e., if ==usOnce, then the - -- lambda is applied at most once). - -- The annotation's kind must be `$' - -- HACK ALERT! placing this info here is a short-term hack, - -- but it minimises changes to the rest of the compiler. - -- Hack agreed by SLPJ/KSW 1999-04. +data LBVarInfo = NoLBVarInfo + | IsOneShotLambda -- The lambda is applied at most once). seqLBVar l = l `seq` () \end{code} \begin{code} -hasNoLBVarInfo NoLBVarInfo = True -hasNoLBVarInfo other = False +hasNoLBVarInfo NoLBVarInfo = True +hasNoLBVarInfo IsOneShotLambda = False noLBVarInfo = NoLBVarInfo --- not safe to print or parse LBVarInfo because it is not really a --- property of the definition, but a property of the context. pprLBVarInfo NoLBVarInfo = empty -pprLBVarInfo (LBVarInfo u) | u `eqUsage` usOnce - = ptext SLIT("OneShot") - | otherwise - = empty +pprLBVarInfo IsOneShotLambda = ptext SLIT("OneShot") instance Outputable LBVarInfo where ppr = pprLBVarInfo @@ -765,94 +672,28 @@ part of an unsaturated lambda \begin{code} zapLamInfo :: IdInfo -> Maybe IdInfo zapLamInfo info@(IdInfo {occInfo = occ, newDemandInfo = demand}) - | is_safe_occ && not (isStrictDmd demand) + | is_safe_occ occ && is_safe_dmd demand = Nothing | otherwise - = Just (info {occInfo = safe_occ, - newDemandInfo = Top}) + = 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 = case occ of - OneOcc in_lam once -> in_lam - other -> True + is_safe_occ (OneOcc in_lam _ _) = in_lam + is_safe_occ other = True safe_occ = case occ of - OneOcc _ once -> OneOcc insideLam once - other -> occ + OneOcc _ once int_cxt -> OneOcc insideLam once int_cxt + other -> occ + + is_safe_dmd Nothing = True + is_safe_dmd (Just dmd) = not (isStrictDmd dmd) \end{code} \begin{code} zapDemandInfo :: IdInfo -> Maybe IdInfo -zapDemandInfo info@(IdInfo {newDemandInfo = demand}) - | not (isStrictDmd demand) = Nothing - | otherwise = Just (info {newDemandInfo = Top}) +zapDemandInfo info@(IdInfo {newDemandInfo = dmd}) + | isJust dmd = Just (info {newDemandInfo = Nothing}) + | otherwise = Nothing \end{code} - -copyIdInfo is used when shorting out a top-level binding - f_local = BIG - f = f_local -where f is exported. We are going to swizzle it around to - f = BIG - f_local = f - -BUT (a) we must be careful about messing up rules - (b) we must ensure f's IdInfo ends up right - -(a) Messing up the rules -~~~~~~~~~~~~~~~~~~~~ -The example that went bad on me was this one: - - iterate :: (a -> a) -> a -> [a] - iterate = iterateList - - iterateFB c f x = x `c` iterateFB c f (f x) - iterateList f x = x : iterateList f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterateList - #-} - -This got shorted out to: - - iterateList :: (a -> a) -> a -> [a] - iterateList = iterate - - iterateFB c f x = x `c` iterateFB c f (f x) - iterate f x = x : iterate f (f x) - - {-# RULES - "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x) - "iterateFB" iterateFB (:) = iterate - #-} - -And now we get an infinite loop in the rule system - iterate f x -> build (\cn -> iterateFB c f x) - -> iterateFB (:) f x - -> iterate f x - -Tiresome solution: don't do shorting out if f has rewrite rules. -Hence shortableIdInfo. - -(b) Keeping the IdInfo right -~~~~~~~~~~~~~~~~~~~~~~~~ -We want to move strictness/worker info from f_local to f, but keep the rest. -Hence copyIdInfo. - -\begin{code} -shortableIdInfo :: IdInfo -> Bool -shortableIdInfo info = isEmptyCoreRules (specInfo info) - -copyIdInfo :: IdInfo -- f_local - -> IdInfo -- f (the exported one) - -> IdInfo -- New info for f -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}