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 ( ...@@ -29,7 +29,7 @@ module Id (
mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
mkLocalId, mkLocalIdWithInfo, mkLocalId, mkLocalIdWithInfo,
mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM, mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal, mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
mkWorkerId, mkExportedLocalId, mkWorkerId, mkExportedLocalId,
-- ** Taking an Id apart -- ** Taking an Id apart
...@@ -38,9 +38,12 @@ module Id ( ...@@ -38,9 +38,12 @@ module Id (
recordSelectorFieldLabel, recordSelectorFieldLabel,
-- ** Modifying an Id -- ** Modifying an Id
setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, setIdName, setIdUnique, Id.setIdType,
globaliseId, setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, setIdExported, setIdNotExported,
globaliseId, localiseId,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo, zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
-- ** Predicates on Ids -- ** Predicates on Ids
isImplicitId, isDeadBinder, isDictId, isStrictId, isImplicitId, isDeadBinder, isDictId, isStrictId,
...@@ -86,7 +89,7 @@ module Id ( ...@@ -86,7 +89,7 @@ module Id (
setIdWorkerInfo, setIdWorkerInfo,
setIdSpecialisation, setIdSpecialisation,
setIdCafInfo, setIdCafInfo,
setIdOccInfo, setIdOccInfo, zapIdOccInfo,
#ifdef OLD_STRICTNESS #ifdef OLD_STRICTNESS
setIdStrictness, setIdStrictness,
...@@ -185,6 +188,17 @@ setIdExported = setIdVarExported ...@@ -185,6 +188,17 @@ setIdExported = setIdVarExported
setIdNotExported :: Id -> Id setIdNotExported :: Id -> Id
setIdNotExported = setIdVarNotExported 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 :: GlobalIdDetails -> Id -> Id
globaliseId = globaliseIdVar globaliseId = globaliseIdVar
...@@ -274,10 +288,6 @@ Make some local @Ids@ for a template @CoreExpr@. These have bogus ...@@ -274,10 +288,6 @@ Make some local @Ids@ for a template @CoreExpr@. These have bogus
instantiated before use. instantiated before use.
\begin{code} \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 -- | Workers get local names. "CoreTidy" will externalise these if necessary
mkWorkerId :: Unique -> Id -> Type -> Id mkWorkerId :: Unique -> Id -> Type -> Id
mkWorkerId uniq unwrkr ty mkWorkerId uniq unwrkr ty
...@@ -603,6 +613,9 @@ idOccInfo id = occInfo (idInfo id) ...@@ -603,6 +613,9 @@ idOccInfo id = occInfo (idInfo id)
setIdOccInfo :: Id -> OccInfo -> Id setIdOccInfo :: Id -> OccInfo -> Id
setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
zapIdOccInfo :: Id -> Id
zapIdOccInfo b = b `setIdOccInfo` NoOccInfo
\end{code} \end{code}
......
...@@ -27,7 +27,6 @@ module VarEnv ( ...@@ -27,7 +27,6 @@ module VarEnv (
-- ** Operations on InScopeSets -- ** Operations on InScopeSets
emptyInScopeSet, mkInScopeSet, delInScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
modifyInScopeSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
-- * The RnEnv2 type -- * The RnEnv2 type
...@@ -66,7 +65,18 @@ import FastString ...@@ -66,7 +65,18 @@ import FastString
\begin{code} \begin{code}
-- | A set of variables that are in scope at some point -- | A set of variables that are in scope at some point
data InScopeSet = InScope (VarEnv Var) FastInt 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 -- For example, it might be the size of the set
-- INVARIANT: it's not zero; we use it as a multiplier in uniqAway -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway
...@@ -94,37 +104,16 @@ extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet ...@@ -94,37 +104,16 @@ extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
extendInScopeSetSet (InScope in_scope n) vs extendInScopeSetSet (InScope in_scope n) vs
= InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM 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 :: InScopeSet -> Var -> InScopeSet
delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarEnv` v) n
elemInScopeSet :: Var -> InScopeSet -> Bool elemInScopeSet :: Var -> InScopeSet -> Bool
elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope 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 -- | Look up a variable the 'InScopeSet'. This lets you map from
-- of any 'modifyInScopeSet' operation, returns that variable with all appropriate modifications -- the variable's identity (unique) to its full value.
-- applied to it. Otherwise, return @Nothing@
lookupInScope :: InScopeSet -> Var -> Maybe Var lookupInScope :: InScopeSet -> Var -> Maybe Var
-- It's important to look for a fixed point lookupInScope (InScope in_scope _) v = lookupVarEnv in_scope v
-- 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
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -256,6 +256,8 @@ lintCoreExpr :: CoreExpr -> LintM OutType ...@@ -256,6 +256,8 @@ lintCoreExpr :: CoreExpr -> LintM OutType
lintCoreExpr (Var var) lintCoreExpr (Var var)
= do { checkL (not (var == oneTupleDataConId)) = do { checkL (not (var == oneTupleDataConId))
(ptext (sLit "Illegal one-tuple")) (ptext (sLit "Illegal one-tuple"))
; checkDeadIdOcc var
; var' <- lookupIdInScope var ; var' <- lookupIdInScope var
; return (idType var') ; return (idType var')
} }
...@@ -422,6 +424,17 @@ checkKinds tyvar arg_ty ...@@ -422,6 +424,17 @@ checkKinds tyvar arg_ty
tyvar_kind = tyVarKind tyvar tyvar_kind = tyVarKind tyvar
arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty arg_kind | isCoVar tyvar = coercionKindPredTy arg_ty
| otherwise = typeKind 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} \end{code}
...@@ -666,6 +679,12 @@ addLoc :: LintLocInfo -> LintM a -> LintM a ...@@ -666,6 +679,12 @@ addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m = addLoc extra_loc m =
LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs) 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 :: [Var] -> LintM a -> LintM a
addInScopeVars vars m addInScopeVars vars m
| null dups | null dups
......
...@@ -18,7 +18,7 @@ module CoreUtils ( ...@@ -18,7 +18,7 @@ module CoreUtils (
-- * Constructing expressions -- * Constructing expressions
mkInlineMe, mkSCC, mkCoerce, mkCoerceI, mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
bindNonRec, needsCaseBinding, bindNonRec, needsCaseBinding,
mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes, mkAltExpr, mkPiType, mkPiTypes,
-- * Taking expressions apart -- * Taking expressions apart
findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs, findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
...@@ -71,7 +71,6 @@ import NewDemand ...@@ -71,7 +71,6 @@ import NewDemand
import Type import Type
import Coercion import Coercion
import TyCon import TyCon
import TysWiredIn
import CostCentre import CostCentre
import BasicTypes import BasicTypes
import Unique import Unique
...@@ -298,13 +297,6 @@ mkAltExpr (LitAlt lit) [] [] ...@@ -298,13 +297,6 @@ mkAltExpr (LitAlt lit) [] []
= Lit lit = Lit lit
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" 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} \end{code}
......
...@@ -4,7 +4,7 @@ module MkCore ( ...@@ -4,7 +4,7 @@ module MkCore (
-- * Constructing normal syntax -- * Constructing normal syntax
mkCoreLet, mkCoreLets, mkCoreLet, mkCoreLets,
mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreApp, mkCoreApps, mkCoreConApps,
mkCoreLams, mkCoreLams, mkWildCase, mkIfThenElse,
-- * Constructing boxed literals -- * Constructing boxed literals
mkWordExpr, mkWordExprWord, mkWordExpr, mkWordExprWord,
...@@ -48,7 +48,6 @@ import HscTypes ...@@ -48,7 +48,6 @@ import HscTypes
import TysWiredIn import TysWiredIn
import PrelNames import PrelNames
import MkId ( seqId )
import Type import Type
import TypeRep import TypeRep
...@@ -57,6 +56,7 @@ import DataCon ( DataCon, dataConWorkId ) ...@@ -57,6 +56,7 @@ import DataCon ( DataCon, dataConWorkId )
import FastString import FastString
import UniqSupply import UniqSupply
import Unique ( mkBuiltinUnique )
import BasicTypes import BasicTypes
import Util ( notNull, zipEqual ) import Util ( notNull, zipEqual )
import Panic import Panic
...@@ -121,22 +121,50 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args ...@@ -121,22 +121,50 @@ mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args
----------- -----------
mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr
mk_val_app (Var f `App` Type ty1 `App` Type _ `App` arg1) arg2 _ res_ty 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 arg1 case_bndr res_ty [(DEFAULT,[],arg2)]
where where
case_bndr = case arg1 of case_bndr = case arg1 of
Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] 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] mk_val_app fun arg arg_ty _ -- See Note [CoreSyn let/app invariant]
| not (needsCaseBinding arg_ty arg) | not (needsCaseBinding arg_ty arg)
= App fun arg -- The vastly common case = App fun arg -- The vastly common case
mk_val_app fun arg arg_ty res_ty 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 where
arg_id = mkWildId arg_ty -- Lots of shadowing, but it doesn't matter, arg_id = mkWildBinder arg_ty
-- because 'fun ' should not have a free wild-id -- 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} \end{code}
Note [Desugaring seq (1)] cf Trac #1031 Note [Desugaring seq (1)] cf Trac #1031
......
...@@ -248,7 +248,7 @@ instance OutputableBndr Var where ...@@ -248,7 +248,7 @@ instance OutputableBndr Var where
pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder :: BindingSite -> Var -> SDoc
pprCoreBinder LetBind binder pprCoreBinder LetBind binder
| isTyVar binder = pprTypedBinder binder | isTyVar binder = pprKindedTyVarBndr binder
| otherwise | otherwise
= vcat [sig, pprIdDetails binder, pragmas] = vcat [sig, pprIdDetails binder, pragmas]
where where
...@@ -256,7 +256,15 @@ pprCoreBinder LetBind binder ...@@ -256,7 +256,15 @@ pprCoreBinder LetBind binder
pragmas = ppIdInfo binder (idInfo binder) pragmas = ppIdInfo binder (idInfo binder)
-- Lambda bound type variables are preceded by "@" -- 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 -- Case bound things don't get a signature or a herald, unless we have debug on
pprCoreBinder CaseBind bndr pprCoreBinder CaseBind bndr
...@@ -264,7 +272,8 @@ pprCoreBinder CaseBind bndr ...@@ -264,7 +272,8 @@ pprCoreBinder CaseBind bndr
if debugStyle sty then if debugStyle sty then
parens (pprTypedBinder bndr) parens (pprTypedBinder bndr)
else else
pprUntypedBinder bndr if isDeadBinder bndr then char '_'
else pprUntypedBinder bndr
pprUntypedBinder :: Var -> SDoc pprUntypedBinder :: Var -> SDoc
pprUntypedBinder binder pprUntypedBinder binder
...@@ -272,19 +281,19 @@ pprUntypedBinder binder ...@@ -272,19 +281,19 @@ pprUntypedBinder binder
| otherwise = pprIdBndr binder | otherwise = pprIdBndr binder
pprTypedBinder :: Var -> SDoc pprTypedBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedBinder binder pprTypedBinder binder
| isTyVar binder = ptext (sLit "@") <+> pprTyVarBndr binder | isTyVar binder = pprKindedTyVarBndr binder
| otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder) | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder)
pprTyVarBndr :: TyVar -> SDoc pprKindedTyVarBndr :: TyVar -> SDoc
pprTyVarBndr tyvar -- Print a type variable binder with its kind (but not if *)
= getPprStyle $ \ sty -> pprKindedTyVarBndr tyvar
if debugStyle sty then = ptext (sLit "@") <+> ppr tyvar <> opt_kind
hsep [ppr tyvar, dcolon, pprParendKind kind]
-- See comments with ppDcolon in PprCore.lhs
else
ppr tyvar
where where
opt_kind -- Print the kind if not *
| isLiftedTypeKind kind = empty
| otherwise = dcolon <> pprKind kind
kind = tyVarKind tyvar kind = tyVarKind tyvar
-- pprIdBndr does *not* print the type -- pprIdBndr does *not* print the type
......
...@@ -36,7 +36,6 @@ import TcType ...@@ -36,7 +36,6 @@ import TcType
import CostCentre import CostCentre
import Module import Module
import Id import Id
import Name ( localiseName )
import Var ( Var, TyVar ) import Var ( Var, TyVar )
import VarSet import VarSet
import Rules import Rules
...@@ -352,7 +351,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind ...@@ -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 spec_rhs = Let (NonRec local_poly poly_f_body) ds_spec_expr
poly_f_body = mkLams (tvs ++ dicts) f_body 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) | d <- varSetElems (exprFreeVars ds_spec_expr)
, isDictId d] , isDictId d]
-- Note [Const rule dicts] -- Note [Const rule dicts]
...@@ -380,9 +379,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind ...@@ -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")) decomp_msg = hang (ptext (sLit "Specialisation too complicated to desugar; ignored"))
2 (ppr spec_expr) 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) mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> DsM (TyVarEnv Type)
-- If any of the tyvars is missing from any of the lists in -- If any of the tyvars is missing from any of the lists in
...@@ -443,7 +440,7 @@ And from that we want the rule ...@@ -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 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 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 ...@@ -22,6 +22,7 @@ import CoreSyn
import DsMonad import DsMonad
import CoreUtils import CoreUtils
import MkCore
import Var import Var
import Id import Id
import MkId import MkId
...@@ -142,7 +143,7 @@ unboxArg arg ...@@ -142,7 +143,7 @@ unboxArg arg
tc `hasKey` boolTyConKey tc `hasKey` boolTyConKey
= do prim_arg <- newSysLocalDs intPrimTy = do prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg, return (Var prim_arg,
\ body -> Case (Case arg (mkWildId arg_ty) intPrimTy \ body -> Case (mkWildCase arg arg_ty intPrimTy
[(DataAlt falseDataCon,[],mkIntLit 0), [(DataAlt falseDataCon,[],mkIntLit 0),
(DataAlt trueDataCon, [],mkIntLit 1)]) (DataAlt trueDataCon, [],mkIntLit 1)])
-- In increasing tag order! -- In increasing tag order!
...@@ -284,8 +285,8 @@ boxResult augment mbTopCon result_ty ...@@ -284,8 +285,8 @@ boxResult augment mbTopCon result_ty
mkApps (Var toIOCon) mkApps (Var toIOCon)
[ Type io_res_ty, [ Type io_res_ty,
Lam state_id $ Lam state_id $
Case (App the_call (Var state_id)) mkWildCase (App the_call (Var state_id))
(mkWildId ccall_res_ty) ccall_res_ty
(coreAltType the_alt) (coreAltType the_alt)
[the_alt] [the_alt]
] ]
...@@ -298,10 +299,10 @@ boxResult augment _mbTopCon result_ty ...@@ -298,10 +299,10 @@ boxResult augment _mbTopCon result_ty
res <- resultWrapper result_ty res <- resultWrapper result_ty
(ccall_res_ty, the_alt) <- mk_alt return_result (augment res) (ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
let let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId)) wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty) ccall_res_ty
(coreAltType the_alt) (coreAltType the_alt)
[the_alt] [the_alt]
return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where where
return_result _ [ans] = ans return_result _ [ans] = ans
...@@ -371,7 +372,7 @@ resultWrapper result_ty ...@@ -371,7 +372,7 @@ resultWrapper result_ty
-- Base case 3: the boolean type -- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= return = return
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy) (Just intPrimTy, \e -> mkWildCase e intPrimTy
boolTy boolTy
[(DEFAULT ,[],Var trueDataConId ), [(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt 0),[],Var falseDataConId)]) (LitAlt (mkMachInt 0),[],Var falseDataConId)])
......
...@@ -301,11 +301,10 @@ mkCoAlgCaseMatchResult var ty match_alts ...@@ -301,11 +301,10 @@ mkCoAlgCaseMatchResult var ty match_alts
| otherwise | otherwise
= CanFail = CanFail
wild_var = mkWildId (idType var)
sorted_alts = sortWith get_tag match_alts sorted_alts = sortWith get_tag match_alts
get_tag (con, _, _) = dataConTag con get_tag (con, _, _) = dataConTag con
mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts 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 mk_alt fail (con, args, MatchResult _ body_fn) = do
body <- body_fn fail body <- body_fn fail
...@@ -352,7 +351,7 @@ mkCoAlgCaseMatchResult var ty match_alts ...@@ -352,7 +351,7 @@ mkCoAlgCaseMatchResult var ty match_alts
mk_parrCase fail = do mk_parrCase fail = do
lengthP <- dsLookupGlobalId lengthPName lengthP <- dsLookupGlobalId lengthPName
alt <- unboxAlt alt <- unboxAlt
return (Case (len lengthP) (mkWildId intTy) ty [alt]) return (mkWildCase (len lengthP) intTy ty [alt])
where where
elemTy = case splitTyConApp (idType var) of elemTy = case splitTyConApp (idType var) of
(_, [elemTy]) -> elemTy (_, [elemTy]) -> elemTy
...@@ -364,9 +363,8 @@ mkCoAlgCaseMatchResult var ty match_alts ...@@ -364,9 +363,8 @@ mkCoAlgCaseMatchResult var ty match_alts
l <- newSysLocalDs intPrimTy l <- newSysLocalDs intPrimTy
indexP <- dsLookupGlobalId indexPName indexP <- dsLookupGlobalId indexPName
alts <- mapM (mkAlt indexP) sorted_alts