X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCase.lhs;h=99e34ab6349a6bdf71b76fb5836ae816520c8d3d;hb=e47dd5d2e5e6dadec89fd0c36d53a14e686dcbfa;hp=6783e1154d070c7fd90598bcc1d7e606b7bfa0a9;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 6783e11..99e34ab 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -6,47 +6,48 @@ Support code for @Simplify@. \begin{code} -#include "HsVersions.h" - module SimplCase ( simplCase, bindLargeRhs ) where -import Ubiq{-uitous-} -import 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 ( UnfoldingDetails(..), UnfoldingGuidance(..), - FormSummary(..) - ) +import CoreUnfold ( Unfolding(..) ) import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, - unTagBindersAlts + unTagBindersAlts, unTagBinders, coreExprType ) -import Id ( idType, isDataCon, getIdDemandInfo, - 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 Maybes ( maybeToBool ) -import PrelInfo ( voidPrimTy, voidPrimId ) +import PrelVals ( voidId ) import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) +import SimplVar ( simplBinder, simplBinders ) +import SimplUtils ( newId, newIds ) import SimplEnv import SimplMonad -import SimplUtils ( mkValLamTryingEta ) -import Type ( isPrimType, maybeAppDataTyCon, mkFunTys, eqTy ) -import Unique ( Unique{-instance Eq-} ) -import Usage ( GenUsage{-instance Eq-} ) -import Util ( isIn, isSingleton, panic, assertPanic ) +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 - -> OutType -- Type of result expression + -> OutType -- Type of result expression -> SmplM OutExpr simplCase env (Let bind body) alts rhs_c result_ty @@ -99,27 +100,30 @@ All of this works equally well if the outer case has multiple rhss. \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} @@ -131,20 +135,33 @@ 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} 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} @@ -293,9 +310,9 @@ completeCase env scrut alts rhs_c -- 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, @@ -306,16 +323,11 @@ completeCase env scrut alts rhs_c -- 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 ""]) (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 @@ -325,16 +337,11 @@ completeCase env scrut alts rhs_c -- 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 @@ -359,7 +366,7 @@ completeCase env scrut alts rhs_c 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) @@ -367,10 +374,10 @@ 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 - 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 @@ -382,7 +389,7 @@ constructor or literal, because that would have been inlined \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} @@ -435,38 +442,36 @@ 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 -- 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 mkValLamTryingEta - 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) @@ -475,15 +480,13 @@ 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] 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 @@ -507,19 +510,43 @@ 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 && + 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 v -> extendUnfoldEnvGivenConstructor env1 v con con_args' + 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' -> @@ -530,11 +557,11 @@ simplAlts env scrut (PrimAlts alts deflt) rhs_c 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' -> @@ -572,7 +599,7 @@ simplDefault :: 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 @@ -580,38 +607,26 @@ simplDefault env scrut NoDefault form rhs_c = 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 = 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 = 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') @@ -650,7 +665,7 @@ completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c 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} @@ -671,7 +686,7 @@ completeAlgCaseWithKnownCon -> (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 @@ -681,7 +696,9 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c | 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 @@ -693,15 +710,14 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c = -- 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 = 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') @@ -711,7 +727,7 @@ 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): @@ -761,12 +777,13 @@ The following code handles *both* these transformations (one 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) @@ -791,16 +808,17 @@ mkCoCase scrut (AlgAlts outer_alts v | scrut_is_var = Var scrut_var | otherwise = Con con (map TyArg arg_tys ++ map VarArg args) - arg_tys = case maybeAppDataTyCon (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) @@ -850,7 +868,7 @@ Now the identity-case transformation: and similar friends. \begin{code} -mkCoCase scrut alts +mkCoCase env scrut alts | identity_alts alts = tick CaseIdentity `thenSmpl_` returnSmpl scrut @@ -887,7 +905,7 @@ mkCoCase scrut alts 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 @@ -938,7 +956,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}