X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCase.lhs;h=786f723ca6f3ec68c12816e4efbb48f43db45783;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=6783e1154d070c7fd90598bcc1d7e606b7bfa0a9;hpb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 6783e11..786f723 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -10,33 +10,34 @@ Support code for @Simplify@. module SimplCase ( simplCase, bindLargeRhs ) where -import Ubiq{-uitous-} -import SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun ) import BinderInfo -- too boring to try to select things... import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), - FormSummary(..) +import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), + SimpleUnfolding, FormSummary ) import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, unTagBindersAlts ) import Id ( idType, isDataCon, getIdDemandInfo, - DataCon(..), GenId{-instance Eq-} + SYN_IE(DataCon), GenId{-instance Eq-} ) 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 SimplEnv import SimplMonad import SimplUtils ( mkValLamTryingEta ) -import Type ( isPrimType, maybeAppDataTyCon, mkFunTys, eqTy ) +import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy ) +import TysPrim ( voidTy ) import Unique ( Unique{-instance Eq-} ) import Usage ( GenUsage{-instance Eq-} ) -import Util ( isIn, isSingleton, panic, assertPanic ) +import Util ( isIn, isSingleton, zipEqual, panic, assertPanic ) \end{code} Float let out of case. @@ -293,9 +294,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 +307,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 @@ -324,17 +320,12 @@ 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 + Var v -> lookupRhsInfo env v + other -> NoRhsInfo -- 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 @@ -368,9 +359,8 @@ completeCase env scrut alts rhs_c 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 + VarArg rhs_var' -> rhs_var' == scrut_var + other -> False other -> False is_elem x ys = isIn "completeCase" x ys @@ -382,7 +372,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} @@ -440,17 +430,17 @@ bindLargeRhs env args rhs_ty rhs_c -- 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 @@ -483,7 +473,7 @@ bindLargeRhs env args rhs_ty rhs_c 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 @@ -513,13 +503,17 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c 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' -> 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, _) = getAppDataTyConExpandingDicts (idType v) + args = map TyArg ty_args ++ map VarArg con_args' + other -> env1 in rhs_c new_env rhs `thenSmpl` \ rhs' -> @@ -530,11 +524,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 +566,7 @@ simplDefault :: SimplEnv -> OutExpr -- Simplified scrutinee -> InDefault -- Default alternative to be completed - -> UnfoldingDetails -- Gives form of scrutinee + -> RhsInfo -- Gives form of scrutinee -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler -> SmplM OutDefault @@ -580,38 +574,27 @@ 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 +simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs) + info_from_this_case rhs_c = cloneId env binder `thenSmpl` \ binder' -> let - env1 = extendIdEnvWithAtom env binder (VarArg binder') + env1 = extendIdEnvWithClone env binder binder' + env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case -- 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_info = lookupRhsInfo env scrut_var + env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info + new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder') in rhs_c new_env rhs `thenSmpl` \ rhs' -> returnSmpl (BindDefault binder' rhs') -simplDefault env scrut (BindDefault binder rhs) form rhs_c +simplDefault env scrut (BindDefault binder@(_,occ_info) rhs) + info_from_this_case rhs_c = cloneId env binder `thenSmpl` \ binder' -> let - env1 = extendIdEnvWithAtom env binder (VarArg binder') - new_env = extendUnfoldEnvGivenFormDetails env1 binder' form + env1 = extendIdEnvWithClone env binder binder' + new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case in rhs_c new_env rhs `thenSmpl` \ rhs' -> returnSmpl (BindDefault binder' rhs') @@ -681,7 +664,8 @@ 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) + new_env = extendIdEnvWithAtoms env + (zipEqual "SimplCase" alt_args (filter isValArg con_args)) in rhs_c new_env rhs @@ -695,13 +679,12 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c NoDefault -> -- Blargh! panic "completeAlgCaseWithKnownCon: No matching alternative and no default" - 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' -> 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 +694,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 +744,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 +775,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 (getAppDataTyConExpandingDicts (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 +835,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 +872,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