X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCase.lhs;h=786f723ca6f3ec68c12816e4efbb48f43db45783;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=d2cb6c5e6115a0f19a3c7bebe651c034ea5bd574;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index d2cb6c5..786f723 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1994-1995 +% (c) The AQUA Project, Glasgow University, 1994-1996 % \section[SimplCase]{Simplification of `case' expression} @@ -10,33 +10,36 @@ Support code for @Simplify@. module SimplCase ( simplCase, bindLargeRhs ) where -import SimplMonad -import SimplEnv +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun ) -import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp, - voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) +import BinderInfo -- too boring to try to select things... +import CmdLineOpts ( SimplifierSwitch(..) ) +import CoreSyn +import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), + SimpleUnfolding, FormSummary ) -import Type ( splitSigmaTy, splitTyArgs, glueTyArgs, - getTyConFamilySize, isPrimType, - maybeDataTyCon +import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, + unTagBindersAlts ) -import Literal ( isNoRepLit, Literal ) -import CmdLineOpts ( SimplifierSwitch(..) ) -import Id -import IdInfo -import Maybes ( catMaybes, maybeToBool, Maybe(..) ) -import Simplify -import SimplUtils -import SimplVar ( completeVar ) -import Util +import Id ( idType, isDataCon, getIdDemandInfo, + SYN_IE(DataCon), GenId{-instance Eq-} + ) +import IdInfo ( willBeDemanded, DemandInfo ) +import Literal ( isNoRepLit, Literal{-instance Eq-} ) +import Maybes ( maybeToBool ) +import PrelVals ( voidId ) +import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) +import SimplEnv +import SimplMonad +import SimplUtils ( mkValLamTryingEta ) +import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy ) +import TysPrim ( voidTy ) +import Unique ( Unique{-instance Eq-} ) +import Usage ( GenUsage{-instance Eq-} ) +import Util ( isIn, isSingleton, zipEqual, panic, assertPanic ) \end{code} - - - - Float let out of case. \begin{code} @@ -44,7 +47,7 @@ simplCase :: SimplEnv -> InExpr -- Scrutinee -> InAlts -- Alternatives -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler - -> OutUniType -- Type of result expression + -> OutType -- Type of result expression -> SmplM OutExpr simplCase env (Let bind body) alts rhs_c result_ty @@ -185,10 +188,10 @@ completeCase env (Lit lit) alts rhs_c tick KnownBranch `thenSmpl_` completePrimCaseWithKnownLit env lit alts rhs_c -completeCase env expr@(Con con tys con_args) alts rhs_c +completeCase env expr@(Con con con_args) alts rhs_c = -- Ha! Staring us in the face -- select the appropriate alternative tick KnownBranch `thenSmpl_` - completeAlgCaseWithKnownCon env con tys con_args alts rhs_c + completeAlgCaseWithKnownCon env con con_args alts rhs_c \end{code} Case elimination @@ -291,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, @@ -304,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 t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (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 @@ -322,25 +320,20 @@ 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 - Prim op _ _ -> primOpOkForSpeculation op - Var _ -> case alts of - PrimAlts _ _ -> True -- Primitive, hence non-bottom - AlgAlts _ _ -> False -- Not primitive - other -> False + Prim op _ -> primOpOkForSpeculation op + Var _ -> case alts of + PrimAlts _ _ -> True -- Primitive, hence non-bottom + AlgAlts _ _ -> False -- Not primitive + other -> False -- case v of w -> e{strict in w} ===> e[v/w] scrut_is_var_and_single_strict_default @@ -366,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 @@ -380,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} @@ -390,7 +382,7 @@ completeCase env scrut alts rhs_c bindLargeAlts :: SimplEnv -> InAlts -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler - -> OutUniType -- Result type + -> OutType -- Result type -> SmplM ([OutBinding], -- Extra bindings InAlts) -- Modified alts @@ -427,7 +419,7 @@ bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c \begin{code} bindLargeRhs :: SimplEnv -> [InBinder] -- The args wrt which the rhs should be abstracted - -> OutUniType + -> OutType -> (SimplEnv -> SmplM OutExpr) -- Rhs handler -> SmplM (OutBinding, -- New bindings (singleton or empty) InExpr) -- Modified rhs @@ -438,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 @@ -463,7 +455,7 @@ bindLargeRhs env args rhs_ty rhs_c let final_rhs = (if switchIsSet new_env SimplDoEtaReduction - then mkCoLamTryingEta + then mkValLamTryingEta else mkValLam) used_args' rhs' in returnSmpl (NonRec rhs_fun_id final_rhs, @@ -473,15 +465,15 @@ 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 :: OutUniType - rhs_fun_ty = glueTyArgs [simplTy env (idType id) | (id,_) <- used_args] rhs_ty + 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 = mkFunTy voidPrimTy rhs_ty + prim_rhs_fun_ty = mkFunTy voidTy rhs_ty \end{code} Case alternatives when we don't know the scrutinee @@ -511,14 +503,18 @@ 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 var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args') - other -> env1 + 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' -> returnSmpl (con, con_args', rhs') @@ -528,12 +524,12 @@ 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 var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LitForm lit)) - other -> env + Var v -> extendEnvGivenNewRhs env v (Lit lit) + other -> env in rhs_c new_env rhs `thenSmpl` \ rhs' -> returnSmpl (lit, rhs') @@ -570,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 @@ -578,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 = _scc_ "euegFD2" (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 = _scc_ "euegFD2" (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') @@ -663,13 +648,13 @@ var [substitute \tr{y} out of existence]. \begin{code} completeAlgCaseWithKnownCon :: SimplEnv - -> DataCon -> [Type] -> [InAtom] + -> DataCon -> [InArg] -- Scrutinee is (con, type, value arguments) -> InAlts -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler -> SmplM OutExpr -completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c +completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c = ASSERT(isDataCon con) search_alts alts where @@ -679,7 +664,8 @@ completeAlgCaseWithKnownCon env con tys 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 @@ -693,23 +679,22 @@ completeAlgCaseWithKnownCon env con tys 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 = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id' - (ConForm con tys 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 tys con_args)) rhs') + returnSmpl (Let (NonRec id' (Con con con_args)) rhs') \end{code} 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): @@ -759,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) @@ -787,18 +773,19 @@ mkCoCase scrut (AlgAlts outer_alts munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs) where v | scrut_is_var = Var scrut_var - | otherwise = Con con arg_tys (map VarArg args) + | otherwise = Con con (map TyArg arg_tys ++ map VarArg args) - arg_tys = case maybeDataTyCon (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) @@ -848,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 @@ -856,7 +843,7 @@ mkCoCase scrut alts identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt - identity_alg_alt (con, args, Con con' _ args') + identity_alg_alt (con, args, Con con' args') = con == con' && and (zipWith eq_arg args args') && length args == length args' @@ -885,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 @@ -913,26 +900,30 @@ munge_alg_deflt deflt_var (BindDefault d' rhs) \end{code} \begin{code} - -- A cheap equality test which bales out fast! cheap_eq :: InExpr -> InExpr -> Bool + -- A cheap equality test which bales out fast! + cheap_eq (Var v1) (Var v2) = v1==v2 cheap_eq (Lit l1) (Lit l2) = l1==l2 -cheap_eq (Con con1 tys1 args1) (Con con2 tys2 args2) = (con1==con2) && - (args1 `eq_args` args2) - -- Types bound to be equal -cheap_eq (Prim op1 tys1 args1) (Prim op2 tys2 args2) = (op1==op2) && - (args1 `eq_args` args2) - -- Types bound to be equal -cheap_eq (App f1 a1) (App f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2) -cheap_eq (CoTyApp f1 t1) (CoTyApp f2 t2) = (f1 `cheap_eq` f2) && (t1 == t2) +cheap_eq (Con con1 args1) (Con con2 args2) + = con1 == con2 && args1 `eq_args` args2 + +cheap_eq (Prim op1 args1) (Prim op2 args2) + = op1 ==op2 && args1 `eq_args` args2 + +cheap_eq (App f1 a1) (App f2 a2) + = f1 `cheap_eq` f2 && a1 `eq_arg` a2 + cheap_eq _ _ = False -- ToDo: make CoreArg an instance of Eq -eq_args (arg1: args1) (arg2 : args2) = (arg1 `eq_atom` arg2) && (args1 `eq_args` args2) -eq_args [] [] = True -eq_args other1 other2 = False - -eq_atom (LitArg l1) (LitArg l2) = l1==l2 -eq_atom (VarArg v1) (VarArg v2) = v1==v2 -eq_atom other1 other2 = False +eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2 +eq_args [] [] = True +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 _ _ = False \end{code}