module SimplCase ( simplCase, bindLargeRhs ) where
-import Ubiq{-uitous-}
-import SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
- FormSummary(..)
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ SimpleUnfolding, FormSummary
)
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts
)
import Id ( idType, isDataCon, getIdDemandInfo,
- DataCon(..), GenId{-instance Eq-}
+ SYN_IE(DataCon), GenId{-instance Eq-}
)
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit, Literal{-instance Eq-} )
import Maybes ( maybeToBool )
-import PrelVals ( voidPrimId )
+import PrelVals ( voidId )
import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
import SimplEnv
import SimplMonad
import SimplUtils ( mkValLamTryingEta )
-import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
-import TysPrim ( voidPrimTy )
+import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
+import TysPrim ( voidTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
-- Eliminate unused rhss if poss
rhss = case scrut_form of
- OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
- not (alt_lit `is_elem` not_these)
- ]
+ OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
+ not (alt_lit `is_elem` not_these)
+ ]
other -> [rhs | (_,rhs) <- alts]
AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
-- Eliminate unused alts if poss
possible_alts = case scrut_form of
- OtherConForm not_these ->
+ OtherCon not_these ->
-- Remove alts which can't match
[alt | alt@(alt_con,_,_) <- alts,
not (alt_con `is_elem` not_these)]
-#ifdef DEBUG
--- ConForm c v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppStr "<args>"]) (ppr PprDebug alts))
- -- ConForm can't happen, since we'd have
- -- inlined it, and be in completeCaseWithKnownCon by now
-#endif
other -> alts
alt_binders_unused (con, args, rhs) = all is_dead args
-- If the scrutinee is a variable, look it up to see what we know about it
scrut_form = case scrut of
- Var v -> lookupUnfolding env v
- other -> NoUnfoldingDetails
+ Var v -> lookupRhsInfo env v
+ other -> NoRhsInfo
-- If the scrut is already eval'd then there's no worry about
-- eliminating the case
- scrut_is_evald = case scrut_form of
- OtherLitForm _ -> True
- ConForm _ _ -> True
- OtherConForm _ -> True
- other -> False
-
+ scrut_is_evald = isEvaluated scrut_form
scrut_is_eliminable_primitive
= case scrut of
rhs1_is_scrutinee = case (scrut, rhs1) of
(Var scrut_var, Var rhs_var)
-> case lookupId env rhs_var of
- Just (ItsAnAtom (VarArg rhs_var'))
- -> rhs_var' == scrut_var
- other -> False
+ VarArg rhs_var' -> rhs_var' == scrut_var
+ other -> False
other -> False
is_elem x ys = isIn "completeCase" x ys
\begin{code}
completeCase env scrut alts rhs_c
= simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
- mkCoCase scrut alts'
+ mkCoCase env scrut alts'
\end{code}
-- for let-binding-purposes, we will *caseify* it (!),
-- with potentially-disastrous strictness results. So
-- instead we turn it into a function: \v -> e
- -- where v::VoidPrim. Since arguments of type
+ -- where v::Void. Since arguments of type
-- VoidPrim don't generate any code, this gives the
-- desired effect.
--
-- The general structure is just the same as for the common "otherwise~ case
= newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
- newId voidPrimTy `thenSmpl` \ void_arg_id ->
+ newId voidTy `thenSmpl` \ void_arg_id ->
rhs_c env `thenSmpl` \ prim_new_body ->
returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
- App (Var prim_rhs_fun_id) (VarArg voidPrimId))
+ App (Var prim_rhs_fun_id) (VarArg voidId))
| otherwise
= -- Make the new binding Id. NB: it's an OutId
dead DeadCode = True
dead other = False
- prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty
+ prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
\end{code}
Case alternatives when we don't know the scrutinee
simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
returnSmpl (AlgAlts alts' deflt')
where
- deflt_form = OtherConForm [con | (con,_,_) <- alts]
+ deflt_form = OtherCon [con | (con,_,_) <- alts]
do_alt (con, con_args, rhs)
= cloneIds env con_args `thenSmpl` \ con_args' ->
let
env1 = extendIdEnvWithClones env con_args con_args'
new_env = case scrut of
- Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args'
+ Var v -> extendEnvGivenNewRhs env1 v (Con con args)
+ where
+ (_, ty_args, _) = --trace "SimplCase.getAppData..." $
+ getAppDataTyConExpandingDicts (idType v)
+ args = map TyArg ty_args ++ map VarArg con_args'
+
other -> env1
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
returnSmpl (PrimAlts alts' deflt')
where
- deflt_form = OtherLitForm [lit | (lit,_) <- alts]
+ deflt_form = OtherLit [lit | (lit,_) <- alts]
do_alt (lit, rhs)
= let
new_env = case scrut of
- Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit)
+ Var v -> extendEnvGivenNewRhs env v (Lit lit)
other -> env
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
:: SimplEnv
-> OutExpr -- Simplified scrutinee
-> InDefault -- Default alternative to be completed
- -> UnfoldingDetails -- Gives form of scrutinee
+ -> RhsInfo -- Gives form of scrutinee
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
-> SmplM OutDefault
= returnSmpl NoDefault
-- Special case for variable scrutinee; see notes above.
-simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
+simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
+ info_from_this_case rhs_c
= cloneId env binder `thenSmpl` \ binder' ->
let
- env1 = extendIdEnvWithAtom env binder (VarArg binder')
+ env1 = extendIdEnvWithClone env binder binder'
+ env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
-- Add form details for the default binder
- scrut_form = lookupUnfolding env scrut_var
- final_form
- = case (form_from_this_case, scrut_form) of
- (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
- (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
- -- ConForm, LitForm impossible
- -- (ASSERT? ASSERT? Hello? WDP 95/05)
- other -> form_from_this_case
-
- env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
-
- -- Change unfold details for scrut var. We now want to unfold it
- -- to binder'
- new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
- (Var binder') UnfoldAlways
- new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
-
+ scrut_info = lookupRhsInfo env scrut_var
+ env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
+ new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
-simplDefault env scrut (BindDefault binder rhs) form rhs_c
+simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
+ info_from_this_case rhs_c
= cloneId env binder `thenSmpl` \ binder' ->
let
- env1 = extendIdEnvWithAtom env binder (VarArg binder')
- new_env = extendUnfoldEnvGivenFormDetails env1 binder' form
+ env1 = extendIdEnvWithClone env binder binder'
+ new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
| alt_con == con
= -- Matching alternative!
let
- new_env = extendIdEnvWithAtomList env (zipEqual "SimplCase" alt_args (filter isValArg con_args))
+ new_env = extendIdEnvWithAtoms env
+ (zipEqual "SimplCase" alt_args (filter isValArg con_args))
in
rhs_c new_env rhs
NoDefault -> -- Blargh!
panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
- BindDefault binder rhs -> -- OK, there's a default case
+ BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
-- let-bind the binder to the constructor
cloneId env binder `thenSmpl` \ id' ->
let
env1 = extendIdEnvWithClone env binder id'
- new_env = extendUnfoldEnvGivenFormDetails env1 id'
- (ConForm con con_args)
+ new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
+mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
\end{code}
@mkCoCase@ tries the following transformation (if possible):
equation for AlgAlts, one for PrimAlts):
\begin{code}
-mkCoCase scrut (AlgAlts outer_alts
+mkCoCase env scrut (AlgAlts outer_alts
(BindDefault deflt_var
(Case (Var scrut_var')
(AlgAlts inner_alts inner_deflt))))
- | (scrut_is_var && scrut_var == scrut_var') -- First transformation
- || deflt_var == scrut_var' -- Second transformation
+ | switchIsSet env SimplCaseMerge &&
+ ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
+ deflt_var == scrut_var') -- Second transformation
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
v | scrut_is_var = Var scrut_var
| otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
- arg_tys = case (maybeAppDataTyConExpandingDicts (idType deflt_var)) of
- Just (_, arg_tys, _) -> arg_tys
+ arg_tys = --trace "SimplCase:getAppData...:2" $
+ case (getAppDataTyConExpandingDicts (idType deflt_var)) of
+ (_, arg_tys, _) -> arg_tys
-mkCoCase scrut (PrimAlts
+mkCoCase env scrut (PrimAlts
outer_alts
(BindDefault deflt_var (Case
(Var scrut_var')
(PrimAlts inner_alts inner_deflt))))
- | (scrut_is_var && scrut_var == scrut_var') ||
- deflt_var == scrut_var'
+ | switchIsSet env SimplCaseMerge &&
+ ((scrut_is_var && scrut_var == scrut_var') ||
+ deflt_var == scrut_var')
= -- Aha! The default-absorption rule applies
tick CaseMerge `thenSmpl_`
returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
and similar friends.
\begin{code}
-mkCoCase scrut alts
+mkCoCase env scrut alts
| identity_alts alts
= tick CaseIdentity `thenSmpl_`
returnSmpl scrut
The catch-all case
\begin{code}
-mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
+mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
\end{code}
Boring local functions used above. They simply introduce a trivial binding
projects / ghc-hetmet.git / blobdiff