InExpr(..), InAlts(..), InDefault(..), InArg(..),
OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..)
-
- -- and to make the interface self-sufficient...
) where
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}
%************************************************************************
-- 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]
-- 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
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
= 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_
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}
%************************************************************************
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}
\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)
ok_to_dup = switchIsOn chkr SimplOkToDupCode
+#ifdef DEBUG
+extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
+#endif
+
extendIdEnvWithAtomList
:: SimplEnv
-> [(InBinder, OutArg)]
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)
-- (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}
projects / ghc-hetmet.git / blobdiff