From 7e8cba32c6f045dde3db8a9ddc9831ec8ab4ed43 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Sat, 20 Sep 2008 17:52:38 +0000 Subject: [PATCH] Tidy up the treatment of dead binders This patch does a lot of tidying up of the way that dead variables are handled in Core. Just the sort of thing to do on an aeroplane. * The tricky "binder-swap" optimisation is moved from the Simplifier to the Occurrence Analyser. See Note [Binder swap] in OccurAnal. This is really a nice change. It should reduce the number of simplifier iteratoins (slightly perhaps). And it means that we can be much less pessimistic about zapping occurrence info on binders in a case expression. * For example: case x of y { (a,b) -> e } Previously, each time around, even if y,a,b were all dead, the Simplifier would pessimistically zap their OccInfo, so that we can't see they are dead any more. As a result virtually no case expression ended up with dead binders. This wasn't Bad in itself, but it always felt wrong. * I added a check to CoreLint to check that a dead binder really isn't used. That showed up a couple of bugs in CSE. (Only in this sense -- they didn't really matter.) * I've changed the PprCore printer to print "_" for a dead variable. (Use -dppr-debug to see it again.) This reduces clutter quite a bit, and of course it's much more useful with the above change. * Another benefit of the binder-swap change is that I could get rid of the Simplifier hack (working, but hacky) in which the InScopeSet was used to map a variable to a *different* variable. That allowed me to remove VarEnv.modifyInScopeSet, and to simplify lookupInScopeSet so that it doesn't look for a fixpoint. This fixes no bugs, but is a useful cleanup. * Roman pointed out that Id.mkWildId is jolly dangerous, because of its fixed unique. So I've - localied it to MkCore, where it is private (not exported) - renamed it to 'mkWildBinder' to stress that you should only use it at binding sites, unless you really know what you are doing - provided a function MkCore.mkWildCase that emodies the most common use of mkWildId, and use that elsewhere So things are much better * A knock-on change is that I found a common pattern of localising a potentially global Id, and made a function for it: Id.localiseId --- compiler/basicTypes/Id.lhs | 29 ++- compiler/basicTypes/VarEnv.lhs | 41 ++-- compiler/coreSyn/CoreLint.lhs | 19 ++ compiler/coreSyn/CoreUtils.lhs | 10 +- compiler/coreSyn/MkCore.lhs | 42 +++- compiler/coreSyn/PprCore.lhs | 33 ++-- compiler/deSugar/DsBinds.lhs | 9 +- compiler/deSugar/DsCCall.lhs | 17 +- compiler/deSugar/DsUtils.lhs | 8 +- compiler/prelude/PrelRules.lhs | 5 +- compiler/simplCore/CSE.lhs | 30 +-- compiler/simplCore/LiberateCase.lhs | 6 +- compiler/simplCore/OccurAnal.lhs | 161 ++++++++++++---- compiler/simplCore/SimplEnv.lhs | 36 ++-- compiler/simplCore/Simplify.lhs | 363 ++++++++++++++++------------------- compiler/vectorise/VectCore.hs | 6 +- compiler/vectorise/VectType.hs | 24 +-- compiler/vectorise/VectUtils.hs | 5 +- 18 files changed, 479 insertions(+), 365 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 154275b..d87e45b 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -29,7 +29,7 @@ module Id ( mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, mkLocalId, mkLocalIdWithInfo, mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, - mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, mkWorkerId, mkExportedLocalId, -- ** Taking an Id apart @@ -38,9 +38,12 @@ module Id ( recordSelectorFieldLabel, -- ** Modifying an Id - setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, - globaliseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + setIdName, setIdUnique, Id.setIdType, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo, + -- ** Predicates on Ids isImplicitId, isDeadBinder, isDictId, isStrictId, @@ -86,7 +89,7 @@ module Id ( setIdWorkerInfo, setIdSpecialisation, setIdCafInfo, - setIdOccInfo, + setIdOccInfo, zapIdOccInfo, #ifdef OLD_STRICTNESS setIdStrictness, @@ -185,6 +188,17 @@ setIdExported = setIdVarExported setIdNotExported :: Id -> Id setIdNotExported = setIdVarNotExported +localiseId :: Id -> Id +-- Make an with the same unique and type as the +-- incoming Id, but with an *Internal* Name and *LocalId* flavour +localiseId id + | isLocalId id && isInternalName name + = id + | otherwise + = mkLocalIdWithInfo (localiseName name) (idType id) (idInfo id) + where + name = idName id + globaliseId :: GlobalIdDetails -> Id -> Id globaliseId = globaliseIdVar @@ -274,10 +288,6 @@ Make some local @Ids@ for a template @CoreExpr@. These have bogus instantiated before use. \begin{code} --- | Make a /wild Id/. This is typically used when you need a binder that you don't expect to use -mkWildId :: Type -> Id -mkWildId ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty - -- | Workers get local names. "CoreTidy" will externalise these if necessary mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId uniq unwrkr ty @@ -603,6 +613,9 @@ idOccInfo id = occInfo (idInfo id) setIdOccInfo :: Id -> OccInfo -> Id setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id + +zapIdOccInfo :: Id -> Id +zapIdOccInfo b = b `setIdOccInfo` NoOccInfo \end{code} diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index 4bb00cf..7e28d1a 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -27,7 +27,6 @@ module VarEnv ( -- ** Operations on InScopeSets emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - modifyInScopeSet, getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, -- * The RnEnv2 type @@ -66,7 +65,18 @@ import FastString \begin{code} -- | A set of variables that are in scope at some point data InScopeSet = InScope (VarEnv Var) FastInt - -- The Int# is a kind of hash-value used by uniqAway + -- The (VarEnv Var) is just a VarSet. But we write it like + -- this to remind ourselves that you can look up a Var in + -- the InScopeSet. Typically the InScopeSet contains the + -- canonical version of the variable (e.g. with an informative + -- unfolding), so this lookup is useful. + -- + -- INVARIANT: the VarEnv maps (the Unique of) a variable to + -- a variable with the same Uniqua. (This was not + -- the case in the past, when we had a grevious hack + -- mapping var1 to var2. + -- + -- The FastInt is a kind of hash-value used by uniqAway -- For example, it might be the size of the set -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway @@ -94,37 +104,16 @@ extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet extendInScopeSetSet (InScope in_scope n) vs = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs)) --- | Replace the first 'Var' with the second in the set of in-scope variables -modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet --- Exploit the fact that the in-scope "set" is really a map --- Make old_v map to new_v --- QUESTION: shouldn't we add a mapping from new_v to new_v as it is presumably now in scope? - MB 08 -modifyInScopeSet (InScope in_scope n) old_v new_v = InScope (extendVarEnv in_scope old_v new_v) (n +# _ILIT(1)) - delInScopeSet :: InScopeSet -> Var -> InScopeSet delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n elemInScopeSet :: Var -> InScopeSet -> Bool elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope --- | If the given variable was even added to the 'InScopeSet', or if it was the \"from\" argument --- of any 'modifyInScopeSet' operation, returns that variable with all appropriate modifications --- applied to it. Otherwise, return @Nothing@ +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. lookupInScope :: InScopeSet -> Var -> Maybe Var --- It's important to look for a fixed point --- When we see (case x of y { I# v -> ... }) --- we add [x -> y] to the in-scope set (Simplify.simplCaseBinder and --- modifyInScopeSet). --- --- When we lookup up an occurrence of x, we map to y, but then --- we want to look up y in case it has acquired more evaluation information by now. -lookupInScope (InScope in_scope _) v - = go v - where - go v = case lookupVarEnv in_scope v of - Just v' | v == v' -> Just v' -- Reached a fixed point - | otherwise -> go v' - Nothing -> Nothing +lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v \end{code} \begin{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index ffccf6f..2b2a6e8 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -256,6 +256,8 @@ lintCoreExpr :: CoreExpr -> LintM OutType lintCoreExpr (Var var) = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) + + ; checkDeadIdOcc var ; var' <- lookupIdInScope var ; return (idType var') } @@ -422,6 +424,17 @@ checkKinds tyvar arg_ty tyvar_kind = tyVarKind tyvar arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty | otherwise = typeKind arg_ty + +checkDeadIdOcc :: Id -> LintM () +-- Occurrences of an Id should never be dead.... +-- except when we are checking a case pattern +checkDeadIdOcc id + | isDeadOcc (idOccInfo id) + = do { in_case <- inCasePat + ; checkL in_case + (ptext (sLit "Occurrence of a dead Id") <+> ppr id) } + | otherwise + = return () \end{code} @@ -666,6 +679,12 @@ addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m = LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) +inCasePat :: LintM Bool -- A slight hack; see the unique call site +inCasePat = LintM $ \ loc _ errs -> (Just (is_case_pat loc), errs) + where + is_case_pat (CasePat {} : _) = True + is_case_pat _other = False + addInScopeVars :: [Var] -> LintM a -> LintM a addInScopeVars vars m | null dups diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 07709c8..eb9ea41 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -18,7 +18,7 @@ module CoreUtils ( -- * Constructing expressions mkInlineMe, mkSCC, mkCoerce, mkCoerceI, bindNonRec, needsCaseBinding, - mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, + mkAltExpr, mkPiType, mkPiTypes, -- * Taking expressions apart findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, @@ -71,7 +71,6 @@ import NewDemand import Type import Coercion import TyCon -import TysWiredIn import CostCentre import BasicTypes import Unique @@ -298,13 +297,6 @@ mkAltExpr (LitAlt lit) [] [] = Lit lit mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" - -mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr -mkIfThenElse guard then_expr else_expr --- Not going to be refining, so okay to take the type of the "then" clause - = Case guard (mkWildId boolTy) (exprType then_expr) - [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! - (DataAlt trueDataCon, [], then_expr) ] \end{code} diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs index acb189f..e771137 100644 --- a/compiler/coreSyn/MkCore.lhs +++ b/compiler/coreSyn/MkCore.lhs @@ -4,7 +4,7 @@ module MkCore ( -- * Constructing normal syntax mkCoreLet, mkCoreLets, mkCoreApp, mkCoreApps, mkCoreConApps, - mkCoreLams, + mkCoreLams, mkWildCase, mkIfThenElse, -- * Constructing boxed literals mkWordExpr, mkWordExprWord, @@ -48,7 +48,6 @@ import HscTypes import TysWiredIn import PrelNames -import MkId ( seqId ) import Type import TypeRep @@ -57,6 +56,7 @@ import DataCon ( DataCon, dataConWorkId ) import FastString import UniqSupply +import Unique ( mkBuiltinUnique ) import BasicTypes import Util ( notNull, zipEqual ) import Panic @@ -121,22 +121,50 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args ----------- mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty - | f == seqId -- Note [Desugaring seq (1), (2)] + | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] = Case arg1 case_bndr res_ty [(DEFAULT,[],arg2)] where case_bndr = case arg1 of Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] - _ -> mkWildId ty1 + _ -> mkWildBinder ty1 mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant] | not (needsCaseBinding arg_ty arg) = App fun arg -- The vastly common case mk_val_app fun arg arg_ty res_ty - = Case arg (mkWildId arg_ty) res_ty [(DEFAULT,[],App fun (Var arg_id))] + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] where - arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter, - -- because 'fun ' should not have a free wild-id + arg_id = mkWildBinder arg_ty + -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id + -- + -- This is Dangerous. But this is the only place we play this + -- game, mk_val_app returns an expression that does not have + -- have a free wild-id. So the only thing that can go wrong + -- is if you take apart this case expression, and pass a + -- fragmet of it as the fun part of a 'mk_val_app'. + + +-- | Make a /wildcard binder/. This is typically used when you need a binder +-- that you expect to use only at a *binding* site. Do not use it at +-- occurrence sites because it has a single, fixed unique, and it's very +-- easy to get into difficulties with shadowing. That's why it is used so little. +mkWildBinder :: Type -> Id +mkWildBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty + +mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +-- Make a case expression whose case binder is unused +-- The alts should not have any occurrences of WildId +mkWildCase scrut scrut_ty res_ty alts + = Case scrut (mkWildBinder scrut_ty) res_ty alts + +mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr +mkIfThenElse guard then_expr else_expr +-- Not going to be refining, so okay to take the type of the "then" clause + = mkWildCase guard boolTy (exprType then_expr) + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] \end{code} Note [Desugaring seq (1)] cf Trac #1031 diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 39d5b35..d641a9e 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -248,7 +248,7 @@ instance OutputableBndr Var where pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder - | isTyVar binder = pprTypedBinder binder + | isTyVar binder = pprKindedTyVarBndr binder | otherwise = vcat [sig, pprIdDetails binder, pragmas] where @@ -256,7 +256,15 @@ pprCoreBinder LetBind binder pragmas = ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" -pprCoreBinder LambdaBind bndr = parens (pprTypedBinder bndr) +pprCoreBinder LambdaBind bndr + | isDeadBinder bndr + = getPprStyle $ \ sty -> + if debugStyle sty then + parens (pprTypedBinder bndr) + else + char '_' + | otherwise + = parens (pprTypedBinder bndr) -- Case bound things don't get a signature or a herald, unless we have debug on pprCoreBinder CaseBind bndr @@ -264,7 +272,8 @@ pprCoreBinder CaseBind bndr if debugStyle sty then parens (pprTypedBinder bndr) else - pprUntypedBinder bndr + if isDeadBinder bndr then char '_' + else pprUntypedBinder bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder @@ -272,19 +281,19 @@ pprUntypedBinder binder | otherwise = pprIdBndr binder pprTypedBinder :: Var -> SDoc +-- Print binder with a type or kind signature (not paren'd) pprTypedBinder binder - | isTyVar binder = ptext (sLit "@") <+> pprTyVarBndr binder + | isTyVar binder = pprKindedTyVarBndr binder | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder) -pprTyVarBndr :: TyVar -> SDoc -pprTyVarBndr tyvar - = getPprStyle $ \ sty -> - if debugStyle sty then - hsep [ppr tyvar, dcolon, pprParendKind kind] - -- See comments with ppDcolon in PprCore.lhs - else - ppr tyvar +pprKindedTyVarBndr :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +pprKindedTyVarBndr tyvar + = ptext (sLit "@") <+> ppr tyvar <> opt_kind where + opt_kind -- Print the kind if not * + | isLiftedTypeKind kind = empty + | otherwise = dcolon <> pprKind kind kind = tyVarKind tyvar -- pprIdBndr does *not* print the type diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index a47551e..020b7b4 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -36,7 +36,6 @@ import TcType import CostCentre import Module import Id -import Name ( localiseName ) import Var ( Var, TyVar ) import VarSet import Rules @@ -352,7 +351,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr poly_f_body = mkLams (tvs ++ dicts) f_body - extra_dict_bndrs = [localise d + extra_dict_bndrs = [localiseId d -- See Note [Constant rule dicts] | d <- varSetElems (exprFreeVars ds_spec_expr) , isDictId d] -- Note [Const rule dicts] @@ -380,9 +379,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored")) 2 (ppr spec_expr) - - localise d = mkLocalId (localiseName (idName d)) (idType d) - -- See Note [Constant rule dicts] + mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type) -- If any of the tyvars is missing from any of the lists in @@ -443,7 +440,7 @@ And from that we want the rule But be careful! That dInt might be GHC.Base.$fOrdInt, which is an External Name, and you can't bind them in a lambda or forall without getting things -confused. Hence the use of 'localise' to make it Internal. +confused. Hence the use of 'localiseId' to make it Internal. %************************************************************************ diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs index a94ab42..2034e37 100644 --- a/compiler/deSugar/DsCCall.lhs +++ b/compiler/deSugar/DsCCall.lhs @@ -22,6 +22,7 @@ import CoreSyn import DsMonad import CoreUtils +import MkCore import Var import Id import MkId @@ -142,7 +143,7 @@ unboxArg arg tc `hasKey` boolTyConKey = do prim_arg <- newSysLocalDs intPrimTy return (Var prim_arg, - \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy + \ body -> Case (mkWildCase arg arg_ty intPrimTy [(DataAlt falseDataCon,[],mkIntLit 0), (DataAlt trueDataCon, [],mkIntLit 1)]) -- In increasing tag order! @@ -284,8 +285,8 @@ boxResult augment mbTopCon result_ty mkApps (Var toIOCon) [ Type io_res_ty, Lam state_id $ - Case (App the_call (Var state_id)) - (mkWildId ccall_res_ty) + mkWildCase (App the_call (Var state_id)) + ccall_res_ty (coreAltType the_alt) [the_alt] ] @@ -298,10 +299,10 @@ boxResult augment _mbTopCon result_ty res <- resultWrapper result_ty (ccall_res_ty, the_alt) <- mk_alt return_result (augment res) let - wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) - (mkWildId ccall_res_ty) - (coreAltType the_alt) - [the_alt] + wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId)) + ccall_res_ty + (coreAltType the_alt) + [the_alt] return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) where return_result _ [ans] = ans @@ -371,7 +372,7 @@ resultWrapper result_ty -- Base case 3: the boolean type | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = return - (Just intPrimTy, \e -> Case e (mkWildId intPrimTy) + (Just intPrimTy, \e -> mkWildCase e intPrimTy boolTy [(DEFAULT ,[],Var trueDataConId ), (LitAlt (mkMachInt 0),[],Var falseDataConId)]) diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 24579df..f2609b7 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -301,11 +301,10 @@ mkCoAlgCaseMatchResult var ty match_alts | otherwise = CanFail - wild_var = mkWildId (idType var) sorted_alts = sortWith get_tag match_alts get_tag (con, _, _) = dataConTag con mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts - return (Case (Var var) wild_var ty (mk_default fail ++ alts)) + return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)) mk_alt fail (con, args, MatchResult _ body_fn) = do body <- body_fn fail @@ -352,7 +351,7 @@ mkCoAlgCaseMatchResult var ty match_alts mk_parrCase fail = do lengthP <- dsLookupGlobalId lengthPName alt <- unboxAlt - return (Case (len lengthP) (mkWildId intTy) ty [alt]) + return (mkWildCase (len lengthP) intTy ty [alt]) where elemTy = case splitTyConApp (idType var) of (_, [elemTy]) -> elemTy @@ -364,9 +363,8 @@ mkCoAlgCaseMatchResult var ty match_alts l <- newSysLocalDs intPrimTy indexP <- dsLookupGlobalId indexPName alts <- mapM (mkAlt indexP) sorted_alts - return (DataAlt intDataCon, [l], (Case (Var l) wild ty (dft : alts))) + return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) where - wild = mkWildId intPrimTy dft = (DEFAULT, [], fail) -- -- each alternative matches one array length (corresponding to one diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index bacd1bc..67eb06f 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -20,7 +20,8 @@ module PrelRules ( primOpRules, builtinRules ) where #include "HsVersions.h" import CoreSyn -import Id ( mkWildId, idUnfolding ) +import MkCore ( mkWildCase ) +import Id ( idUnfolding ) import Literal ( Literal(..), mkMachInt, mkMachWord , literalType , word2IntLit, int2WordLit @@ -340,7 +341,7 @@ litEq op_name is_eq rule_fn _ = Nothing do_lit_eq lit expr - = Just (Case expr (mkWildId (literalType lit)) boolTy + = Just (mkWildCase expr (literalType lit) boolTy [(DEFAULT, [], val_if_neq), (LitAlt lit, [], val_if_eq)]) val_if_eq | is_eq = trueVal diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs index 495ea42..1386197 100644 --- a/compiler/simplCore/CSE.lhs +++ b/compiler/simplCore/CSE.lhs @@ -11,7 +11,7 @@ module CSE ( #include "HsVersions.h" import DynFlags ( DynFlag(..), DynFlags ) -import Id ( Id, idType, idInlinePragma ) +import Id ( Id, idType, idInlinePragma, zapIdOccInfo ) import CoreUtils ( hashExpr, cheapEqExpr, exprIsBig, mkAltExpr, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) @@ -69,7 +69,7 @@ to run the substitution over types and IdInfo. No no no. Instead, we just thro (In fact, I think the simplifier does guarantee no-shadowing for type variables.) -[Note: case binders 1] +Note [Case binders 1] ~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -83,9 +83,9 @@ but for CSE purpose that's a bad idea. So we add the binding (wild1 -> a) to the extra var->var mapping. Notice this is exactly backwards to what the simplifier does, which is -to try to replaces uses of a with uses of wild1 +to try to replaces uses of 'a' with uses of 'wild1' -[Note: case binders 2] +Note [Case binders 2] ~~~~~~~~~~~~~~~~~~~~~~ Consider case (h x) of y -> ...(h x)... @@ -98,7 +98,7 @@ to the reverse CSE mapping if the scrutinee is a non-trivial expression. case binder -> scrutinee to the substitution -[Note: unboxed tuple case binders] +Note [Unboxed tuple case binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider case f x of t { (# a,b #) -> @@ -233,34 +233,40 @@ cseExpr env (Lam b e) = let (env', b') = addBinder env b in Lam b' (cseExpr env' e) cseExpr env (Let bind e) = let (env', bind') = cseBind env bind in Let bind' (cseExpr env' e) -cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr' ty (cseAlts env' scrut' bndr bndr' alts) +cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts) where scrut' = tryForCSE env scrut (env', bndr') = addBinder env bndr - + bndr'' = zapIdOccInfo bndr' + -- The swizzling from Note [Case binders 2] may + -- cause a dead case binder to be alive, so we + -- play safe here and bring them all to life cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt] cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)] | isUnboxedTupleCon con -- Unboxed tuples are special because the case binder isn't - -- a real values. See [Note: unboxed tuple case binders] - = [(DataAlt con, args', tryForCSE new_env rhs)] + -- a real values. See Note [Unboxed tuple case binders] + = [(DataAlt con, args'', tryForCSE new_env rhs)] where (env', args') = addBinders env args + args'' = map zapIdOccInfo args' -- They should all be ids + -- Same motivation for zapping as [Case binders 2] only this time + -- it's Note [Unboxed tuple case binders] new_env | exprIsCheap scrut' = env' | otherwise = extendCSEnv env' scrut' tup_value - tup_value = mkAltExpr (DataAlt con) args' (tyConAppArgs (idType bndr)) + tup_value = mkAltExpr (DataAlt con) args'' (tyConAppArgs (idType bndr)) cseAlts env scrut' bndr bndr' alts = map cse_alt alts where (con_target, alt_env) = case scrut' of - Var v' -> (v', extendSubst env bndr v') -- See [Note: case binder 1] + Var v' -> (v', extendSubst env bndr v') -- See Note [Case binders 1] -- map: bndr -> v' - _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See [Note: case binder 2] + _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index ab79239..9fe6b87 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -18,7 +18,6 @@ import UniqSupply ( UniqSupply ) import SimplMonad ( SimplCount, zeroSimplCount ) import Id import VarEnv -import Name ( localiseName ) import Util ( notNull ) \end{code} @@ -171,10 +170,10 @@ libCaseBind env (Rec pairs) -- processing the rhs with an *un-extended* environment, so -- that the same process doesn't occur for ever! -- - extended_env = addRecBinds env [ (adjust binder, libCase env_body rhs) + extended_env = addRecBinds env [ (localiseId binder, libCase env_body rhs) | (binder, rhs) <- pairs ] - -- Two subtle things: + -- The call to localiseId is needed for two subtle reasons -- (a) Reset the export flags on the binders so -- that we don't get name clashes on exported things if the -- local binding floats out to top level. This is most unlikely @@ -184,7 +183,6 @@ libCaseBind env (Rec pairs) -- (b) Make the name an Internal one. External Names should never be -- nested; if it were floated to the top level, we'd get a name -- clash at code generation time. - adjust bndr = setIdNotExported (setIdName bndr (localiseName (idName bndr))) rhs_small_enough (id,rhs) = idArity id > 0 -- Note [Only functions!] diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 2b2c058..58f72cb 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -20,6 +20,7 @@ module OccurAnal ( import CoreSyn import CoreFVs import CoreUtils ( exprIsTrivial, isDefaultAlt ) +import Coercion ( mkSymCoercion ) import Id import IdInfo import BasicTypes @@ -769,8 +770,8 @@ occAnal env expr@(Lam _ _) is_one_shot b = isId b && isOneShotBndr b occAnal env (Case scrut bndr ty alts) - = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> - case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') -> + = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> + case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> let alts_usage = foldr1 combineAltsUsageDetails alts_usage_s alts_usage' = addCaseBndrUsage alts_usage @@ -779,6 +780,8 @@ occAnal env (Case scrut bndr ty alts) in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} where + -- Note [Case binder usage] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ -- The case binder gets a usage of either "many" or "dead", never "one". -- Reason: we like to inline single occurrences, to eliminate a binding, -- but inlining a case binder *doesn't* eliminate a binding. @@ -787,18 +790,27 @@ occAnal env (Case scrut bndr ty alts) -- into -- case x of w { (p,q) -> f (p,q) } addCaseBndrUsage usage = case lookupVarEnv usage bndr of - Nothing -> usage - Just occ -> extendVarEnv usage bndr (markMany occ) + Nothing -> usage + Just _ -> extendVarEnv usage bndr NoOccInfo alt_env = setVanillaCtxt env -- Consider x = case v of { True -> (p,q); ... } -- Then it's fine to inline p and q + bndr_swap = case scrut of + Var v -> Just (v, Var bndr) + Cast (Var v) co -> Just (v, Cast (Var bndr) (mkSymCoercion co)) + _other -> Nothing + + occ_anal_alt = occAnalAlt alt_env bndr bndr_swap + occ_anal_scrut (Var v) (alt1 : other_alts) - | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v True, Var v) - occ_anal_scrut scrut _alts = occAnal vanillaCtxt scrut - -- No need for rhsCtxt + | not (null other_alts) || not (isDefaultAlt alt1) + = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs + -- in an interesting context; the case has + -- at least one non-default alternative + occ_anal_scrut scrut _alts + = occAnal vanillaCtxt scrut -- No need for rhsCtxt occAnal env (Let bind body) = case occAnal env body of { (body_usage, body') -> @@ -900,38 +912,104 @@ appSpecial env n ctxt args \end{code} -Case alternatives -~~~~~~~~~~~~~~~~~ -If the case binder occurs at all, the other binders effectively do too. -For example - case e of x { (a,b) -> rhs } -is rather like - let x = (a,b) in rhs -If e turns out to be (e1,e2) we indeed get something like - let a = e1; b = e2; x = (a,b) in rhs - -Note [Aug 06]: I don't think this is necessary any more, and it helpe - to know when binders are unused. See esp the call to - isDeadBinder in Simplify.mkDupableAlt +Note [Binder swap] +~~~~~~~~~~~~~~~~~~ +We do these two transformations right here: + + (1) case x of b { pi -> ri } + ==> + case x of b { pi -> let x=b in ri } + + (2) case (x |> co) of b { pi -> ri } + ==> + case (x |> co) of b { pi -> let x = b |> sym co in ri } + + Why (2)? See Note [Ccase of cast] + +In both cases, in a particular alternative (pi -> ri), we only +add the binding if + (a) x occurs free in (pi -> ri) + (ie it occurs in ri, but is not bound in pi) + (b) the pi does not bind b (or the free vars of co) + (c) x is not a +We need (a) and (b) for the inserted binding to be correct. + +Notice that (a) rapidly becomes false, so no bindings are injected. + +Notice the deliberate shadowing of 'x'. But we must call localiseId +on 'x' first, in case it's a GlobalId, or has an External Name. +See, for example, SimplEnv Note [Global Ids in the substitution]. + +For the alternatives where we inject the binding, we can transfer +all x's OccInfo to b. And that is the point. + +The reason for doing these transformations here is because it allows +us to adjust the OccInfo for 'x' and 'b' as we go. + + * Suppose the only occurrences of 'x' are the scrutinee and in the + ri; then this transformation makes it occur just once, and hence + get inlined right away. + + * If we do this in the Simplifier, we don't know whether 'x' is used + in ri, so we are forced to pessimistically zap b's OccInfo even + though it is typically dead (ie neither it nor x appear in the + ri). There's nothing actually wrong with zapping it, except that + it's kind of nice to know which variables are dead. My nose + tells me to keep this information as robustly as possible. + +The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding +{x=b}; it's Nothing if the binder-swap doesn't happen. + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) This invariant is It really +helpe to know when binders are unused. See esp the call to +isDeadBinder in Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, beause it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). \begin{code} occAnalAlt :: OccEnv -> CoreBndr + -> Maybe (Id, CoreExpr) -- Note [Binder swap] -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo) -occAnalAlt env _case_bndr (con, bndrs, rhs) +occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs) = case occAnal env rhs of { (rhs_usage, rhs') -> let - (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs - final_bndrs = tagged_bndrs -- See Note [Aug06] above -{- - final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs - | otherwise = tagged_bndrs - -- Leave the binders untagged if the case - -- binder occurs at all; see note above --} + (alt_usg, tagged_bndrs) = tagBinders rhs_usage bndrs + bndrs' = tagged_bndrs -- See Note [Binders in case alternatives] in - (final_usage, (con, final_bndrs, rhs')) } + case mb_scrut_var of + Just (scrut_var, scrut_rhs) -- See Note [Binder swap] + | scrut_var `localUsedIn` alt_usg -- (a) Fast path, usually false + , not (any shadowing bndrs) -- (b) + -> (addOneOcc usg_wo_scrut case_bndr NoOccInfo, + -- See Note [Case binder usage] for the NoOccInfo + (con, bndrs', Let (NonRec scrut_var' scrut_rhs) rhs')) + where + (usg_wo_scrut, scrut_var') = tagBinder alt_usg (localiseId scrut_var) + -- Note the localiseId; we're making a new binding + -- for it, and it might have an External Name, or + -- even be a GlobalId + shadowing bndr = bndr `elemVarSet` rhs_fvs + rhs_fvs = exprFreeVars scrut_rhs + + _other -> (alt_usg, (con, bndrs', rhs')) } \end{code} @@ -1022,6 +1100,8 @@ addAppCtxt (OccEnv encl ctxt) args \begin{code} type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage + -- INVARIANT: never IAmDead + -- (Deadness is signalled by not being in the map at all) (+++), combineAltsUsageDetails :: UsageDetails -> UsageDetails -> UsageDetails @@ -1040,8 +1120,9 @@ addOneOcc usage id info emptyDetails :: UsageDetails emptyDetails = (emptyVarEnv :: UsageDetails) -usedIn :: Id -> UsageDetails -> Bool -v `usedIn` details = isExportedId v || v `elemVarEnv` details +localUsedIn, usedIn :: Id -> UsageDetails -> Bool +v `localUsedIn` details = v `elemVarEnv` details +v `usedIn` details = isExportedId v || v `localUsedIn` details type IdWithOccInfo = Id @@ -1099,8 +1180,7 @@ mkOneOcc _env id int_cxt markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo -markMany IAmDead = IAmDead -markMany _ = NoOccInfo +markMany _ = NoOccInfo markInsideSCC occ = markMany occ @@ -1109,19 +1189,18 @@ markInsideLam occ = occ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo -addOccInfo IAmDead info2 = info2 -addOccInfo info1 IAmDead = info1 -addOccInfo _ _ = NoOccInfo +addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + NoOccInfo -- Both branches are at least One + -- (Argument is never IAmDead) -- (orOccInfo orig new) is used -- when combining occurrence info from branches of a case -orOccInfo IAmDead info2 = info2 -orOccInfo info1 IAmDead = info1 orOccInfo (OneOcc in_lam1 _ int_cxt1) (OneOcc in_lam2 _ int_cxt2) = OneOcc (in_lam1 || in_lam2) False -- False, because it occurs in both branches (int_cxt1 && int_cxt2) -orOccInfo _ _ = NoOccInfo +orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + NoOccInfo \end{code} diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs index 70e0fa1..a2e06a0 100644 --- a/compiler/simplCore/SimplEnv.lhs +++ b/compiler/simplCore/SimplEnv.lhs @@ -271,9 +271,12 @@ addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) v -- _delete_ it from the substitution when going inside -- the (\x -> ...)! -modifyInScope :: SimplEnv -> CoreBndr -> CoreBndr -> SimplEnv -modifyInScope env@(SimplEnv {seInScope = in_scope}) v v' - = env {seInScope = modifyInScopeSet in_scope v v'} +modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv +-- The variable should already be in scope, but +-- replace the existing version with this new one +-- which has more information +modifyInScope env@(SimplEnv {seInScope = in_scope}) v + = env {seInScope = extendInScopeSet in_scope v} --------------------- zapSubstEnv :: SimplEnv -> SimplEnv @@ -440,20 +443,25 @@ floatBinds (Floats bs _) = fromOL bs %* * %************************************************************************ +Note [Global Ids in the substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We look up even a global (eg imported) Id in the substitution. Consider + case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } +The binder-swap in the occurence analyser will add a binding +for a LocalId version of g (with the same unique though): + case X.g_34 of b { (a,b) -> let g_34 = b in + ... case X.g_34 of { (p,q) -> ...} ... } +So we want to look up the inner X.g_34 in the substitution, where we'll +find that it has been substituted by b. (Or conceivably cloned.) \begin{code} substId :: SimplEnv -> InId -> SimplSR -- Returns DoneEx only on a non-Var expression substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v - | not (isLocalId v) - = DoneId v - | otherwise -- A local Id - = case lookupVarEnv ids v of + = case lookupVarEnv ids v of -- Note [Global Ids in the substitution] Nothing -> DoneId (refine in_scope v) Just (DoneId v) -> DoneId (refine in_scope v) - Just (DoneEx (Var v)) - | isLocalId v -> DoneId (refine in_scope v) - | otherwise -> DoneId v + Just (DoneEx (Var v)) -> DoneId (refine in_scope v) Just res -> res -- DoneEx non-var, or ContEx where @@ -461,9 +469,11 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v -- Even though it isn't in the substitution, it may be in -- the in-scope set with better IdInfo refine :: InScopeSet -> Var -> Var -refine in_scope v = case lookupInScope in_scope v of +refine in_scope v + | isLocalId v = case lookupInScope in_scope v of Just v' -> v' Nothing -> WARN( True, ppr v ) v -- This is an error! + | otherwise = v lookupRecBndr :: SimplEnv -> InId -> OutId -- Look up an Id which has been put into the envt by simplRecBndrs, @@ -519,7 +529,7 @@ simplLamBndr env bndr old_unf = idUnfolding bndr (env1, id1) = substIdBndr env bndr id2 = id1 `setIdUnfolding` substUnfolding env old_unf - env2 = modifyInScope env1 id1 id2 + env2 = modifyInScope env1 id2 --------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) @@ -644,7 +654,7 @@ addBndrRules :: SimplEnv -> InBndr -> OutBndr -> (SimplEnv, OutBndr) -- Rules are added back in to to the bin addBndrRules env in_id out_id | isEmptySpecInfo old_rules = (env, out_id) - | otherwise = (modifyInScope env out_id final_id, final_id) + | otherwise = (modifyInScope env final_id, final_id) where subst = mkCoreSubst env old_rules = idSpecialisation in_id diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 39bf3d8..14d11df 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -14,6 +14,7 @@ import Type hiding ( substTy, extendTvSubst ) import SimplEnv import SimplUtils import MkId ( rUNTIME_ERROR_ID ) +import FamInstEnv ( FamInstEnv ) import Id import Var import IdInfo @@ -365,6 +366,9 @@ simplNonRecX :: SimplEnv -> SimplM SimplEnv simplNonRecX env bndr new_rhs + | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p } + = return env -- Here b is dead, and we avoid creating + | otherwise -- the binding b = (a,b) = do { (env', bndr') <- simplBinder env bndr ; completeNonRecX env' (isStrictId bndr) bndr bndr' new_rhs } @@ -1191,7 +1195,91 @@ all this at once is TOO HARD! %* * %************************************************************************ -Blob of helper functions for the "case-of-something-else" situation. +Note [Case elimination] +~~~~~~~~~~~~~~~~~~~~~~~ +The case-elimination transformation discards redundant case expressions. +Start with a simple situation: + + case x# of ===> e[x#/y#] + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +The code in SimplUtils.prepareAlts has the effect of generalise this +idea to look for a case where we're scrutinising a variable, and we +know that only the default case can match. For example: + + case x of + 0# -> ... + DEFAULT -> ...(case x of + 0# -> ... + DEFAULT -> ...) ... + +Here the inner case is first trimmed to have only one alternative, the +DEFAULT, after which it's an instance of the previous case. This +really only shows up in eliminating error-checking code. + +We also make sure that we deal with this very common case: + + case e of + x -> ...x... + +Here we are using the case as a strict let; if x is used only once +then we want to inline it. We have to be careful that this doesn't +make the program terminate when it would have diverged before, so we +check that + - e is already evaluated (it may so if e is a variable) + - x is used strictly, or + +Lastly, the code in SimplUtils.mkCase combines identical RHSs. So + + case e of ===> case e of DEFAULT -> r + True -> r + False -> r + +Now again the case may be elminated by the CaseElim transformation. + + +Further notes about case elimination +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: test :: Integer -> IO () + test = print + +Turns out that this compiles to: + Print.test + = \ eta :: Integer + eta1 :: State# RealWorld -> + case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> + case hPutStr stdout + (PrelNum.jtos eta ($w[] @ Char)) + eta1 + of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + +Notice the strange '<' which has no effect at all. This is a funny one. +It started like this: + +f x y = if x < 0 then jtos x + else if y==0 then "" else jtos x + +At a particular call site we have (f v 1). So we inline to get + + if v < 0 then jtos x + else if 1==0 then "" else jtos x + +Now simplify the 1==0 conditional: + + if v<0 then jtos v else jtos v + +Now common-up the two branches of the case: + + case (v<0) of DEFAULT -> jtos v + +Why don't we drop the case? Because it's strict in v. It's technically +wrong to drop even unnecessary evaluations, and in practice they +may be a result of 'seq' so we *definitely* don't want to drop those. +I don't really know how to improve this situation. \begin{code} --------------------------------------------------------- @@ -1225,7 +1313,7 @@ rebuildCase env scrut case_bndr alts cont rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont -- See if we can get rid of the case altogether - -- See the extensive notes on case-elimination above + -- See Note [Case eliminiation] -- mkCase made sure that if all the alternatives are equal, -- then there is now only one (DEFAULT) rhs | all isDeadBinder bndrs -- bndrs are [InId] @@ -1301,78 +1389,15 @@ try to eliminate uses of v in the RHSs in favour of case_bndr; that way, there's a chance that v will now only be used once, and hence inlined. -Note [no-case-of-case] -~~~~~~~~~~~~~~~~~~~~~~ -We *used* to suppress the binder-swap in case expressoins when --fno-case-of-case is on. Old remarks: - "This happens in the first simplifier pass, - and enhances full laziness. Here's the bad case: - f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) - If we eliminate the inner case, we trap it inside the I# v -> arm, - which might prevent some full laziness happening. I've seen this - in action in spectral/cichelli/Prog.hs: - [(m,n) | m <- [1..max], n <- [1..max]] - Hence the check for NoCaseOfCase." -However, now the full-laziness pass itself reverses the binder-swap, so this -check is no longer necessary. - -Note [Suppressing the case binder-swap] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -There is another situation when it might make sense to suppress the -case-expression binde-swap. If we have - - case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } - ...other cases .... } - -We'll perform the binder-swap for the outer case, giving - - case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } - ...other cases .... } - -But there is no point in doing it for the inner case, because w1 can't -be inlined anyway. Furthermore, doing the case-swapping involves -zapping w2's occurrence info (see paragraphs that follow), and that -forces us to bind w2 when doing case merging. So we get - - case x of w1 { A -> let w2 = w1 in e1 - B -> let w2 = w1 in e2 - ...other cases .... } - -This is plain silly in the common case where w2 is dead. - -Even so, I can't see a good way to implement this idea. I tried -not doing the binder-swap if the scrutinee was already evaluated -but that failed big-time: - - data T = MkT !Int - - case v of w { MkT x -> - case x of x1 { I# y1 -> - case x of x2 { I# y2 -> ... - -Notice that because MkT is strict, x is marked "evaluated". But to -eliminate the last case, we must either make sure that x (as well as -x1) has unfolding MkT y1. THe straightforward thing to do is to do -the binder-swap. So this whole note is a no-op. +Historical note: we use to do the "case binder swap" in the Simplifier +so there were additional complications if the scrutinee was a variable. +Now the binder-swap stuff is done in the occurrence analyer; see +OccurAnal Note [Binder swap]. Note [zapOccInfo] ~~~~~~~~~~~~~~~~~ -If we replace the scrutinee, v, by tbe case binder, then we have to nuke -any occurrence info (eg IAmDead) in the case binder, because the -case-binder now effectively occurs whenever v does. AND we have to do -the same for the pattern-bound variables! Example: - - (case x of { (a,b) -> a }) (case x of { (p,q) -> q }) - -Here, b and p are dead. But when we move the argment inside the first -case RHS, and eliminate the second case, we get - - case x of { (a,b) -> a b } - -Urk! b is alive! Reason: the scrutinee was a variable, and case elimination -happened. - -Indeed, this can happen anytime the case binder isn't dead: +If the case binder is not dead, then neither are the pattern bound +variables: case of x { (a,b) -> case x of { (p,q) -> p } } Here (a,b) both look dead, but come alive after the inner case is eliminated. @@ -1381,15 +1406,6 @@ The point is that we bring into the envt a binding after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. -Note [Case of cast] -~~~~~~~~~~~~~~~~~~~ -Consider case (v `cast` co) of x { I# -> - ... (case (v `cast` co) of {...}) ... -We'd like to eliminate the inner case. We can get this neatly by -arranging that inside the outer case we add the unfolding - v |-> x `cast` (sym co) -to v. Then we should inline v at the inner case, cancel the casts, and away we go - Note [Improving seq] ~~~~~~~~~~~~~~~~~~~ Consider @@ -1420,121 +1436,78 @@ At one point I did transformation in LiberateCase, but it's more robust here. (Otherwise, there's a danger that we'll simply drop the 'seq' altogether, before LiberateCase gets to see it.) -Note [Case elimination] -~~~~~~~~~~~~~~~~~~~~~~~ -The case-elimination transformation discards redundant case expressions. -Start with a simple situation: - - case x# of ===> e[x#/y#] - y# -> e - -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -The code in SimplUtils.prepareAlts has the effect of generalise this -idea to look for a case where we're scrutinising a variable, and we -know that only the default case can match. For example: - - case x of - 0# -> ... - DEFAULT -> ...(case x of - 0# -> ... - DEFAULT -> ...) ... - -Here the inner case is first trimmed to have only one alternative, the -DEFAULT, after which it's an instance of the previous case. This -really only shows up in eliminating error-checking code. - -We also make sure that we deal with this very common case: - - case e of - x -> ...x... - -Here we are using the case as a strict let; if x is used only once -then we want to inline it. We have to be careful that this doesn't -make the program terminate when it would have diverged before, so we -check that - - e is already evaluated (it may so if e is a variable) - - x is used strictly, or - -Lastly, the code in SimplUtils.mkCase combines identical RHSs. So - - case e of ===> case e of DEFAULT -> r - True -> r - False -> r - -Now again the case may be elminated by the CaseElim transformation. +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressoins when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. -Further notes about case elimination -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider: test :: Integer -> IO () - test = print +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is another situation when it might make sense to suppress the +case-expression binde-swap. If we have -Turns out that this compiles to: - Print.test - = \ eta :: Integer - eta1 :: State# RealWorld -> - case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT -> - case hPutStr stdout - (PrelNum.jtos eta ($w[] @ Char)) - eta1 - of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }} + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } -Notice the strange '<' which has no effect at all. This is a funny one. -It started like this: +We'll perform the binder-swap for the outer case, giving -f x y = if x < 0 then jtos x - else if y==0 then "" else jtos x + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } -At a particular call site we have (f v 1). So we inline to get +But there is no point in doing it for the inner case, because w1 can't +be inlined anyway. Furthermore, doing the case-swapping involves +zapping w2's occurrence info (see paragraphs that follow), and that +forces us to bind w2 when doing case merging. So we get - if v < 0 then jtos x - else if 1==0 then "" else jtos x + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } -Now simplify the 1==0 conditional: +This is plain silly in the common case where w2 is dead. - if v<0 then jtos v else jtos v +Even so, I can't see a good way to implement this idea. I tried +not doing the binder-swap if the scrutinee was already evaluated +but that failed big-time: -Now common-up the two branches of the case: + data T = MkT !Int - case (v<0) of DEFAULT -> jtos v + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... -Why don't we drop the case? Because it's strict in v. It's technically -wrong to drop even unnecessary evaluations, and in practice they -may be a result of 'seq' so we *definitely* don't want to drop those. -I don't really know how to improve this situation. +Notice that because MkT is strict, x is marked "evaluated". But to +eliminate the last case, we must either make sure that x (as well as +x1) has unfolding MkT y1. THe straightforward thing to do is to do +the binder-swap. So this whole note is a no-op. \begin{code} -simplCaseBinder :: SimplEnv -> OutExpr -> OutId -> [InAlt] - -> SimplM (SimplEnv, OutExpr, OutId) -simplCaseBinder env0 scrut0 case_bndr0 alts - = do { (env1, case_bndr1) <- simplBinder env0 case_bndr0 - - ; fam_envs <- getFamEnvs - ; (env2, scrut2, case_bndr2) <- improve_seq fam_envs env1 scrut0 - case_bndr0 case_bndr1 alts - -- Note [Improving seq] - - ; let (env3, case_bndr3) = improve_case_bndr env2 scrut2 case_bndr2 - -- Note [Case of cast] - - ; return (env3, scrut2, case_bndr3) } - where - - improve_seq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) - = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) - env2 = extendIdSubst env case_bndr rhs - ; return (env2, scrut `Cast` co, case_bndr2) } - - improve_seq _ env scrut _ case_bndr1 _ - = return (env, scrut, case_bndr1) - - +improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv + -> OutExpr -> InId -> OutId -> [InAlt] + -> SimplM (SimplEnv, OutExpr, OutId) +-- Note [Improving seq] +improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] + | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) + = do { case_bndr2 <- newId (fsLit "nt") ty2 + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) + env2 = extendIdSubst env case_bndr rhs + ; return (env2, scrut `Cast` co, case_bndr2) } + +improveSeq _ env scrut _ case_bndr1 _ + = return (env, scrut, case_bndr1) + +{- improve_case_bndr env scrut case_bndr -- See Note [no-case-of-case] -- | switchIsOn (getSwitchChecker env) NoCaseOfCase @@ -1555,12 +1528,9 @@ simplCaseBinder env0 scrut0 case_bndr0 alts _ -> (env, case_bndr) where - case_bndr' = zapOccInfo case_bndr + case_bndr' = zapIdOccInfo case_bndr env1 = modifyInScope env case_bndr case_bndr' - - -zapOccInfo :: InId -> InId -- See Note [zapOccInfo] -zapOccInfo b = b `setIdOccInfo` NoOccInfo +-} \end{code} @@ -1616,10 +1586,15 @@ simplAlts :: SimplEnv simplAlts env scrut case_bndr alts cont' = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $ - do { let alt_env = zapFloats env - ; (alt_env', scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts + do { let env0 = zapFloats env + + ; (env1, case_bndr1) <- simplBinder env0 case_bndr + + ; fam_envs <- getFamEnvs + ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env1 scrut + case_bndr case_bndr1 alts - ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut case_bndr' alts + ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env' scrut' case_bndr' alts ; alts' <- mapM (simplAlt alt_env' imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } @@ -1685,6 +1660,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) evald_v = zapped_v `setIdUnfolding` evaldUnfolding go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr the_strs) + -- See Note [zapOccInfo] -- zap_occ_info: if the case binder is alive, then we add the unfolding -- case_bndr = C vs -- to the envt; so vs are now very much alive @@ -1693,15 +1669,15 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs) -- ==> case e of t { (a,b) -> ...(a)... } -- Look, Ma, a is alive now. zap_occ_info | isDeadBinder case_bndr' = \ident -> ident - | otherwise = zapOccInfo + | otherwise = zapIdOccInfo addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv addBinderUnfolding env bndr rhs - = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs) + = modifyInScope env (bndr `setIdUnfolding` mkUnfolding False rhs) addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv addBinderOtherCon env bndr cons - = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons) + = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons) \end{code} @@ -1770,8 +1746,7 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont -- args are aready OutExprs, but bs are InIds ; env'' <- simplNonRecX env' bndr bndr_rhs - ; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env'')) $ - simplExprF env'' rhs cont } + ; simplExprF env'' rhs cont } where -- Ugh! bind_args env' _ [] _ = return env' @@ -1782,7 +1757,7 @@ knownAlt env scrut the_args bndr (DataAlt dc, bs, rhs) cont bind_args env' dead_bndr (b:bs') (arg : args) = ASSERT( isId b ) - do { let b' = if dead_bndr then b else zapOccInfo b + do { let b' = if dead_bndr then b else zapIdOccInfo b -- Note that the binder might be "dead", because it doesn't -- occur in the RHS; and simplNonRecX may therefore discard -- it via postInlineUnconditionally. diff --git a/compiler/vectorise/VectCore.hs b/compiler/vectorise/VectCore.hs index de83279..c78f8ca 100644 --- a/compiler/vectorise/VectCore.hs +++ b/compiler/vectorise/VectCore.hs @@ -14,10 +14,10 @@ module VectCore ( #include "HsVersions.h" import CoreSyn +import MkCore ( mkWildCase ) import CoreUtils ( exprType ) import DataCon ( DataCon ) import Type ( Type ) -import Id ( mkWildId ) import Var type Vect a = (a,a) @@ -84,9 +84,9 @@ vCaseProd :: VExpr -> Type -> Type -> DataCon -> DataCon -> [Var] -> [VVar] -> VExpr -> VExpr vCaseProd (vscrut, lscrut) vty lty vdc ldc sh_bndrs bndrs (vbody,lbody) - = (Case vscrut (mkWildId $ exprType vscrut) vty + = (mkWildCase vscrut (exprType vscrut) vty [(DataAlt vdc, vbndrs, vbody)], - Case lscrut (mkWildId $ exprType lscrut) lty + mkWildCase lscrut (exprType lscrut) lty [(DataAlt ldc, sh_bndrs ++ lbndrs, lbody)]) where (vbndrs, lbndrs) = unzip bndrs diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs index ffb43bb..b4b3c43 100644 --- a/compiler/vectorise/VectType.hs +++ b/compiler/vectorise/VectType.hs @@ -12,6 +12,7 @@ import VectCore import HscTypes ( TypeEnv, extendTypeEnvList, typeEnvTyCons ) import CoreSyn import CoreUtils +import MkCore ( mkWildCase ) import BuildTyCl import DataCon import TyCon @@ -23,7 +24,6 @@ import OccName import MkId import BasicTypes ( StrictnessMark(..), boolToRecFlag ) import Var ( Var, TyVar ) -import Id ( mkWildId ) import Name ( Name, getOccName ) import NameEnv import TysWiredIn @@ -458,7 +458,7 @@ buildToPRepr repr vect_tc prepr_tc _ expr = do (vars, bodies) <- mapAndUnzipM to_unboxed prods - return . Case expr (mkWildId (exprType expr)) res_ty + return . mkWildCase expr (exprType expr) res_ty $ zipWith4 mk_alt cons vars (tyConDataCons tycon) bodies where mk_alt con vars sum_con body @@ -467,7 +467,7 @@ buildToPRepr repr vect_tc prepr_tc _ ty_args = map (Type . reprType) prods to_repr (EnumRepr { enum_data_con = data_con }) expr - = return . Case expr (mkWildId (exprType expr)) res_ty + = return . mkWildCase expr (exprType expr) res_ty $ map mk_alt cons where mk_alt con = (DataAlt con, [], mkConApp data_con [mkDataConTag con]) @@ -475,7 +475,7 @@ buildToPRepr repr vect_tc prepr_tc _ to_repr prod expr = do (vars, body) <- to_unboxed prod - return $ Case expr (mkWildId (exprType expr)) res_ty + return $ mkWildCase expr (exprType expr) res_ty [(DataAlt con, vars, body)] to_unboxed (ProdRepr { prod_components = tys @@ -518,7 +518,7 @@ buildFromPRepr repr vect_tc prepr_tc _ vars <- mapM (newLocalVar (fsLit "x")) (map reprType prods) bodies <- sequence . zipWith3 from_unboxed prods cons $ map Var vars - return . Case expr (mkWildId (reprType repr)) res_ty + return . mkWildCase expr (reprType repr) res_ty $ zipWith3 sum_alt (tyConDataCons tycon) vars bodies where sum_alt data_con var body = (DataAlt data_con, [var], body) @@ -527,11 +527,11 @@ buildFromPRepr repr vect_tc prepr_tc _ = do var <- newLocalVar (fsLit "n") intPrimTy - let res = Case (Var var) (mkWildId intPrimTy) res_ty + let res = mkWildCase (Var var) intPrimTy res_ty $ (DEFAULT, [], error_expr) : zipWith mk_alt (tyConDataCons vect_tc) cons - return $ Case expr (mkWildId (reprType repr)) res_ty + return $ mkWildCase expr (reprType repr) res_ty [(DataAlt data_con, [var], res)] where mk_alt data_con con = (LitAlt (mkDataConTagLit data_con), [], con) @@ -548,7 +548,7 @@ buildFromPRepr repr vect_tc prepr_tc _ expr = do vars <- mapM (newLocalVar (fsLit "y")) tys - return $ Case expr (mkWildId (reprType prod)) res_ty + return $ mkWildCase expr (reprType prod) res_ty [(DataAlt data_con, vars, con `mkVarApps` vars)] from_unboxed (IdRepr _) con expr @@ -583,7 +583,7 @@ buildToArrPRepr repr vect_tc prepr_tc arr_tc return . Lam arg . mkCoerce co - $ Case scrut (mkWildId (mkTyConApp arr_tc var_tys)) res_ty + $ mkWildCase scrut (mkTyConApp arr_tc var_tys) res_ty [(DataAlt arr_dc, shape_vars ++ concat repr_vars, result)] where var_tys = mkTyVarTys $ tyConTyVars vect_tc @@ -683,7 +683,7 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc result <- go prods repr_vars vars body let scrut = unwrapFamInstScrut tycon ty_args expr - return . Case scrut (mkWildId scrut_ty) res_ty + return . mkWildCase scrut scrut_ty res_ty $ [(DataAlt data_con, shape_vars ++ vars, result)] where ty_args = map reprType prods @@ -715,7 +715,7 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc let scrut = unwrapFamInstScrut tycon tys expr scrut_ty = mkTyConApp tycon tys - return $ Case scrut (mkWildId scrut_ty) res_ty + return $ mkWildCase scrut scrut_ty res_ty [(DataAlt data_con, shape_vars ++ repr_vars, body)] from_prod (EnumRepr { enum_arr_tycon = tycon @@ -728,7 +728,7 @@ buildFromArrPRepr repr vect_tc prepr_tc arr_tc = let scrut = unwrapFamInstScrut tycon [] expr scrut_ty = mkTyConApp tycon [] in - return $ Case scrut (mkWildId scrut_ty) res_ty + return $ mkWildCase scrut scrut_ty res_ty [(DataAlt data_con, shape_vars, body)] from_prod (IdRepr _) diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs index 3bf97fa..6a8f893 100644 --- a/compiler/vectorise/VectUtils.hs +++ b/compiler/vectorise/VectUtils.hs @@ -30,7 +30,6 @@ import TypeRep import TyCon import DataCon import Var -import Id ( mkWildId ) import MkId ( unwrapFamInstScrut ) import TysWiredIn import BasicTypes ( Boxity(..) ) @@ -430,7 +429,7 @@ mkVectEnv :: [Type] -> [Var] -> (Type, CoreExpr, CoreExpr -> CoreExpr -> CoreExp mkVectEnv [] [] = (unitTy, Var unitDataConId, \_ body -> body) mkVectEnv [ty] [v] = (ty, Var v, \env body -> Let (NonRec v env) body) mkVectEnv tys vs = (ty, mkCoreTup (map Var vs), - \env body -> Case env (mkWildId ty) (exprType body) + \env body -> mkWildCase env ty (exprType body) [(DataAlt (tupleCon Boxed (length vs)), vs, body)]) where ty = mkCoreTupTy tys @@ -460,7 +459,7 @@ mkLiftEnv lc tys vs bind env body = let scrut = unwrapFamInstScrut env_tc env_tyargs env in - return $ Case scrut (mkWildId (exprType scrut)) + return $ mkWildCase scrut (exprType scrut) (exprType body) [(DataAlt env_con, lc : bndrs, body)] return (env, bind) -- 1.7.10.4