X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCase.lhs;h=ea06d8d3ac6845e767eabef494cd8d57c4ad2ba5;hb=9dd6e1c216993624a2cd74b62ca0f0569c02c26b;hp=f571658ec54ba2b32e79307da961c1b2d52d4fdc;hpb=8f7ac3fe40d3d55743b824deab655d0797a1c55f;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index f571658..ea06d8d 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -1,4 +1,4 @@ -% +`% % (c) The AQUA Project, Glasgow University, 1994-1996 % \section[SimplCase]{Simplification of `case' expression} @@ -6,22 +6,22 @@ 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-} ) @@ -30,11 +30,12 @@ import PrelVals ( voidId ) 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. @@ -44,7 +45,7 @@ simplCase :: SimplEnv -> 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 @@ -109,7 +110,7 @@ simplCase env (Case inner_scrut inner_alts) outer_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) @@ -129,10 +130,12 @@ simplCase env scrut 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} @@ -140,9 +143,18 @@ 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' -> + = 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} @@ -355,7 +367,7 @@ completeCase env scrut alts rhs_c -- 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 @@ -422,7 +434,7 @@ bindLargeRhs :: SimplEnv 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 @@ -440,14 +452,16 @@ bindLargeRhs env args rhs_ty rhs_c 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' @@ -459,8 +473,6 @@ bindLargeRhs env args rhs_ty rhs_c -- 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] @@ -491,6 +503,27 @@ simplAlts :: SimplEnv -> 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' -> @@ -505,8 +538,7 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c 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 @@ -770,8 +802,7 @@ mkCoCase env scrut (AlgAlts outer_alts 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 @@ -919,7 +950,6 @@ 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 `eqTy` t2 -eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2 +eq_arg (TyArg t1) (TyArg t2) = t1 == t2 eq_arg _ _ = False \end{code}