X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=ba098eab38f6ec900302a95855d6a36d3e4ee723;hb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;hp=6712d6a55bed17d3ff67dca79ea7e0bddd5577e1;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 6712d6a..ba098ea 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -41,8 +41,6 @@ module SimplEnv ( InExpr(..), InAlts(..), InDefault(..), InArg(..), OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) - - -- and to make the interface self-sufficient... ) where import Ubiq{-uitous-} @@ -50,48 +48,45 @@ import Ubiq{-uitous-} import SmplLoop -- breaks the MagicUFs / SimplEnv loop import BinderInfo ( BinderInfo{-instances-} ) +import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult ) import CoreSyn import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, calcUnfoldingGuidance, UnfoldingGuidance(..), mkFormSummary, FormSummary ) +import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup ) import FiniteMap -- lots of things import Id ( idType, getIdUnfolding, getIdStrictness, + applyTypeEnvToId, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, addOneToIdEnv, modifyIdEnv, IdEnv(..), IdSet(..), GenId ) -import IdInfo ( StrictnessInfo ) +import IdInfo ( bottomIsGuaranteed, StrictnessInfo ) import Literal ( isNoRepLit, Literal{-instances-} ) +import Name ( isLocallyDefined ) +import OccurAnal ( occurAnalyseExpr ) import Outputable ( Outputable(..){-instances-} ) import PprCore -- various instances import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar ) import Pretty -import Type ( getAppDataTyCon ) +import Type ( eqTy, getAppDataTyCon, applyTypeEnvToTy ) import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, growTyVarEnvList, - TyVarEnv(..), GenTyVar ) -import Unique ( Unique ) + TyVarEnv(..), GenTyVar{-instance Eq-} + ) +import Unique ( Unique{-instance Outputable-} ) +import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList ) import UniqSet -- lots of things import Usage ( UVar(..), GenUsage{-instances-} ) -import Util ( zipEqual, panic, assertPanic ) +import Util ( zipEqual, panic, panic#, assertPanic ) type TypeEnv = TyVarEnv Type -addToUFM_Directly = panic "addToUFM_Directly (SimplEnv)" -applyTypeEnvToId = panic "applyTypeEnvToId (SimplEnv)" -applyTypeEnvToTy = panic "applyTypeEnvToTy (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} %************************************************************************ @@ -257,7 +252,7 @@ data UnfoldItem -- a glorified triple... -- we can "wrap" it in the CC -- that was in force. -data UnfoldConApp -- yet another glorified triple +data UnfoldConApp -- yet another glorified pair = UCA OutId -- same fields as ConForm [OutArg] @@ -303,7 +298,7 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id -- 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 @@ -313,12 +308,12 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc where new_con_apps = case uf_details of - ConForm con vargs + ConForm con args -> 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 vargs + entry = UCA con args not_a_constructor -> con_apps -- unchanged @@ -382,7 +377,7 @@ cmp_app (UCA c1 as1) (UCA c2 as2) = case (c1 `cmp` c2) of LT_ -> LT_ GT_ -> GT_ - _ -> cmp_lists cmp_atom as1 as2 + _ -> cmp_lists cmp_arg as1 as2 where cmp_lists cmp_item [] [] = EQ_ cmp_lists cmp_item (x:xs) [] = GT_ @@ -390,11 +385,20 @@ cmp_app (UCA c1 as1) (UCA c2 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 (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_ } - cmp_atom (LitArg _) _ = GT_ + -- ToDo: make an "instance Ord3 CoreArg"??? + + cmp_arg (VarArg x) (VarArg y) = x `cmp` y + cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } + cmp_arg (TyArg x) (TyArg y) = if x `eqTy` y then EQ_ else panic# "SimplEnv.cmp_app:TyArgs" + cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" + cmp_arg x y + | tag x _LT_ tag y = LT_ + | otherwise = GT_ + where + tag (VarArg _) = ILIT(1) + tag (LitArg _) = ILIT(2) + tag (TyArg _) = ILIT(3) + tag (UsageArg _) = ILIT(4) \end{code} %************************************************************************ @@ -496,7 +500,6 @@ extendTyEnvList (SimplEnv chkr encl_cc ty_env id_env unfold_env) pairs 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} @@ -523,7 +526,7 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env) \begin{code} extendIdEnvWithAtom :: SimplEnv - -> InBinder -> OutArg + -> InBinder -> OutArg{-Val args only, please-} -> SimplEnv extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit) @@ -547,6 +550,10 @@ extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) ok_to_dup = switchIsOn chkr SimplOkToDupCode +#ifdef DEBUG +extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!" +#endif + extendIdEnvWithAtomList :: SimplEnv -> [(InBinder, OutArg)] @@ -730,7 +737,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem modify (u, occ_info) env - = case (lookupDirectlyUFM env u) of + = case (lookupUFM_Directly env u) of Nothing -> env -- ToDo: can this happen? Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx) @@ -768,7 +775,7 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) -- (This is brought to you by *ANDY* Magic Constants, Inc.) is_really_small = case collectArgs new_rhs of - (Var _, xs) -> length xs < 10 + (Var _, _, _, xs) -> length xs < 10 _ -> False -} \end{code}