Commit 7e8cba32 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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
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 (
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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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))
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)])
......
......@@ -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
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~
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)
......
......@@ -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!]
......
......@@ -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))