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}
%************************************************************************
= 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]
]
-- 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
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
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}
%************************************************************************
\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
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]
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
= 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}
= 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
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
projects / ghc-hetmet.git / blobdiff