X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=ee87e0ae919466000cb3a4d63487d5bd8c9266cb;hb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;hp=c06e976802c0700192d9f5f65f7a1c3f23404653;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index c06e976..ee87e0a 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \section[SimplEnv]{Environment stuff for the simplifier} @@ -10,10 +10,8 @@ module SimplEnv ( nullSimplEnv, pprSimplEnv, -- debugging only ---UNUSED: getInEnvs, replaceInEnvs, nullInEnvs, - nullTyVarEnv, extendTyEnv, extendTyEnvList, simplTy, simplTyInId, @@ -23,7 +21,6 @@ module SimplEnv ( lookupId, extendUnfoldEnvGivenRhs, ---OLD: extendUnfoldEnvWithRecInlinings, extendUnfoldEnvGivenFormDetails, extendUnfoldEnvGivenConstructor, lookForConstructor, @@ -31,68 +28,70 @@ module SimplEnv ( getSwitchChecker, switchIsSet, ---UNUSED: getEnclosingCC, setEnclosingCC, - mkFormSummary, - -- Types - SwitchChecker(..), - SimplEnv, UnfoldingDetails(..), UnfoldingGuidance(..), - FormSummary(..), EnclosingCcDetails(..), + SwitchChecker(..), + SimplEnv, EnclosingCcDetails(..), InIdEnv(..), IdVal(..), InTypeEnv(..), UnfoldEnv, UnfoldItem, UnfoldConApp, - -- re-exported from BinderInfo - BinderInfo(..), - FunOrArg, DuplicationDanger, InsideSCC, -- sigh - - InId(..), InBinder(..), InType(..), InBinding(..), InUniType(..), - OutId(..), OutBinder(..), OutType(..), OutBinding(..), OutUniType(..), + InId(..), InBinder(..), InBinding(..), InType(..), + OutId(..), OutBinder(..), OutBinding(..), OutType(..), - InExpr(..), InAtom(..), InAlts(..), InDefault(..), InArg(..), - OutExpr(..), OutAtom(..), OutAlts(..), OutDefault(..), OutArg(..), + InExpr(..), InAlts(..), InDefault(..), InArg(..), + OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) -- and to make the interface self-sufficient... - BasicLit, GlobalSwitch, SimplifierSwitch, SwitchResult, CoreAtom, - CoreCaseAlternatives, CoreExpr, Id, - IdEnv(..), UniqFM, Unique, - MagicUnfoldingFun, Maybe, TyVar, TyVarEnv(..), UniType - - IF_ATTACK_PRAGMAS(COMMA applyTypeEnvToTy COMMA applyTypeEnvToId) - IF_ATTACK_PRAGMAS(COMMA emptyUFM COMMA lookupUFM COMMA lookupIdEnv) -- profiling ) where -IMPORT_Trace +import Ubiq{-uitous-} -import AbsPrel ( buildId ) -import AbsUniType ( applyTypeEnvToTy, getUniDataTyCon, cmpUniType ) -import Bag ( emptyBag, Bag ) -import BasicLit ( isNoRepLit, BasicLit(..), PrimKind ) -- .. for pragmas only -import BinderInfo -import CmdLineOpts ( switchIsOn, intSwitchSet, - SimplifierSwitch(..), SwitchResult +import SmplLoop -- breaks the MagicUFs / SimplEnv loop + +import BinderInfo ( BinderInfo{-instances-} ) +import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult ) +import CoreSyn +import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, + calcUnfoldingGuidance, UnfoldingGuidance(..), + mkFormSummary, FormSummary ) -import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) -import CostCentre -import FiniteMap -import Id ( getIdUnfolding, eqId, cmpId, applyTypeEnvToId, - getIdUniType, getIdStrictness, isWorkerId, - isBottomingId +import FiniteMap -- lots of things +import Id ( idType, getIdUnfolding, getIdStrictness, + applyTypeEnvToId, + nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, + addOneToIdEnv, modifyIdEnv, + IdEnv(..), IdSet(..), GenId ) +import IdInfo ( StrictnessInfo ) +import Literal ( isNoRepLit, Literal{-instances-} ) +import Outputable ( Outputable(..){-instances-} ) +import PprCore -- various instances +import PprStyle ( PprStyle(..) ) +import PprType ( GenType, GenTyVar ) +import Pretty +import Type ( getAppDataTyCon, applyTypeEnvToTy ) +import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, + growTyVarEnvList, + TyVarEnv(..), GenTyVar{-instance Eq-} ) -import IdEnv -import IdInfo -import MagicUFs -import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) -import OccurAnal ( occurAnalyseExpr ) -import PlainCore -- for the "Out*" types and things -import Pretty -- debugging only -import SimplUtils ( simplIdWantsToBeINLINEd ) -import TaggedCore -- for the "In*" types and things -import TyVarEnv -import UniqFM ( lookupDirectlyUFM, addToUFM_Directly, ufmToList ) -import UniqSet -import Util +import Unique ( Unique{-instance Outputable-} ) +import UniqSet -- lots of things +import Usage ( UVar(..), GenUsage{-instances-} ) +import Util ( zipEqual, panic, assertPanic ) + +type TypeEnv = TyVarEnv Type +addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)" +bottomIsGuaranteed = panic "bottomIsGuaranteed (SimplEnv)" +cmpType = panic "cmpType (SimplEnv)" +exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)" +lookupDirectlyUFM = panic "lookupDirectlyUFM (SimplEnv)" +manifestlyWHNF = panic "manifestlyWHNF (SimplEnv)" +occurAnalyseExpr = panic "occurAnalyseExpr (SimplEnv)" +oneSafeOcc = panic "oneSafeOcc (SimplEnv)" +oneTextualOcc = panic "oneTextualOcc (SimplEnv)" +simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" +uNFOLDING_CREATION_THRESHOLD = panic "uNFOLDING_CREATION_THRESHOLD (SimplEnv)" +ufmToList = panic "ufmToList (SimplEnv)" \end{code} %************************************************************************ @@ -113,10 +112,10 @@ INVARIANT: we assume {\em no shadowing}. (ToDo: How can we ASSERT this? WDP 94/06) This allows us to neglect keeping everything paired with its static environment. -The environment contains bindings for all +The environment contains bindings for all {\em in-scope,} {\em locally-defined} -things. +things. For such things, any unfolding is found in the environment, not in the Id. Unfoldings in the Id itself are used only for imported things @@ -125,34 +124,34 @@ inside the Ids, etc.). \begin{code} data SimplEnv - = SimplEnv - (SwitchChecker SimplifierSwitch) + = SimplEnv + SwitchChecker EnclosingCcDetails -- the enclosing cost-centre (when profiling) InTypeEnv -- For cloning types -- Domain is all in-scope type variables - + InIdEnv -- IdEnv - -- Domain is - -- *all* - -- *in-scope*, - -- *locally-defined* + -- Domain is + -- *all* + -- *in-scope*, + -- *locally-defined* -- *InIds* -- (Could omit the exported top-level guys, -- since their names mustn't change; and ditto -- the non-exported top-level guys which you -- don't want to macro-expand, since their -- names need not change.) - -- + -- -- Starts off empty - + UnfoldEnv -- Domain is any *OutIds*, including imports -- where we know something more than the -- interface file tells about their value (see -- below) -nullSimplEnv :: SwitchChecker SimplifierSwitch -> SimplEnv +nullSimplEnv :: SwitchChecker -> SimplEnv nullSimplEnv sw_chkr = SimplEnv sw_chkr NoEnclosingCcDetails nullTyVarEnv nullIdEnv null_unfold_env @@ -169,25 +168,23 @@ pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _)) pp_id_entry (v, idval) = ppCat [ppr PprDebug v, ppStr "=>", case idval of - InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e] - ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a] + InlineIt _ _ e -> ppCat [ppStr "InlineIt:", ppr PprDebug e] + ItsAnAtom a -> ppCat [ppStr "Atom:", ppr PprDebug a] ] pp_uf_entry (UnfoldItem v form encl_cc) = ppCat [ppr PprDebug v, ppStr "=>", case form of - NoUnfoldingDetails -> ppStr "NoUnfoldingDetails" - LiteralForm l -> ppCat [ppStr "Lit:", ppr PprDebug l] - OtherLiteralForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]] - ConstructorForm c t a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a] - OtherConstructorForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") - [ppr PprDebug c | c <- cs]] - GeneralForm t w e g -> ppCat [ppStr "UF:", - ppr PprDebug t, - ppr PprDebug w, + NoUnfoldingDetails -> ppStr "NoUnfoldingDetails" + LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l] + OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") + [ppr PprDebug l | l <- ls]] + ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a] + OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") + [ppr PprDebug c | c <- cs]] + GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w, ppr PprDebug g, ppr PprDebug e] - MagicForm s _ -> ppCat [ppStr "Magic:", ppPStr s] - IWantToBeINLINEd _ -> ppStr "IWantToBeINLINEd" + MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s] ] \end{code} @@ -225,16 +222,16 @@ data IdVal -- If x gets an InlineIt, we must remember -- the correct binding for y. - | ItsAnAtom OutAtom -- Used either (a) to record the cloned Id + | ItsAnAtom OutArg -- Used either (a) to record the cloned Id -- or (b) if the orig defn is a let-binding, and -- the RHS of the let simplifies to an atom, - -- we just bind the variable to that atom, and + -- we just bind the variable to that atom, and -- elide the let. \end{code} %************************************************************************ %* * -\subsubsection{The @UnfoldEnv@, @UnfoldingDetails@, and @UnfoldingGuidance@ types} +\subsubsection{The @UnfoldEnv@ type} %* * %************************************************************************ @@ -261,15 +258,13 @@ data UnfoldItem -- a glorified triple... -- that was in force. data UnfoldConApp -- yet another glorified triple - = UCA OutId -- same fields as ConstructorForm; - [UniType] -- a new type so we can make - [OutAtom] -- Ord work on it (instead of on - -- UnfoldingDetails). + = UCA OutId -- same fields as ConForm + [OutArg] data UnfoldEnv -- yup, a glorified triple... = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem IdSet -- The Ids in the domain of the env - -- which have details (GeneralForm True ...) + -- which have details (GenForm True ...) -- i.e., they claim they are duplicatable. -- These are the ones we have to worry -- about when adding new items to the @@ -304,11 +299,11 @@ lookup_unfold_env_encl_cc grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env grow_unfold_env (UFE u_env interesting_ids con_apps) id - uf_details@(GeneralForm True _ _ _) encl_cc + uf_details@(GenForm True _ _ _) encl_cc -- Only interested in Ids which have a "dangerous" unfolding; that is -- one that claims to have a single occurrence. = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - (interesting_ids `unionUniqSets` singletonUniqSet id) + (addOneToUniqSet interesting_ids id) con_apps grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc @@ -318,12 +313,12 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc where new_con_apps = case uf_details of - ConstructorForm con targs vargs + ConForm con vargs -> case (lookupFM con_apps entry) of Just _ -> con_apps -- unchanged; we hang onto what we have Nothing -> addToFM con_apps entry id where - entry = UCA con targs vargs + entry = UCA con vargs not_a_constructor -> con_apps -- unchanged @@ -332,7 +327,7 @@ addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items -- otherwise, we'd need to change con_apps UFE (growIdEnvList u_env extra_items) interesting_ids con_apps where - constructor_form_in_those (_, UnfoldItem _ (ConstructorForm _ _ _) _) = True + constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True constructor_form_in_those _ = False rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env @@ -352,8 +347,8 @@ lookup_unfold_env_encl_cc (UFE u_env _ _) id Nothing -> NoEnclosingCcDetails Just (UnfoldItem _ _ encl_cc) -> encl_cc -lookup_conapp (UFE _ _ con_apps) con ty_args con_args - = lookupFM con_apps (UCA con ty_args con_args) +lookup_conapp (UFE _ _ con_apps) con args + = lookupFM con_apps (UCA con args) modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps @@ -362,7 +357,7 @@ modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id -- we modify it. modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem -modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) +modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc \end{code} @@ -378,18 +373,16 @@ instance Ord UnfoldConApp where a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False } a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True } a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True } -#ifdef __GLASGOW_HASKELL__ _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } -#endif -cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2) - = case cmpId c1 c2 of +instance Ord3 UnfoldConApp where + cmp = cmp_app + +cmp_app (UCA c1 as1) (UCA c2 as2) + = case (c1 `cmp` c2) of LT_ -> LT_ GT_ -> GT_ - _ -> case (cmp_lists (cmpUniType True{-properly-}) tys1 tys2) of - LT_ -> LT_ - GT_ -> GT_ - _ -> cmp_lists cmp_atom as1 as2 + _ -> cmp_lists cmp_atom as1 as2 where cmp_lists cmp_item [] [] = EQ_ cmp_lists cmp_item (x:xs) [] = GT_ @@ -397,176 +390,11 @@ cmp_app (UCA c1 tys1 as1) (UCA c2 tys2 as2) cmp_lists cmp_item (x:xs) (y:ys) = case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other } - cmp_atom (CoVarAtom x) (CoVarAtom y) = x `cmpId` y - cmp_atom (CoVarAtom _) _ = LT_ - cmp_atom (CoLitAtom x) (CoLitAtom y) -#ifdef __GLASGOW_HASKELL__ + cmp_atom (VarArg x) (VarArg y) = x `cmp` y + cmp_atom (VarArg _) _ = LT_ + cmp_atom (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } -#else - = if x == y then EQ_ elsid if x < y then LT_ else GT_ -#endif - cmp_atom (CoLitAtom _) _ = GT_ -\end{code} - -\begin{code} -data UnfoldingDetails - = NoUnfoldingDetails - - | LiteralForm - BasicLit - - | OtherLiteralForm - [BasicLit] -- It is a literal, but definitely not one of these - - | ConstructorForm - Id -- The constructor - [UniType] -- Type args - [OutAtom] -- Value arguments; NB OutAtoms, already cloned - - | OtherConstructorForm - [Id] -- It definitely isn't one of these constructors - -- This captures the situation in the default branch of - -- a case: case x of - -- c1 ... -> ... - -- c2 ... -> ... - -- v -> default-rhs - -- Then in default-rhs we know that v isn't c1 or c2. - -- - -- NB. In the degenerate: case x of {v -> default-rhs} - -- x will be bound to - -- OtherConstructorForm [] - -- which captures the idea that x is eval'd but we don't - -- know which constructor. - - - | GeneralForm - Bool -- True <=> At most one textual occurrence of the - -- binder in its scope, *or* - -- if we are happy to duplicate this - -- binding. - FormSummary -- Tells whether the template is a WHNF or bottom - TemplateOutExpr -- The template - UnfoldingGuidance -- Tells about the *size* of the template. - - | MagicForm - FAST_STRING - MagicUnfoldingFun - - {-OLD? Nukable? ("Also turgid" SLPJ)-} - | IWantToBeINLINEd -- Means this has an INLINE pragma; - -- Used for things which have a defn in this module - UnfoldingGuidance -- Guidance from the pragma; usually UnfoldAlways. - -data FormSummary - = WhnfForm -- Expression is WHNF - | BottomForm -- Expression is guaranteed to be bottom. We're more gung - -- ho about inlining such things, because it can't waste work - | OtherForm -- Anything else - -instance Outputable FormSummary where - ppr sty WhnfForm = ppStr "WHNF" - ppr sty BottomForm = ppStr "Bot" - ppr sty OtherForm = ppStr "Other" - -mkFormSummary :: StrictnessInfo -> CoreExpr bndr Id -> FormSummary -mkFormSummary si expr - | manifestlyWHNF expr = WhnfForm - | bottomIsGuaranteed si = BottomForm - - -- Chances are that the Id will be decorated with strictness info - -- telling that the RHS is definitely bottom. This *might* not be the - -- case, if it's been a while since strictness analysis, but leaving out - -- the test for manifestlyBottom makes things a little more efficient. - -- We can always put it back... - -- | manifestlyBottom expr = BottomForm - - | otherwise = OtherForm -\end{code} - -\begin{code} -data UnfoldingGuidance - = UnfoldNever -- Don't do it! - - | UnfoldAlways -- There is no "original" definition, - -- so you'd better unfold. Or: something - -- so cheap to unfold (e.g., 1#) that - -- you should do it absolutely always. - - | EssentialUnfolding -- Like UnfoldAlways, but you *must* do - -- it absolutely always. - -- This is what we use for data constructors - -- and PrimOps, because we don't feel like - -- generating curried versions "just in case". - - | UnfoldIfGoodArgs Int -- if "m" type args and "n" value args; and - Int -- those val args are manifestly data constructors - [Bool] -- the val-arg positions marked True - -- (i.e., a simplification will definitely - -- be possible). - Int -- The "size" of the unfolding; to be elaborated - -- later. ToDo -\end{code} - -\begin{code} -instance Outputable UnfoldingGuidance where - ppr sty UnfoldNever = ppStr "_N_" - ppr sty UnfoldAlways = ppStr "_ALWAYS_" - ppr sty EssentialUnfolding = ppStr "_ESSENTIAL_" -- shouldn't appear in an iface - ppr sty (UnfoldIfGoodArgs t v cs size) - = ppCat [ppStr "_IF_ARGS_", ppInt t, ppInt v, - if null cs -- always print *something* - then ppChar 'X' - else ppBesides (map pp_c cs), - ppInt size ] - where - pp_c False = ppChar 'X' - pp_c True = ppChar 'C' -\end{code} - -%************************************************************************ -%* * -\subsection{@mkGenForm@ and @modifyUnfoldingDetails@} -%* * -%************************************************************************ - -\begin{code} -mkGenForm :: Bool -- Ok to Dup code down different case branches, - -- because of either a flag saying so, - -- or alternatively the object is *SMALL* - -> BinderInfo -- - -> FormSummary - -> TemplateOutExpr -- Template - -> UnfoldingGuidance -- Tells about the *size* of the template. - -> UnfoldingDetails - -mkGenForm safe_to_dup occ_info WhnfForm template guidance - = GeneralForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance - -mkGenForm safe_to_dup occ_info form_summary template guidance - | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences - = GeneralForm True form_summary template guidance - - | otherwise -- Not a WHNF, many occurrences - = NoUnfoldingDetails -\end{code} - -\begin{code} -modifyUnfoldingDetails - :: Bool -- OK to dup - -> BinderInfo -- New occurrence info for the thing - -> UnfoldingDetails - -> UnfoldingDetails - -modifyUnfoldingDetails ok_to_dup occ_info - (GeneralForm only_one form_summary template guidance) - | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance - -{- OLD: - | otherwise = NoUnfoldingDetails - I can't see why we zap bindings which don't claim to be unique --} - -modifyUnfoldingDetails ok_to_dup occ_info other = other + cmp_atom (LitArg _) _ = GT_ \end{code} %************************************************************************ @@ -588,35 +416,28 @@ data EnclosingCcDetails %************************************************************************ \begin{code} -type InId = Id -- Not yet cloned -type InBinder = (InId, BinderInfo) -type InType = UniType -- Ditto +type InId = Id -- Not yet cloned +type InBinder = (InId, BinderInfo) +type InType = Type -- Ditto type InBinding = SimplifiableCoreBinding type InExpr = SimplifiableCoreExpr -type InAtom = SimplifiableCoreAtom -- same as PlainCoreAtom -type InAlts = SimplifiableCoreCaseAlternatives +type InAlts = SimplifiableCoreCaseAlts type InDefault = SimplifiableCoreCaseDefault -type InArg = CoreArg InId -type InUniType = UniType +type InArg = SimplifiableCoreArg -type OutId = Id -- Cloned +type OutId = Id -- Cloned type OutBinder = Id -type OutType = UniType -- Cloned -type OutBinding = PlainCoreBinding -type OutExpr = PlainCoreExpr -type OutAtom = PlainCoreAtom -type OutAlts = PlainCoreCaseAlternatives -type OutDefault = PlainCoreCaseDefault -type OutArg = CoreArg OutId -type OutUniType = UniType - -type TemplateOutExpr = CoreExpr (OutId, BinderInfo) OutId - -- An OutExpr with occurrence info attached - -- This is used as a template in GeneralForms. +type OutType = Type -- Cloned +type OutBinding = CoreBinding +type OutExpr = CoreExpr +type OutAlts = CoreCaseAlts +type OutDefault = CoreCaseDefault +type OutArg = CoreArg + \end{code} \begin{code} -type SwitchChecker switch = switch -> SwitchResult +type SwitchChecker = SimplifierSwitch -> SwitchResult \end{code} %************************************************************************ @@ -632,7 +453,7 @@ type SwitchChecker switch = switch -> SwitchResult %************************************************************************ \begin{code} -getSwitchChecker :: SimplEnv -> SwitchChecker SimplifierSwitch +getSwitchChecker :: SimplEnv -> SwitchChecker getSwitchChecker (SimplEnv chkr _ _ _ _) = chkr switchIsSet :: SimplEnv -> SimplifierSwitch -> Bool @@ -647,10 +468,6 @@ switchIsSet (SimplEnv chkr _ _ _ _) switch %************************************************************************ \begin{code} --- UNUSED: ---getEnclosingCC :: SimplEnv -> EnclosingCcDetails ---getEnclosingCC (SimplEnv _ encl_cc _ _ _) = encl_cc - setEnclosingCC :: SimplEnv -> EnclosingCcDetails -> SimplEnv setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc @@ -664,40 +481,36 @@ setEnclosingCC (SimplEnv chkr _ ty_env id_env unfold_env) encl_cc %************************************************************************ \begin{code} -type InTypeEnv = TypeEnv -- Maps InTyVars to OutUniTypes +type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes -extendTyEnv :: SimplEnv -> TyVar -> UniType -> SimplEnv +extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv extendTyEnv (SimplEnv chkr encl_cc ty_env id_env unfold_env) tyvar ty = SimplEnv chkr encl_cc new_ty_env id_env unfold_env where new_ty_env = addOneToTyVarEnv ty_env tyvar ty -extendTyEnvList :: SimplEnv -> [(TyVar,UniType)] -> SimplEnv +extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs = SimplEnv chkr encl_cc new_ty_env id_env unfold_env where new_ty_env = growTyVarEnvList ty_env pairs simplTy (SimplEnv _ _ ty_env _ _) ty = applyTypeEnvToTy ty_env ty - simplTyInId (SimplEnv _ _ ty_env _ _) id = applyTypeEnvToId ty_env id \end{code} -@replaceInEnvs@ is used to install saved type and id envs +@replaceInEnvs@ is used to install saved type and id envs when pulling an un-simplified expression out of the environment, which was saved with its environments. \begin{code} nullInEnvs = (nullTyVarEnv, nullIdEnv) :: (InTypeEnv,InIdEnv) --- UNUSED: ---getInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) ---getInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) = (ty_env,id_env) - replaceInEnvs :: SimplEnv -> (InTypeEnv,InIdEnv) -> SimplEnv -replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) + +replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) (new_ty_env, new_id_env) - = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env + = SimplEnv chkr encl_cc new_ty_env new_id_env unfold_env \end{code} %************************************************************************ @@ -709,16 +522,16 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) \begin{code} extendIdEnvWithAtom :: SimplEnv - -> InBinder -> OutAtom + -> InBinder -> OutArg -> SimplEnv -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(CoLitAtom lit) +extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit) = SimplEnv chkr encl_cc ty_env new_id_env unfold_env where new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id, occ_info) atom@(CoVarAtom out_id) + (in_id, occ_info) atom@(VarArg out_id) = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env where new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) @@ -735,7 +548,7 @@ extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) extendIdEnvWithAtomList :: SimplEnv - -> [(InBinder, OutAtom)] + -> [(InBinder, OutArg)] -> SimplEnv extendIdEnvWithAtomList = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) @@ -746,9 +559,9 @@ extendIdEnvWithInlining -> InBinder -> InExpr -> SimplEnv -extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env) - ~(SimplEnv _ _ inline_ty_env inline_id_env _ ) - (in_id,occ_info) +extendIdEnvWithInlining (SimplEnv chkr encl_cc ty_env id_env unfold_env) + ~(SimplEnv _ _ inline_ty_env inline_id_env _ ) + (in_id,occ_info) expr = SimplEnv chkr encl_cc ty_env new_id_env unfold_env where @@ -761,10 +574,10 @@ extendIdEnvWithClone -> SimplEnv extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id,_) out_id + (in_id,_) out_id = SimplEnv chkr encl_cc ty_env new_id_env unfold_env where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (CoVarAtom out_id)) + new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom (VarArg out_id)) extendIdEnvWithClones -- Like extendIdEnvWithClone :: SimplEnv @@ -778,7 +591,7 @@ extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env) where new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals) in_ids = [id | (id,_) <- in_binders] - out_vals = [ItsAnAtom (CoVarAtom out_id) | out_id <- out_ids] + out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids] lookupId :: SimplEnv -> Id -> Maybe IdVal @@ -824,15 +637,15 @@ extendUnfoldEnvGivenConstructor -- specialised variant extendUnfoldEnvGivenConstructor env var con args = let -- conjure up the types to which the con should be applied - scrut_ty = getIdUniType var - (_, ty_args, _) = getUniDataTyCon scrut_ty + scrut_ty = idType var + (_, ty_args, _) = getAppDataTyCon scrut_ty in extendUnfoldEnvGivenFormDetails - env var (ConstructorForm con ty_args (map CoVarAtom args)) + env var (ConForm con (map VarArg args)) \end{code} -@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS +@extendUnfoldEnvGivenRhs@ records in the UnfoldEnv info about the RHS of a new binding. There is a horrid case we have to take care about, due to Andr\'e Santos: @ @@ -843,20 +656,20 @@ due to Andr\'e Santos: tabulate f (l,u) = listArray (l,u) [f i | i <- [l..u]]; f_iaamain a_xs= - let { - f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1; - f_aareorder a_index a_ar= - let { - f_aareorder' a_i= a_ar ! (a_index ! a_i) - } in tabulate f_aareorder' (bounds a_ar); - r_index=tabulate ((+) 1) (1,1); + let { + f_aareorder::(Array_type Int) -> (Array_type t1) -> Array_type t1; + f_aareorder a_index a_ar= + let { + f_aareorder' a_i= a_ar ! (a_index ! a_i) + } in tabulate f_aareorder' (bounds a_ar); + r_index=tabulate ((+) 1) (1,1); arr = listArray (1,1) a_xs; arg = f_aareorder r_index arr - } in elems arg + } in elems arg @ Now, when the RHS of arg gets simplified, we inline f_aareorder to get @ - arg = let f_aareorder' a_i = arr ! (r_index ! a_i) + arg = let f_aareorder' a_i = arr ! (r_index ! a_i) in tabulate f_aareorder' (bounds arr) @ Note that r_index is not inlined, because it was bound to a_index which @@ -891,11 +704,11 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) -- Compute unfolding details details = case rhs of - CoVar v -> panic "CoVars already dealt with" - CoLit lit | isNoRepLit lit -> LiteralForm lit - | otherwise -> panic "non-noRep CoLits already dealt with" + Var v -> panic "Vars already dealt with" + Lit lit | isNoRepLit lit -> LitForm lit + | otherwise -> panic "non-noRep Lits already dealt with" - CoCon con tys args -> ConstructorForm con tys args + Con con args -> ConForm con args other -> mkGenForm ok_to_dup occ_info (mkFormSummary (getIdStrictness out_id) rhs) @@ -904,7 +717,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) -- Compute resulting unfold env new_unfold_env = case details of NoUnfoldingDetails -> unfold_env - GeneralForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -} + GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -} other -> unfold_env1 -- Add unfolding to unfold env @@ -929,7 +742,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) Nothing -> uNFOLDING_CREATION_THRESHOLD Just xx -> xx - ok_to_dup = switchIsOn chkr SimplOkToDupCode + ok_to_dup = switchIsOn chkr SimplOkToDupCode || exprSmallEnoughToDup rhs -- [Andy] added, Jun 95 @@ -948,36 +761,15 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) -- False -> g x -} {- OLD: - Omitted SLPJ Feb 95; should, I claim, be unnecessary + Omitted SLPJ Feb 95; should, I claim, be unnecessary -- is_really_small looks for things like f a b c -- but making sure there are not *too* many arguments. -- (This is brought to you by *ANDY* Magic Constants, Inc.) is_really_small = case collectArgs new_rhs of - (CoVar _, xs) -> length xs < 10 + (Var _, _, _, xs) -> length xs < 10 _ -> False -} - - -{- UNUSED: -extendUnfoldEnvWithRecInlinings :: SimplEnv -> [OutId] -> [InExpr] -> SimplEnv - -extendUnfoldEnvWithRecInlinings env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) - new_ids old_rhss - = SimplEnv chkr encl_cc ty_env id_env new_unfold_env - where - extra_unfold_items - = [ (new_id, UnfoldItem new_id - (GeneralForm True - (mkFormSummary (getIdStrictness new_id) old_rhs) - old_rhs UnfoldAlways) - encl_cc) - | (new_id, old_rhs) <- new_ids `zipEqual` old_rhss, - simplIdWantsToBeINLINEd new_id env - ] - - new_unfold_env = addto_unfold_env unfold_env extra_unfold_items --} \end{code} \begin{code} @@ -987,12 +779,12 @@ lookupUnfolding (SimplEnv _ _ _ _ unfold_env) var | not (isLocallyDefined var) -- Imported, so look inside the id = getIdUnfolding var - | otherwise -- Locally defined, so look in the envt. + | otherwise -- Locally defined, so look in the envt. -- There'll be nothing inside the Id. = lookup_unfold_env unfold_env var \end{code} -We need to remove any @GeneralForm@ bindings from the UnfoldEnv for +We need to remove any @GenForm@ bindings from the UnfoldEnv for the RHS of an Id which has an INLINE pragma. \begin{code} @@ -1006,26 +798,26 @@ filterUnfoldEnvForInlines env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) -- be inlined wherever they are used, and then all the -- UnfoldEnv stuff will take effect. Meanwhile, there isn't -- much point in doing anything to the as-yet-un-INLINEd rhs. - + -- Andy disagrees! Example: -- all xs = foldr (&&) True xs -- any p = all . map p {-# INLINE any #-} - -- - -- Problem: any won't get deforested, and so if it's exported and + -- + -- Problem: any won't get deforested, and so if it's exported and -- the importer doesn't use the inlining, (eg passes it as an arg) -- then we won't get deforestation at all. - -- + -- -- So he'd like not to filter the unfold env at all. But that's a disaster: -- Suppose we have: -- -- let f = \pq -> BIG - -- in + -- in -- let g = \y -> f y y -- {-# INLINE g #-} -- in ...g...g...g...g...g... - -- + -- -- Now, if that's the ONLY occurrence of f, it will be inlined inside g, - -- and thence copied multiple times when g is inlined. + -- and thence copied multiple times when g is inlined. \end{code} ====================== @@ -1035,9 +827,9 @@ for nullary constructors: \begin{verbatim} = -- Don't re-use nullary constructors; it's a waste. Consider - -- let + -- let -- a = leInt#! p q - -- in + -- in -- case a of -- True -> ... -- False -> False @@ -1051,6 +843,6 @@ but now we only do constructor re-use in let-bindings the special case isn't necessary any more. \begin{code} -lookForConstructor (SimplEnv _ _ _ _ unfold_env) con ty_args con_args - = lookup_conapp unfold_env con ty_args con_args +lookForConstructor (SimplEnv _ _ _ _ unfold_env) con args + = lookup_conapp unfold_env con args \end{code}