Commit 7e8cba32 authored by's avatar

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

     - 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
parent bb924bdd
......@@ -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 (
-- ** 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 (
setIdOccInfo, zapIdOccInfo,
......@@ -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)
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.
-- | 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
......@@ -27,7 +27,6 @@ module VarEnv (
-- ** Operations on InScopeSets
emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
-- * The RnEnv2 type
......@@ -66,7 +65,18 @@ import FastString
-- | 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
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
......@@ -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 ()
......@@ -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)
is_case_pat (CasePat {} : _) = True
is_case_pat _other = False
addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars vars m
| null dups
......@@ -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) ]
......@@ -4,7 +4,7 @@ module MkCore (
-- * Constructing normal syntax
mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps,
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)]
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))]
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) ]
Note [Desugaring seq (1)] cf Trac #1031
......@@ -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]
......@@ -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)
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)
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
ppr tyvar
pprKindedTyVarBndr :: TyVar -> SDoc
-- Print a type variable binder with its kind (but not if *)
pprKindedTyVarBndr tyvar
= ptext (sLit "@") <+> ppr tyvar <> opt_kind
opt_kind -- Print the kind if not *
| isLiftedTypeKind kind = empty
| otherwise = dcolon <> pprKind kind
kind = tyVarKind tyvar
-- pprIdBndr does *not* print the type
......@@ -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.
......@@ -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))
(coreAltType 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)
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
(coreAltType the_alt)
wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
(coreAltType the_alt)
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
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
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)])
......@@ -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])
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))
wild = mkWildId intPrimTy
dft = (DEFAULT, [], fail)
-- each alternative matches one array length (corresponding to one
......@@ -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
......@@ -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]
......@@ -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]
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]
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)
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)]
(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
(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)
......@@ -18,7 +18,6 @@ import UniqSupply ( UniqSupply )
import SimplMonad ( SimplCount, zeroSimplCount )
import Id
import VarEnv
import Name ( localiseName )
import Util ( notNull )
......@@ -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!]
......@@ -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') ->
alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
alts_usage' = addCaseBndrUsage alts_usage
......@@ -779,6 +780,8 @@ occAnal env (Case scrut bndr ty alts)
total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
-- 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
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]
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).
occAnalAlt :: OccEnv
-> CoreBndr
-> Maybe (Id, CoreExpr) -- Note [Binder swap]
-> CoreAlt
-> (UsageDetails, Alt IdWithOccInfo)