%
-% (c) The AQUA Project, Glasgow University, 1994-1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[SimplCase]{Simplification of `case' expression}
Support code for @Simplify@.
\begin{code}
-#include "HsVersions.h"
-
module SimplCase ( simplCase, bindLargeRhs ) where
-import SimplMonad
-import SimplEnv
+#include "HsVersions.h"
-import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp,
- voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
+
+import BinderInfo -- too boring to try to select things...
+import CmdLineOpts ( SimplifierSwitch(..) )
+import CoreSyn
+import CoreUnfold ( Unfolding(..) )
+import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
+ unTagBindersAlts, unTagBinders, coreExprType
)
-import Type ( splitSigmaTy, splitTyArgs, glueTyArgs,
- getTyConFamilySize, isPrimType,
- maybeDataTyCon
+import Id ( idType, isDataCon, getIdDemandInfo, dataConArgTys,
+ DataCon, GenId{-instance Eq-},
+ Id
)
-import Literal ( isNoRepLit, Literal )
-import CmdLineOpts ( SimplifierSwitch(..) )
-import Id
-import IdInfo
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Simplify
-import SimplUtils
-import SimplVar ( completeVar )
-import Util
+import IdInfo ( willBeDemanded, DemandInfo )
+import Literal ( isNoRepLit, Literal{-instance Eq-} )
+import Maybes ( maybeToBool )
+import PrelVals ( voidId )
+import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
+import SimplVar ( simplBinder, simplBinders )
+import SimplUtils ( newId, newIds )
+import SimplEnv
+import SimplMonad
+import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys )
+import TyCon ( isDataTyCon )
+import TysPrim ( voidTy )
+import Util ( Eager, runEager, appEager,
+ isIn, isSingleton, zipEqual, panic, assertPanic )
+import Outputable
\end{code}
-
-
-
-
Float let out of case.
\begin{code}
simplCase :: SimplEnv
- -> InExpr -- Scrutinee
- -> InAlts -- Alternatives
+ -> InExpr -- Scrutinee
+ -> (SubstEnvs, InAlts) -- Alternatives, and their static environment
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> OutUniType -- Type of result expression
+ -> OutType -- Type of result expression
-> SmplM OutExpr
simplCase env (Let bind body) alts rhs_c result_ty
\begin{code}
-simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
+simplCase env (Case inner_scrut inner_alts) (subst_envs, outer_alts) rhs_c result_ty
| switchIsSet env SimplCaseOfCase
= -- Ha! Do case-of-case
tick CaseOfCase `thenSmpl_`
if no_need_to_bind_large_alts
then
- simplCase env inner_scrut inner_alts
- (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
+ simplCase env inner_scrut (getSubstEnvs env, inner_alts)
+ (\env' rhs -> simplCase env' rhs (subst_envs, outer_alts) rhs_c result_ty)
+ result_ty
else
- bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
+ bindLargeAlts env_alts outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
let
- rhs_c' = \env rhs -> simplExpr env rhs []
+ rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
in
- simplCase env inner_scrut inner_alts
- (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
+ simplCase env inner_scrut (getSubstEnvs env, inner_alts)
+ (\env rhs -> simplCase env rhs (emptySubstEnvs, outer_alts') rhs_c' result_ty)
result_ty
`thenSmpl` \ case_expr ->
returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
where
+ env_alts = setSubstEnvs env subst_envs
+
no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
isSingleton (nonErrorRHSs inner_alts)
\end{code}
| maybeToBool maybe_error_app
= -- Look for an application of an error id
tick CaseOfError `thenSmpl_`
- rhs_c env retyped_error_app
+ simplExpr env retyped_error_app [] result_ty
+ -- Ignore rhs_c!
+ -- We must apply simplExpr because "rhs" isn't yet simplified.
+ -- The ice is a little thin because body_ty is an OutType; but it's ok really
where
- alts_ty = coreAltsType (unTagBindersAlts alts)
- maybe_error_app = maybeErrorApp scrut (Just alts_ty)
+ maybe_error_app = maybeErrorApp scrut (Just result_ty)
Just retyped_error_app = maybe_error_app
\end{code}
Finally the default case
\begin{code}
-simplCase env other_scrut alts rhs_c result_ty
- = -- Float the let outside the case scrutinee
- simplExpr env other_scrut [] `thenSmpl` \ scrut' ->
- completeCase env scrut' alts rhs_c
+simplCase env other_scrut (subst_envs, alts) rhs_c result_ty
+ = simplTy env scrut_ty `appEager` \ scrut_ty' ->
+ simplExpr env_scrut other_scrut [] scrut_ty' `thenSmpl` \ scrut' ->
+ completeCase env_alts scrut' alts rhs_c
+ where
+ -- When simplifying the scrutinee of a complete case that
+ -- has no default alternative
+ env_scrut = case alts of
+ AlgAlts _ NoDefault -> setCaseScrutinee env
+ PrimAlts _ NoDefault -> setCaseScrutinee env
+ other -> env
+
+ env_alts = setSubstEnvs env subst_envs
+
+ scrut_ty = coreExprType (unTagBinders other_scrut)
\end{code}
tick KnownBranch `thenSmpl_`
completePrimCaseWithKnownLit env lit alts rhs_c
-completeCase env expr@(Con con tys con_args) alts rhs_c
+completeCase env expr@(Con con con_args) alts rhs_c
= -- Ha! Staring us in the face -- select the appropriate alternative
tick KnownBranch `thenSmpl_`
- completeAlgCaseWithKnownCon env con tys con_args alts rhs_c
+ completeAlgCaseWithKnownCon env con con_args alts rhs_c
\end{code}
Case elimination
-- 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 t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (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
+ other -> NoUnfolding
-- 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
- Prim op _ _ -> primOpOkForSpeculation op
- Var _ -> case alts of
- PrimAlts _ _ -> True -- Primitive, hence non-bottom
- AlgAlts _ _ -> False -- Not primitive
- other -> False
+ Prim op _ -> primOpOkForSpeculation op
+ Var _ -> case alts of
+ PrimAlts _ _ -> True -- Primitive, hence non-bottom
+ AlgAlts _ _ -> False -- Not primitive
+ other -> False
-- case v of w -> e{strict in w} ===> e[v/w]
scrut_is_var_and_single_strict_default
elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
= case scrut of
Var v -> -- Binder used, but can be eliminated in favour of scrut
- (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
+ (True, [rhs], bindIdToAtom env used_binder (VarArg v))
non_var -> -- Binder used, and can't be elimd
(False, [rhs], env)
-- the scrutinee. Remember that the rhs is as yet unsimplified.
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
+ -> case (lookupIdSubst env rhs_var) of
+ Nothing -> rhs_var == scrut_var
+ Just (SubstVar 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}
bindLargeAlts :: SimplEnv
-> InAlts
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
- -> OutUniType -- Result type
+ -> OutType -- Result type
-> SmplM ([OutBinding], -- Extra bindings
InAlts) -- Modified alts
\begin{code}
bindLargeRhs :: SimplEnv
-> [InBinder] -- The args wrt which the rhs should be abstracted
- -> OutUniType
+ -> OutType
-> (SimplEnv -> SmplM OutExpr) -- Rhs handler
-> SmplM (OutBinding, -- New bindings (singleton or empty)
InExpr) -- Modified rhs
bindLargeRhs env args rhs_ty rhs_c
- | null used_args && isPrimType rhs_ty
+ | null used_args && isUnpointedType rhs_ty
-- If we try to lift a primitive-typed something out
-- 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
- newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
-
- -- Generate its rhs
- cloneIds env used_args `thenSmpl` \ used_args' ->
+ = -- Generate the rhs
+ simplBinders env used_args `thenSmpl` \ (new_env, used_args') ->
let
- new_env = extendIdEnvWithClones env used_args used_args'
+ rhs_fun_ty :: OutType
+ rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
in
+
+ -- Make the new binding Id. NB: it's an OutId
+ newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
rhs_c new_env `thenSmpl` \ rhs' ->
let
- final_rhs
- = (if switchIsSet new_env SimplDoEtaReduction
- then mkCoLamTryingEta
- else mkValLam) used_args' rhs'
+ final_rhs = mkValLam used_args' rhs'
in
returnSmpl (NonRec rhs_fun_id final_rhs,
foldl App (Var rhs_fun_id) used_arg_atoms)
-- it's processed the OutId won't be found in the environment, so it
-- will be left unmodified.
where
- rhs_fun_ty :: OutUniType
- rhs_fun_ty = glueTyArgs [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
dead DeadCode = True
dead other = False
- prim_rhs_fun_ty = mkFunTy voidPrimTy rhs_ty
+ prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
\end{code}
Case alternatives when we don't know the scrutinee
-> InAlts
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutAlts
+-- For single-constructor types
+-- case e of y -> b ===> case e of (a,b) -> let y = (a,b) in b
+
+simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
+ | maybeToBool maybe_data_ty &&
+ not (null cons) && -- Not an abstract type (can arise if we're pruning tydecl imports)
+ null other_cons &&
+ isDataTyCon tycon -- doesn't apply to (constructor-less) newtypes
+ = newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
+ let
+ new_args = [ (b, bad_occ_info) | b <- new_bindees ]
+ con_app = mkCon con ty_args (map VarArg new_bindees)
+ new_rhs = Let (NonRec bndr con_app) rhs
+ in
+ simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
+ where
+ maybe_data_ty = splitAlgTyConApp_maybe (idType id)
+ Just (tycon, ty_args, cons) = maybe_data_ty
+ (con:other_cons) = cons
+ inst_con_arg_tys = dataConArgTys con ty_args
+ bad_occ_info = ManyOcc 0 -- Non-committal!
simplAlts env scrut (AlgAlts alts deflt) rhs_c
= mapSmpl do_alt alts `thenSmpl` \ alts' ->
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' ->
+ = simplBinders env con_args `thenSmpl` \ (env1, con_args') ->
let
- env1 = extendIdEnvWithClones env con_args con_args'
new_env = case scrut of
- Var var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args')
- other -> env1
+ Var v -> extendEnvGivenNewRhs env1 v (Con con args)
+ where
+ (_, ty_args, _) = splitAlgTyConApp (idType v)
+ args = map TyArg ty_args ++ map VarArg con_args'
+
+ other -> env1
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (con, con_args', 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 var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LitForm lit))
- other -> env
+ Var v -> extendEnvGivenNewRhs env v (Lit lit)
+ other -> env
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (lit, rhs')
:: SimplEnv
-> OutExpr -- Simplified scrutinee
-> InDefault -- Default alternative to be completed
- -> UnfoldingDetails -- Gives form of scrutinee
+ -> Unfolding -- 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
- = cloneId env binder `thenSmpl` \ binder' ->
+simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
+ info_from_this_case rhs_c
+ = simplBinder env binder `thenSmpl` \ (env1, binder') ->
let
- env1 = extendIdEnvWithAtom env binder (VarArg binder')
+ env2 = extendEnvGivenNewRhs env1 scrut_var (Var binder')
-- 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 = _scc_ "euegFD2" (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_unf = lookupUnfolding env scrut_var
+ new_env = extendEnvGivenUnfolding env2 binder' noBinderInfo scrut_unf
+ -- Use noBinderInfo rather than occ_info because we've
+ -- added more occurrences by binding the scrut_var to it
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
-simplDefault env scrut (BindDefault binder rhs) form rhs_c
- = cloneId env binder `thenSmpl` \ binder' ->
+simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
+ info_from_this_case rhs_c
+ = simplBinder env binder `thenSmpl` \ (env1, binder') ->
let
- env1 = extendIdEnvWithAtom env binder (VarArg binder')
- new_env = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' form)
+ new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
BindDefault binder rhs -> -- OK, there's a default case
-- Just bind the Id to the atom and continue
let
- new_env = extendIdEnvWithAtom env binder (LitArg lit)
+ new_env = bindIdToAtom env binder (LitArg lit)
in
rhs_c new_env rhs
\end{code}
\begin{code}
completeAlgCaseWithKnownCon
:: SimplEnv
- -> DataCon -> [Type] -> [InAtom]
+ -> DataCon -> [InArg]
-- Scrutinee is (con, type, value arguments)
-> InAlts
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutExpr
-completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c
+completeAlgCaseWithKnownCon env con con_args a@(AlgAlts alts deflt) rhs_c
= ASSERT(isDataCon con)
search_alts alts
where
| alt_con == con
= -- Matching alternative!
let
- new_env = extendIdEnvWithAtomList env (zip alt_args con_args)
+ val_args = filter isValArg con_args
+ new_env = foldr bind env (zipEqual "SimplCase" alt_args val_args)
+ bind (bndr, atom) env = bindIdToAtom env bndr atom
in
rhs_c new_env rhs
= -- No matching alternative
case deflt of
NoDefault -> -- Blargh!
- panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
+ pprPanic "completeAlgCaseWithKnownCon: No matching alternative and no default"
+ (ppr con <+> ppr con_args $$ ppr a)
- 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' ->
+ simplBinder env binder `thenSmpl` \ (env1, id') ->
let
- env1 = extendIdEnvWithClone env binder id'
- new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id'
- (ConForm con tys 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 tys con_args)) rhs')
+ returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
\end{code}
Case absorption and identity-case elimination
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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)
munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
where
v | scrut_is_var = Var scrut_var
- | otherwise = Con con arg_tys (map VarArg args)
+ | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
- arg_tys = case maybeDataTyCon (idType deflt_var) of
- Just (_, arg_tys, _) -> arg_tys
+ arg_tys = case (splitAlgTyConApp (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
identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
- identity_alg_alt (con, args, Con con' _ args')
+ identity_alg_alt (con, args, Con con' args')
= con == con'
&& and (zipWith eq_arg args args')
&& length args == length args'
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
\end{code}
\begin{code}
- -- A cheap equality test which bales out fast!
cheap_eq :: InExpr -> InExpr -> Bool
+ -- A cheap equality test which bales out fast!
+
cheap_eq (Var v1) (Var v2) = v1==v2
cheap_eq (Lit l1) (Lit l2) = l1==l2
-cheap_eq (Con con1 tys1 args1) (Con con2 tys2 args2) = (con1==con2) &&
- (args1 `eq_args` args2)
- -- Types bound to be equal
-cheap_eq (Prim op1 tys1 args1) (Prim op2 tys2 args2) = (op1==op2) &&
- (args1 `eq_args` args2)
- -- Types bound to be equal
-cheap_eq (App f1 a1) (App f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2)
-cheap_eq (CoTyApp f1 t1) (CoTyApp f2 t2) = (f1 `cheap_eq` f2) && (t1 == t2)
+cheap_eq (Con con1 args1) (Con con2 args2)
+ = con1 == con2 && args1 `eq_args` args2
+
+cheap_eq (Prim op1 args1) (Prim op2 args2)
+ = op1 ==op2 && args1 `eq_args` args2
+
+cheap_eq (App f1 a1) (App f2 a2)
+ = f1 `cheap_eq` f2 && a1 `eq_arg` a2
+
cheap_eq _ _ = False
-- ToDo: make CoreArg an instance of Eq
-eq_args (arg1: args1) (arg2 : args2) = (arg1 `eq_atom` arg2) && (args1 `eq_args` args2)
-eq_args [] [] = True
-eq_args other1 other2 = False
-
-eq_atom (LitArg l1) (LitArg l2) = l1==l2
-eq_atom (VarArg v1) (VarArg v2) = v1==v2
-eq_atom other1 other2 = False
+eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
+eq_args [] [] = True
+eq_args _ _ = False
+
+eq_arg (LitArg l1) (LitArg l2) = l1 == l2
+eq_arg (VarArg v1) (VarArg v2) = v1 == v2
+eq_arg (TyArg t1) (TyArg t2) = t1 == t2
+eq_arg _ _ = False
\end{code}
projects / ghc-hetmet.git / blobdiff