-`%
+%
% (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
-IMP_Ubiq(){-uitous-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
-#else
+#include "HsVersions.h"
+
import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
---import {-# SOURCE #-} MagicUFs ( MagicUnfoldingFun )
-#endif
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( Unfolding, SimpleUnfolding )
+import CoreUnfold ( Unfolding(..) )
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts, unTagBinders, coreExprType
)
import Id ( idType, isDataCon, getIdDemandInfo, dataConArgTys,
- SYN_IE(DataCon), GenId{-instance Eq-},
- SYN_IE(Id)
+ DataCon, GenId{-instance Eq-},
+ Id
)
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 ( isPrimType, maybeAppDataTyConExpandingDicts, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
+import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys )
import TyCon ( isDataTyCon )
import TysPrim ( voidTy )
-import Unique ( Unique{-instance Eq-} )
-import Usage ( GenUsage{-instance Eq-} )
-import Util ( SYN_IE(Eager), runEager, appEager,
+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
-> OutType -- Type of result expression
-> SmplM OutExpr
\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 [] 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}
Finally the default case
\begin{code}
-simplCase env other_scrut alts rhs_c result_ty
- = simplTy env scrut_ty `appEager` \ scrut_ty' ->
- simplExpr env' other_scrut [] scrut_ty `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' = case alts of
+ 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}
-- If the scrutinee is a variable, look it up to see what we know about it
scrut_form = case scrut of
- Var v -> lookupRhsInfo env v
- other -> NoRhsInfo
+ Var v -> lookupUnfolding env v
+ other -> NoUnfolding
-- If the scrut is already eval'd then there's no worry about
-- eliminating the case
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 (runEager $ lookupId env rhs_var) of
- 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
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
| otherwise
= -- Generate the rhs
- cloneIds env used_args `thenSmpl` \ used_args' ->
+ 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
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
- = ASSERT( isDataTyCon tycon )
- newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
+ 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)
+ 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 = maybeAppDataTyConExpandingDicts (idType id)
+ 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
where
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 v -> extendEnvGivenNewRhs env1 v (Con con args)
where
- (_, ty_args, _) = getAppDataTyConExpandingDicts (idType v)
+ (_, ty_args, _) = splitAlgTyConApp (idType v)
args = map TyArg ty_args ++ map VarArg con_args'
other -> env1
:: SimplEnv
-> OutExpr -- Simplified scrutinee
-> InDefault -- Default alternative to be completed
- -> RhsInfo -- Gives form of scrutinee
+ -> Unfolding -- Gives form of scrutinee
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
-> SmplM OutDefault
-- Special case for variable scrutinee; see notes above.
simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
info_from_this_case rhs_c
- = cloneId env binder `thenSmpl` \ binder' ->
+ = simplBinder env binder `thenSmpl` \ (env1, binder') ->
let
- env1 = extendIdEnvWithClone env binder binder'
- env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
+ env2 = extendEnvGivenNewRhs env1 scrut_var (Var binder')
-- Add form details for the default binder
- scrut_info = lookupRhsInfo env scrut_var
- env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
- new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
+ 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@(_,occ_info) rhs)
info_from_this_case rhs_c
- = cloneId env binder `thenSmpl` \ binder' ->
+ = simplBinder env binder `thenSmpl` \ (env1, binder') ->
let
- env1 = extendIdEnvWithClone env binder binder'
- new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
+ 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}
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutExpr
-completeAlgCaseWithKnownCon env con 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 = extendIdEnvWithAtoms env
- (zipEqual "SimplCase" alt_args (filter isValArg 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@(_,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 = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
v | scrut_is_var = Var scrut_var
| otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
- arg_tys = case (getAppDataTyConExpandingDicts (idType deflt_var)) of
+ arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
(_, arg_tys, _) -> arg_tys
mkCoCase env scrut (PrimAlts
eq_arg (LitArg l1) (LitArg l2) = l1 == l2
eq_arg (VarArg v1) (VarArg v2) = v1 == v2
-eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2
-eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2
+eq_arg (TyArg t1) (TyArg t2) = t1 == t2
eq_arg _ _ = False
\end{code}
projects / ghc-hetmet.git / blobdiff