X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplEnv.lhs;h=7cd952426bde3e30675e192bfbac068b9d6afb42;hb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;hp=ee87e0ae919466000cb3a4d63487d5bd8c9266cb;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index ee87e0a..7cd9524 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -41,57 +41,54 @@ module SimplEnv ( InExpr(..), InAlts(..), InDefault(..), InArg(..), OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) - - -- and to make the interface self-sufficient... ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import SmplLoop -- breaks the MagicUFs / SimplEnv loop +IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop -import BinderInfo ( BinderInfo{-instances-} ) +import BinderInfo ( orBinderInfo, oneSafeOcc, + BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC + ) +import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, +import CoreUnfold ( UnfoldingDetails(..), mkGenForm, mkConForm, calcUnfoldingGuidance, UnfoldingGuidance(..), - mkFormSummary, FormSummary + mkFormSummary, FormSummary(..) ) +import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup ) import FiniteMap -- lots of things import Id ( idType, getIdUnfolding, getIdStrictness, applyTypeEnvToId, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, + addOneToIdEnv, modifyIdEnv, mkIdSet, IdEnv(..), IdSet(..), GenId ) -import IdInfo ( StrictnessInfo ) +import IdInfo ( bottomIsGuaranteed, StrictnessInfo ) import Literal ( isNoRepLit, Literal{-instances-} ) +import Maybes ( maybeToBool ) +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, applyTypeEnvToTy ) +import Type ( eqTy, getAppDataTyConExpandingDicts, applyTypeEnvToTy ) import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, growTyVarEnvList, TyVarEnv(..), GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Outputable-} ) -import UniqSet -- lots of things +import UniqFM ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly, + delFromUFM, ufmToList + ) +--import UniqSet -- lots of things import Usage ( UVar(..), GenUsage{-instances-} ) -import Util ( zipEqual, panic, assertPanic ) +import Util ( zipEqual, thenCmp, cmpList, panic, 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} %************************************************************************ @@ -176,13 +173,11 @@ pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _)) = ppCat [ppr PprDebug v, ppStr "=>", case form of 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, + GenForm w e g -> ppCat [ppStr "UF:", ppr PprDebug w, ppr PprDebug g, ppr PprDebug e] MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s] ] @@ -257,26 +252,38 @@ data UnfoldItem -- a glorified triple... -- we can "wrap" it in the CC -- that was in force. -data UnfoldConApp -- yet another glorified triple - = UCA OutId -- same fields as ConForm - [OutArg] +data UnfoldConApp -- yet another glorified pair + = UCA OutId -- data constructor + [OutArg] -- *value* arguments; see use below 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 (GenForm True ...) - -- i.e., they claim they are duplicatable. - -- These are the ones we have to worry - -- about when adding new items to the - -- unfold env. - (FiniteMap UnfoldConApp OutId) + + (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all) + -- in-scope ids. The "Id" part is just so that + -- we can recover the domain of the mapping, which + -- IdEnvs don't allow directly. + -- + -- Anything that isn't in here + -- should be assumed to occur many times. + -- The things in here all occur once, and the + -- binder-info tells about whether that "once" + -- is inside a lambda, or perhaps once in each branch + -- of a case etc. + -- We keep this info so we can modify it when + -- something changes. + + (FiniteMap UnfoldConApp [([Type], OutId)]) -- Maps applications of constructors (to - -- types & atoms) back to OutIds that are - -- bound to them; i.e., this is a reversed + -- value atoms) back to an association list + -- that says "if the constructor was applied + -- to one of these lists-of-Types, then + -- this OutId is your man (in a non-gender-specific + -- sense)". I.e., this is a reversed -- mapping for (part of) the main IdEnv -- (1st part of UFE) -null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM +null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM \end{code} The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will @@ -291,51 +298,40 @@ things silently grow quite big.... Here are some local functions used elsewhere in the module: \begin{code} -grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv +grow_unfold_env :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails lookup_unfold_env_encl_cc :: UnfoldEnv -> OutId -> EnclosingCcDetails -grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env - -grow_unfold_env (UFE u_env interesting_ids con_apps) id - 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)) - (addOneToUniqSet interesting_ids id) - con_apps +grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env -grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc +grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - interesting_ids + new_occ_env new_con_apps where + new_occ_env = modify_occ_info occ_env id occ_info + new_con_apps = case uf_details of - 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 vargs - + GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id) not_a_constructor -> con_apps -- unchanged -addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items +addto_unfold_env (UFE u_env occ_env con_apps) extra_items = ASSERT(not (any constructor_form_in_those extra_items)) -- otherwise, we'd need to change con_apps - UFE (growIdEnvList u_env extra_items) interesting_ids con_apps + UFE (growIdEnvList u_env extra_items) occ_env con_apps where - constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True + constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True constructor_form_in_those _ = False rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env -get_interesting_ids (UFE _ interesting_ids _) = interesting_ids +get_interesting_ids (UFE _ occ_env _) + = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ] -foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff - = UFE (foldr fun u_env stuff) interesting_ids con_apps +foldr_occ_env fun (UFE u_env occ_env con_apps) stuff + = UFE u_env (foldr fun occ_env stuff) con_apps lookup_unfold_env (UFE u_env _ _) id = case (lookupIdEnv u_env id) of @@ -348,53 +344,76 @@ lookup_unfold_env_encl_cc (UFE u_env _ _) id Just (UnfoldItem _ _ encl_cc) -> encl_cc lookup_conapp (UFE _ _ con_apps) con args - = lookupFM con_apps (UCA con args) + = fst (lookup_conapp_help con_apps con args (panic "lookup_conapp")) + +-- Returns two things; we just fst or snd the one we want: +lookup_conapp_help con_apps con args outid + = case (span notValArg args) of { (ty_args, val_args) -> + let + entry = UCA con val_args + arg_tys = [ t | TyArg t <- ty_args ] + in + case (lookupFM con_apps entry) of + Nothing -> (Nothing, + addToFM con_apps entry [(arg_tys, outid)]) + Just assocs + -> ASSERT(not (null assocs)) + case [ oid | (ts,oid) <- assocs, ts `eq_tys` arg_tys ] of + [o] -> (Just o, + con_apps) -- unchanged; we hang onto what we have + [] -> (Nothing, + addToFM con_apps entry ((arg_tys, outid) : assocs)) + _ -> panic "grow_unfold_env:dup in assoc list" + } + where + eq_tys ts1 ts2 + = case (cmpList cmp_ty ts1 ts2) of { EQ_ -> True; _ -> False } -modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id - = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps + cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types + = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-} --- If the current binding claims to be a "unique" one, then --- we modify it. -modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem +modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _) + = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id -modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) - = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc +modify_occ_info occ_env id other_new_occ + = -- Many or Dead occurrence, just delete from occ_env + delFromUFM occ_env id \end{code} The main thing about @UnfoldConApp@ is that it has @Ord@ defined on it, so we can use it for a @FiniteMap@ key. \begin{code} instance Eq UnfoldConApp where - a == b = case cmp_app a b of { EQ_ -> True; _ -> False } - a /= b = case cmp_app a b of { EQ_ -> False; _ -> True } + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } instance Ord UnfoldConApp where - a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - 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 } - _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } instance Ord3 UnfoldConApp where cmp = cmp_app cmp_app (UCA c1 as1) (UCA c2 as2) - = case (c1 `cmp` c2) of - LT_ -> LT_ - GT_ -> GT_ - _ -> cmp_lists cmp_atom as1 as2 + = cmp c1 c2 `thenCmp` cmpList cmp_arg as1 as2 where - cmp_lists cmp_item [] [] = EQ_ - cmp_lists cmp_item (x:xs) [] = GT_ - cmp_lists cmp_item [] (y:ys) = LT_ - 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) = x `cmp` y + cmp_arg (TyArg x) (TyArg y) = 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 _) = panic# "SimplEnv.cmp_app:TyArg" + tag (UsageArg _) = panic# "SimplEnv.cmp_app:UsageArg" \end{code} %************************************************************************ @@ -522,29 +541,26 @@ 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) +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@(VarArg out_id) +extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps)) + (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) + new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) + new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps + -- Modify occ info for out_id - new_unfold_env = modify_unfold_env - unfold_env - (modifyItem ok_to_dup occ_info) - out_id - -- Modify binding for in_id - -- NO! modify out_id, because its the info on the - -- atom that interest's us. - - ok_to_dup = switchIsOn chkr SimplOkToDupCode +#ifdef DEBUG +extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!" +#endif extendIdEnvWithAtomList :: SimplEnv @@ -589,7 +605,7 @@ extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env id_env unfold_env) in_binders out_ids = SimplEnv chkr encl_cc ty_env new_id_env unfold_env where - new_id_env = growIdEnvList id_env (in_ids `zipEqual` out_vals) + new_id_env = growIdEnvList id_env (zipEqual "extendIdEnvWithClones" in_ids out_vals) in_ids = [id | (id,_) <- in_binders] out_vals = [ItsAnAtom (VarArg out_id) | out_id <- out_ids] @@ -626,7 +642,8 @@ extendUnfoldEnvGivenFormDetails NoUnfoldingDetails -> env good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env where - new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc + new_unfold_env = grow_unfold_env unfold_env id fake_occ_info good_details encl_cc + fake_occ_info = {-ToDo!-} ManyOcc 0 -- generally paranoid extendUnfoldEnvGivenConstructor -- specialised variant :: SimplEnv @@ -638,10 +655,10 @@ extendUnfoldEnvGivenConstructor env var con args = let -- conjure up the types to which the con should be applied scrut_ty = idType var - (_, ty_args, _) = getAppDataTyCon scrut_ty + (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty in extendUnfoldEnvGivenFormDetails - env var (ConForm con (map VarArg args)) + env var (mkConForm con (map TyArg ty_args ++ map VarArg args)) \end{code} @@ -698,40 +715,40 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) = SimplEnv chkr encl_cc ty_env id_env new_unfold_env where -- Occurrence-analyse the RHS - (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs + (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs - interesting_fvs = get_interesting_ids unfold_env + interesting_fvs = get_interesting_ids unfold_env -- Ids in dom of OccEnv -- Compute unfolding details - details = case rhs of - Var v -> panic "Vars already dealt with" - Lit lit | isNoRepLit lit -> LitForm lit - | otherwise -> panic "non-noRep Lits already dealt with" - - Con con args -> ConForm con args - - other -> mkGenForm ok_to_dup occ_info - (mkFormSummary (getIdStrictness out_id) rhs) - template guidance + details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs) + template guidance -- Compute resulting unfold env new_unfold_env = case details of - NoUnfoldingDetails -> unfold_env - GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -} - other -> unfold_env1 + NoUnfoldingDetails -> unfold_env + other -> unfold_env1 -- Add unfolding to unfold env - unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc + unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc +{- OLD: done in grow_unfold_env -- Modify unfoldings of free vars of rhs, based on their -- occurrence info in the rhs [see notes above] - unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info) - - modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem - modify (u, occ_info) env - = case (lookupDirectlyUFM env u) of - Nothing -> env -- ToDo: can this happen? - Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx) + unfold_env2 + = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info) + where + modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo) + modify (u, item@(i,occ_info)) env + = if maybeToBool (lookupUFM_Directly env u) then + -- it occurred before, so now it occurs multiple times; + -- therefore, *delete* it from the occ(urs once) env. + delFromUFM_Directly env u + + else if not (oneSafeOcc ok_to_dup occ_info) then + env -- leave it alone + else + addToUFM_Directly env u item +-} -- Compute unfolding guidance guidance = if simplIdWantsToBeINLINEd out_id env @@ -743,8 +760,8 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) Just xx -> xx ok_to_dup = switchIsOn chkr SimplOkToDupCode - || exprSmallEnoughToDup rhs - -- [Andy] added, Jun 95 +--NO: || exprSmallEnoughToDup rhs +-- -- [Andy] added, Jun 95 {- Reinstated AJG Jun 95; This is needed --example that does not (currently) work