-%
+`%
% (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-}
-IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
+#include "HsVersions.h"
+
+import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( Unfolding, SimpleUnfolding )
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
- unTagBindersAlts
+ unTagBindersAlts, unTagBinders, coreExprType
)
-import Id ( idType, isDataCon, getIdDemandInfo,
- SYN_IE(DataCon), GenId{-instance Eq-}
+import Id ( idType, isDataCon, getIdDemandInfo, dataConArgTys,
+ DataCon, GenId{-instance Eq-},
+ Id
)
import IdInfo ( willBeDemanded, DemandInfo )
import Literal ( isNoRepLit, Literal{-instance Eq-} )
import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
import SimplEnv
import SimplMonad
-import Type ( isPrimType, 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 ( isIn, isSingleton, zipEqual, panic, assertPanic )
+import Util ( Eager, runEager, appEager,
+ isIn, isSingleton, zipEqual, panic, assertPanic )
\end{code}
Float let out of case.
-> InExpr -- Scrutinee
-> InAlts -- Alternatives
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
- -> OutType -- Type of result expression
+ -> OutType -- Type of result expression
-> SmplM OutExpr
simplCase env (Let bind body) alts rhs_c result_ty
else
bindLargeAlts env 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)
| 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}
\begin{code}
simplCase env other_scrut alts rhs_c result_ty
- = -- Float the let outside the case scrutinee
- simplExpr env other_scrut [] `thenSmpl` \ scrut' ->
+ = simplTy env scrut_ty `appEager` \ scrut_ty' ->
+ simplExpr env' other_scrut [] scrut_ty `thenSmpl` \ scrut' ->
completeCase env scrut' alts rhs_c
+ where
+ -- When simplifying the scrutinee of a complete case that
+ -- has no default alternative
+ env' = case alts of
+ AlgAlts _ NoDefault -> setCaseScrutinee env
+ PrimAlts _ NoDefault -> setCaseScrutinee env
+ other -> env
+
+ scrut_ty = coreExprType (unTagBinders other_scrut)
\end{code}
-- 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
+ -> case (runEager $ lookupId env rhs_var) of
VarArg rhs_var' -> rhs_var' == scrut_var
other -> False
other -> False
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
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
+ = -- Generate the rhs
cloneIds env used_args `thenSmpl` \ 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 = mkValLam used_args' rhs'
-- it's processed the OutId won't be found in the environment, so it
-- will be left unmodified.
where
- rhs_fun_ty :: OutType
- rhs_fun_ty = mkFunTys [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]
-> 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
+ = ASSERT( isDataTyCon tycon )
+ 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' ->
new_env = case scrut of
Var v -> extendEnvGivenNewRhs env1 v (Con con args)
where
- (_, ty_args, _) = --trace "SimplCase.getAppData..." $
- getAppDataTyConExpandingDicts (idType v)
+ (_, ty_args, _) = splitAlgTyConApp (idType v)
args = map TyArg ty_args ++ map VarArg con_args'
other -> env1
v | scrut_is_var = Var scrut_var
| otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
- arg_tys = --trace "SimplCase:getAppData...:2" $
- 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