Tidy up the treatment of dead binders
authorsimonpj@microsoft.com <unknown>
Sat, 20 Sep 2008 17:52:38 +0000 (17:52 +0000)
committersimonpj@microsoft.com <unknown>
Sat, 20 Sep 2008 17:52:38 +0000 (17:52 +0000)
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

18 files changed:
compiler/basicTypes/Id.lhs
compiler/basicTypes/VarEnv.lhs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/MkCore.lhs
compiler/coreSyn/PprCore.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsUtils.lhs
compiler/prelude/PrelRules.lhs
compiler/simplCore/CSE.lhs
compiler/simplCore/LiberateCase.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SimplEnv.lhs
compiler/simplCore/Simplify.lhs
compiler/vectorise/VectCore.hs
compiler/vectorise/VectType.hs
compiler/vectorise/VectUtils.hs

index 154275b..d87e45b 100644 (file)
@@ -29,7 +29,7 @@ module Id (
        mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
        mkLocalId, mkLocalIdWithInfo,
        mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
        mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
        mkLocalId, mkLocalIdWithInfo,
        mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
-       mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
+       mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
        mkWorkerId, mkExportedLocalId,
 
        -- ** Taking an Id apart
        mkWorkerId, mkExportedLocalId,
 
        -- ** Taking an Id apart
@@ -38,9 +38,12 @@ module Id (
        recordSelectorFieldLabel,
 
        -- ** Modifying an 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,
        zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
+       
 
        -- ** Predicates on Ids
        isImplicitId, isDeadBinder, isDictId, isStrictId,
 
        -- ** Predicates on Ids
        isImplicitId, isDeadBinder, isDictId, isStrictId,
@@ -86,7 +89,7 @@ module Id (
        setIdWorkerInfo,
        setIdSpecialisation,
        setIdCafInfo,
        setIdWorkerInfo,
        setIdSpecialisation,
        setIdCafInfo,
-       setIdOccInfo,
+       setIdOccInfo, zapIdOccInfo,
 
 #ifdef OLD_STRICTNESS
        setIdStrictness, 
 
 #ifdef OLD_STRICTNESS
        setIdStrictness, 
@@ -185,6 +188,17 @@ setIdExported = setIdVarExported
 setIdNotExported :: Id -> Id
 setIdNotExported = setIdVarNotExported
 
 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
 
 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}
 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
 -- | 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
 
 setIdOccInfo :: Id -> OccInfo -> Id
 setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id
+
+zapIdOccInfo :: Id -> Id
+zapIdOccInfo b = b `setIdOccInfo` NoOccInfo
 \end{code}
 
 
 \end{code}
 
 
index 4bb00cf..7e28d1a 100644 (file)
@@ -27,7 +27,6 @@ module VarEnv (
        -- ** Operations on InScopeSets
        emptyInScopeSet, mkInScopeSet, delInScopeSet,
        extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
        -- ** Operations on InScopeSets
        emptyInScopeSet, mkInScopeSet, delInScopeSet,
        extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
-       modifyInScopeSet,
        getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, 
 
        -- * The RnEnv2 type
        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
 \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
 
        -- 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))
 
 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
 
 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
 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}
 \end{code}
 
 \begin{code}
index ffccf6f..2b2a6e8 100644 (file)
@@ -256,6 +256,8 @@ lintCoreExpr :: CoreExpr -> LintM OutType
 lintCoreExpr (Var var)
   = do { checkL (not (var == oneTupleDataConId))
                 (ptext (sLit "Illegal one-tuple"))
 lintCoreExpr (Var var)
   = do { checkL (not (var == oneTupleDataConId))
                 (ptext (sLit "Illegal one-tuple"))
+
+       ; checkDeadIdOcc var
        ; var' <- lookupIdInScope var
         ; return (idType 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
     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}
 
 
 \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)
 
 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
 addInScopeVars :: [Var] -> LintM a -> LintM a
 addInScopeVars vars m
   | null dups
index 07709c8..eb9ea41 100644 (file)
@@ -18,7 +18,7 @@ module CoreUtils (
        -- * Constructing expressions
        mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
        bindNonRec, needsCaseBinding,
        -- * Constructing expressions
        mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
        bindNonRec, needsCaseBinding,
-       mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
+       mkAltExpr, mkPiType, mkPiTypes,
 
        -- * Taking expressions apart
        findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
 
        -- * Taking expressions apart
        findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
@@ -71,7 +71,6 @@ import NewDemand
 import Type
 import Coercion
 import TyCon
 import Type
 import Coercion
 import TyCon
-import TysWiredIn
 import CostCentre
 import BasicTypes
 import Unique
 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"
   = 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}
 
 
 \end{code}
 
 
index acb189f..e771137 100644 (file)
@@ -4,7 +4,7 @@ module MkCore (
         -- * Constructing normal syntax
         mkCoreLet, mkCoreLets,
         mkCoreApp, mkCoreApps, mkCoreConApps,
         -- * Constructing normal syntax
         mkCoreLet, mkCoreLets,
         mkCoreApp, mkCoreApps, mkCoreConApps,
-        mkCoreLams,
+        mkCoreLams, mkWildCase, mkIfThenElse,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -48,7 +48,6 @@ import HscTypes
 
 import TysWiredIn
 import PrelNames
 
 import TysWiredIn
 import PrelNames
-import MkId             ( seqId )
 
 import Type
 import TypeRep
 
 import Type
 import TypeRep
@@ -57,6 +56,7 @@ import DataCon          ( DataCon, dataConWorkId )
 
 import FastString
 import UniqSupply
 
 import FastString
 import UniqSupply
+import Unique          ( mkBuiltinUnique )
 import BasicTypes
 import Util             ( notNull, zipEqual )
 import Panic
 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
 -----------
 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)]
   = 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
 
 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
   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
 \end{code}
 
 Note [Desugaring seq (1)]  cf Trac #1031
index 39d5b35..d641a9e 100644 (file)
@@ -248,7 +248,7 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyVar binder = pprTypedBinder binder
+  | isTyVar binder = pprKindedTyVarBndr binder
   | otherwise
   = vcat [sig, pprIdDetails binder, pragmas]
   where
   | 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 "@"
     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 
 
 -- 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
     if debugStyle sty then
        parens (pprTypedBinder bndr)
     else
-       pprUntypedBinder bndr
+       if isDeadBinder bndr then char '_'
+       else pprUntypedBinder bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
@@ -272,19 +281,19 @@ pprUntypedBinder binder
   | otherwise      = pprIdBndr binder
 
 pprTypedBinder :: Var -> SDoc
   | otherwise      = pprIdBndr binder
 
 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
-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
   where
+    opt_kind   -- Print the kind if not *
+       | isLiftedTypeKind kind = empty
+       | otherwise = dcolon <> pprKind kind
     kind = tyVarKind tyvar
 
 -- pprIdBndr does *not* print the type
     kind = tyVarKind tyvar
 
 -- pprIdBndr does *not* print the type
index a47551e..020b7b4 100644 (file)
@@ -36,7 +36,6 @@ import TcType
 import CostCentre
 import Module
 import Id
 import CostCentre
 import Module
 import Id
-import Name    ( localiseName )
 import Var     ( Var, TyVar )
 import VarSet
 import Rules
 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
                                
                  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]
                                     | 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)
 
     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 
 
 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
 
 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.
 
 
 %************************************************************************
 
 
 %************************************************************************
index a94ab42..2034e37 100644 (file)
@@ -22,6 +22,7 @@ import CoreSyn
 import DsMonad
 
 import CoreUtils
 import DsMonad
 
 import CoreUtils
+import MkCore
 import Var
 import Id
 import MkId
 import Var
 import Id
 import MkId
@@ -142,7 +143,7 @@ unboxArg arg
     tc `hasKey` boolTyConKey
   = do prim_arg <- newSysLocalDs intPrimTy
        return (Var prim_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!
                                        [(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 $
                              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]
                                     ]
                                             (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
        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
        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
   -- 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)])
                                    boolTy
                                    [(DEFAULT             ,[],Var trueDataConId ),
                                     (LitAlt (mkMachInt 0),[],Var falseDataConId)])
index 24579df..f2609b7 100644 (file)
@@ -301,11 +301,10 @@ mkCoAlgCaseMatchResult var ty match_alts
              | otherwise
              = CanFail
 
              | 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
     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
 
     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
     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
       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
          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
           where
-           wild = mkWildId intPrimTy
            dft  = (DEFAULT, [], fail)
        --
        -- each alternative matches one array length (corresponding to one
            dft  = (DEFAULT, [], fail)
        --
        -- each alternative matches one array length (corresponding to one
index bacd1bc..67eb06f 100644 (file)
@@ -20,7 +20,8 @@ module PrelRules ( primOpRules, builtinRules ) where
 #include "HsVersions.h"
 
 import CoreSyn
 #include "HsVersions.h"
 
 import CoreSyn
-import Id              ( mkWildId, idUnfolding )
+import MkCore          ( mkWildCase )
+import Id              ( idUnfolding )
 import Literal         ( Literal(..), mkMachInt, mkMachWord
                        , literalType
                        , word2IntLit, int2WordLit
 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
     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
                    [(DEFAULT,    [], val_if_neq),
                     (LitAlt lit, [], val_if_eq)])
     val_if_eq  | is_eq     = trueVal
index 495ea42..1386197 100644 (file)
@@ -11,7 +11,7 @@ module CSE (
 #include "HsVersions.h"
 
 import DynFlags        ( DynFlag(..), DynFlags )
 #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 )
 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.)
 
 
 (In fact, I think the simplifier does guarantee no-shadowing for type variables.)
 
 
-[Note: case binders 1]
+Note [Case binders 1]
 ~~~~~~~~~~~~~~~~~~~~~~
 Consider
 
 ~~~~~~~~~~~~~~~~~~~~~~
 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
 
 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)...
 ~~~~~~~~~~~~~~~~~~~~~~
 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
 
        case binder -> scrutinee 
 to the substitution
 
-[Note: unboxed tuple case binders]
+Note [Unboxed tuple case binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
        case f x of t { (# a,b #) -> 
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 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)
                                     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
                                   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
 
 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
   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
     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
 
 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'
 
                                                                -- 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)
                                                                        -- map: scrut' -> bndr'
 
     arg_tys = tyConAppArgs (idType bndr)
index ab79239..9fe6b87 100644 (file)
@@ -18,7 +18,6 @@ import UniqSupply     ( UniqSupply )
 import SimplMonad      ( SimplCount, zeroSimplCount )
 import Id
 import VarEnv
 import SimplMonad      ( SimplCount, zeroSimplCount )
 import Id
 import VarEnv
-import Name            ( localiseName )
 import Util             ( notNull )
 \end{code}
 
 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!
        --
        -- 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 ]
 
                                   | (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
        -- (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.
        -- (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!]
 
     rhs_small_enough (id,rhs)
        =  idArity id > 0       -- Note [Only functions!]
index 2b2c058..58f72cb 100644 (file)
@@ -20,6 +20,7 @@ module OccurAnal (
 import CoreSyn
 import CoreFVs
 import CoreUtils        ( exprIsTrivial, isDefaultAlt )
 import CoreSyn
 import CoreFVs
 import CoreUtils        ( exprIsTrivial, isDefaultAlt )
+import Coercion                ( mkSymCoercion )
 import Id
 import IdInfo
 import BasicTypes
 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)
     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
     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
     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.
         -- 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
         -- 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
 
 
     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)
     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') ->
 
 occAnal env (Let bind body)
   = case occAnal env body                of { (body_usage, body') ->
@@ -900,38 +912,104 @@ appSpecial env n ctxt args
 \end{code}
 
 
 \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
 
 \begin{code}
 occAnalAlt :: OccEnv
            -> CoreBndr
+          -> Maybe (Id, CoreExpr)  -- Note [Binder swap]
            -> CoreAlt
            -> (UsageDetails, Alt IdWithOccInfo)
            -> 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
   = 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
     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}
 
 
 \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
 
 \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
 
 (+++), combineAltsUsageDetails
         :: UsageDetails -> UsageDetails -> UsageDetails
@@ -1040,8 +1120,9 @@ addOneOcc usage id info
 emptyDetails :: UsageDetails
 emptyDetails = (emptyVarEnv :: UsageDetails)
 
 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
 
 
 type IdWithOccInfo = Id
 
@@ -1099,8 +1180,7 @@ mkOneOcc _env id int_cxt
 
 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
 
 
 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
 
-markMany IAmDead = IAmDead
-markMany _       = NoOccInfo
+markMany _  = NoOccInfo
 
 markInsideSCC occ = markMany occ
 
 
 markInsideSCC occ = markMany occ
 
@@ -1109,19 +1189,18 @@ markInsideLam occ                       = occ
 
 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
 
 
 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 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 (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}
 \end{code}
index 70e0fa1..a2e06a0 100644 (file)
@@ -271,9 +271,12 @@ addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) v
        -- _delete_ it from the substitution when going inside
        -- the (\x -> ...)!
 
        -- _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
 
 ---------------------
 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 
 
 \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)
        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
 
        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
        -- 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!
                         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,
 
 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
     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)
 
 ---------------
 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)
 -- 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
   where
     subst     = mkCoreSubst env
     old_rules = idSpecialisation in_id
index 39bf3d8..14d11df 100644 (file)
@@ -14,6 +14,7 @@ import Type hiding      ( substTy, extendTvSubst )
 import SimplEnv
 import SimplUtils
 import MkId            ( rUNTIME_ERROR_ID )
 import SimplEnv
 import SimplUtils
 import MkId            ( rUNTIME_ERROR_ID )
+import FamInstEnv      ( FamInstEnv )
 import Id
 import Var
 import IdInfo
 import Id
 import Var
 import IdInfo
@@ -365,6 +366,9 @@ simplNonRecX :: SimplEnv
              -> SimplM SimplEnv
 
 simplNonRecX env bndr new_rhs
              -> 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 }
 
   = 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}
 ---------------------------------------------------------
 
 \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
 
 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]
   -- 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.
 
 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]
 ~~~~~~~~~~~~~~~~~
 
 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 <any> 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.
         case <any> 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.
 
 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
 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.)
 
 (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}
 
 
 \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
     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
 
             _ -> (env, case_bndr)
         where
-          case_bndr' = zapOccInfo case_bndr
+          case_bndr' = zapIdOccInfo case_bndr
           env1       = modifyInScope env case_bndr case_bndr'
           env1       = modifyInScope env case_bndr case_bndr'
-
-
-zapOccInfo :: InId -> InId      -- See Note [zapOccInfo]
-zapOccInfo b = b `setIdOccInfo` NoOccInfo
+-}
 \end{code}
 
 
 \end{code}
 
 
@@ -1616,10 +1586,15 @@ simplAlts :: SimplEnv
 
 simplAlts env scrut case_bndr alts cont'
   = -- pprTrace "simplAlts" (ppr alts $$ ppr (seIdSubst env)) $
 
 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') }
 
         ; 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)
 
               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
         -- 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
         --   ==>  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
 
 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
 
 addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
 addBinderOtherCon env bndr cons
-  = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
+  = modifyInScope env (bndr `setIdUnfolding` mkOtherCon cons)
 \end{code}
 
 
 \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
                                 -- 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'
   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 )
 
     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.
              -- Note that the binder might be "dead", because it doesn't
              -- occur in the RHS; and simplNonRecX may therefore discard
              -- it via postInlineUnconditionally.
index de83279..c78f8ca 100644 (file)
@@ -14,10 +14,10 @@ module VectCore (
 #include "HsVersions.h"
 
 import CoreSyn
 #include "HsVersions.h"
 
 import CoreSyn
+import MkCore        ( mkWildCase )
 import CoreUtils      ( exprType )
 import DataCon        ( DataCon )
 import Type           ( Type )
 import CoreUtils      ( exprType )
 import DataCon        ( DataCon )
 import Type           ( Type )
-import Id             ( mkWildId )
 import Var
 
 type Vect a = (a,a)
 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)
           -> 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)],
           [(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
           [(DataAlt ldc, sh_bndrs ++ lbndrs, lbody)])
   where
     (vbndrs, lbndrs) = unzip bndrs
index ffb43bb..b4b3c43 100644 (file)
@@ -12,6 +12,7 @@ import VectCore
 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
 import CoreSyn
 import CoreUtils
 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
 import CoreSyn
 import CoreUtils
+import MkCore           ( mkWildCase )
 import BuildTyCl
 import DataCon
 import TyCon
 import BuildTyCl
 import DataCon
 import TyCon
@@ -23,7 +24,6 @@ import OccName
 import MkId
 import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
 import Var               ( Var, TyVar )
 import MkId
 import BasicTypes        ( StrictnessMark(..), boolToRecFlag )
 import Var               ( Var, TyVar )
-import Id                ( mkWildId )
 import Name              ( Name, getOccName )
 import NameEnv
 import TysWiredIn
 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
             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
                  $ 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
         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])
                $ 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
     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
                    [(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
           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)
                  $ 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
 
       = 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
 
                   $ (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)
                    [(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
               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
                    [(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
 
       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
                [(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
           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
                  $ [(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
 
           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
                    [(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
       = 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 _)
                  [(DataAlt data_con, shape_vars, body)]
 
     from_prod (IdRepr _)
index 3bf97fa..6a8f893 100644 (file)
@@ -30,7 +30,6 @@ import TypeRep
 import TyCon
 import DataCon
 import Var
 import TyCon
 import DataCon
 import Var
-import Id                 ( mkWildId )
 import MkId               ( unwrapFamInstScrut )
 import TysWiredIn
 import BasicTypes         ( Boxity(..) )
 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),
 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
                                        [(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
 
           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)
                                         (exprType body)
                                         [(DataAlt env_con, lc : bndrs, body)]
       return (env, bind)