Simplify the SimplCont data type
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 4 May 2012 22:02:46 +0000 (23:02 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 9 May 2012 15:02:48 +0000 (16:02 +0100)
* Put the result type in the Stop continuation
* No need for the alts type in Select

The result is a modest but useful simplification

compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs

index 78798b6..d68e2a4 100644 (file)
@@ -24,7 +24,8 @@ module SimplUtils (
        -- The continuation type
        SimplCont(..), DupFlag(..), ArgInfo(..),
         isSimplified,
-       contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
+       contIsDupable, contResultType, contInputType,
+        contIsTrivial, contArgs, dropArgs, 
        pushSimplifiedArgs, countValArgs, countArgs, addArgTo,
        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
        interestingCallContext, 
@@ -54,7 +55,7 @@ import Var
 import Demand
 import SimplMonad
 import Type    hiding( substTy )
-import Coercion hiding( substCo )
+import Coercion hiding( substCo, substTy )
 import DataCon          ( dataConWorkId )
 import VarSet
 import BasicTypes
@@ -96,7 +97,8 @@ Key points:
 
 \begin{code}
 data SimplCont 
-  = Stop               -- An empty context, or hole, []     
+  = Stop               -- An empty context, or <hole>
+        OutType         -- Type of the <hole>
        CallCtxt        -- True <=> There is something interesting about
                        --          the context, and hence the inliner
                        --          should be a bit keener (see interestingCallContext)
@@ -104,41 +106,43 @@ data SimplCont
                        --     This is an argument of a function that has RULES
                        --     Inlining the call might allow the rule to fire
 
-  | CoerceIt           -- C `cast` co
+  | CoerceIt           -- <hole> `cast` co
        OutCoercion             -- The coercion simplified
                                -- Invariant: never an identity coercion
        SimplCont
 
-  | ApplyTo            -- C arg
+  | ApplyTo            -- <hole> arg
        DupFlag                 -- See Note [DupFlag invariants]
        InExpr StaticEnv        -- The argument and its static env
        SimplCont
 
-  | Select             -- case C of alts
-       DupFlag                         -- See Note [DupFlag invariants]
-       InId InType [InAlt] StaticEnv   -- The case binder, alts type, alts, and subst-env
+  | Select             -- case <hole> of alts
+       DupFlag                 -- See Note [DupFlag invariants]
+       InId [InAlt] StaticEnv  -- The case binder, alts type, alts, and subst-env
        SimplCont
 
   -- The two strict forms have no DupFlag, because we never duplicate them
-  | StrictBind                 -- (\x* \xs. e) C
-       InId [InBndr]           -- let x* = [] in e     
+  | StrictBind                         -- (\x* \xs. e) <hole>
+       InId [InBndr]           -- let x* = <hole> in e         
        InExpr StaticEnv        --      is a special case 
        SimplCont       
 
-  | StrictArg          -- f e1 ..en C
+  | StrictArg          -- f e1 ..en <hole>
        ArgInfo         -- Specifies f, e1..en, Whether f has rules, etc
                        --     plus strictness flags for *further* args
         CallCtxt        -- Whether *this* argument position is interesting
        SimplCont               
 
   | TickIt
-        (Tickish Id)    -- Tick tickish []
+        (Tickish Id)    -- Tick tickish <hole>
         SimplCont
 
 data ArgInfo
   = ArgInfo {
-        ai_fun   :: Id,                -- The function
+        ai_fun   :: OutId,     -- The function
        ai_args  :: [OutExpr],  -- ...applied to these args (which are in *reverse* order)
+        ai_type  :: OutType,    -- Type of (f a1 ... an)
+
        ai_rules :: [CoreRule], -- Rules for this function
 
        ai_encl :: Bool,        -- Flag saying whether this function 
@@ -154,18 +158,19 @@ data ArgInfo
     }
 
 addArgTo :: ArgInfo -> OutExpr -> ArgInfo
-addArgTo ai arg = ai { ai_args = arg : ai_args ai }
+addArgTo ai arg = ai { ai_args = arg : ai_args ai
+                     , ai_type = applyTypeToArg (ai_type ai) arg  }
 
 instance Outputable SimplCont where
-  ppr (Stop interesting)              = ptext (sLit "Stop") <> brackets (ppr interesting)
-  ppr (ApplyTo dup arg _ cont)         = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
+  ppr (Stop _ interesting)          = ptext (sLit "Stop") <> brackets (ppr interesting)
+  ppr (ApplyTo dup arg _ cont)       = ((ptext (sLit "ApplyTo") <+> ppr dup <+> pprParendExpr arg)
                                          {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
-  ppr (StrictBind b _ _ _ cont)        = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
-  ppr (StrictArg ai _ cont)            = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
-  ppr (Select dup bndr ty alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr <+> ppr ty) $$ 
+  ppr (StrictBind b _ _ _ cont)      = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
+  ppr (StrictArg ai _ cont)          = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
+  ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ 
                                         (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont 
-  ppr (CoerceIt co cont)              = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
-  ppr (TickIt t cont)                  = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
+  ppr (CoerceIt co cont)            = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
+  ppr (TickIt t cont)                = (ptext (sLit "TickIt") <+> ppr t) $$ ppr cont
 
 data DupFlag = NoDup       -- Unsimplified, might be big
              | Simplified  -- Simplified
@@ -193,14 +198,14 @@ the following invariants hold
 
 \begin{code}
 -------------------
-mkBoringStop :: SimplCont
-mkBoringStop = Stop BoringCtxt
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty BoringCtxt
 
-mkRhsStop :: SimplCont -- See Note [RHS of lets] in CoreUnfold
-mkRhsStop = Stop (ArgCtxt False)
+mkRhsStop :: OutType -> SimplCont      -- See Note [RHS of lets] in CoreUnfold
+mkRhsStop ty = Stop ty (ArgCtxt False)
 
-mkLazyArgStop :: CallCtxt -> SimplCont
-mkLazyArgStop cci = Stop cci
+mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
+mkLazyArgStop ty cci = Stop ty cci
 
 -------------------
 contIsRhsOrArg :: SimplCont -> Bool
@@ -211,11 +216,11 @@ contIsRhsOrArg _               = False
 
 -------------------
 contIsDupable :: SimplCont -> Bool
-contIsDupable (Stop {})                    = True
-contIsDupable (ApplyTo  OkToDup _ _ _)     = True      -- See Note [DupFlag invariants]
-contIsDupable (Select   OkToDup _ _ _ _ _) = True -- ...ditto...
-contIsDupable (CoerceIt _ cont)            = contIsDupable cont
-contIsDupable _                            = False
+contIsDupable (Stop {})                  = True
+contIsDupable (ApplyTo  OkToDup _ _ _)   = True        -- See Note [DupFlag invariants]
+contIsDupable (Select   OkToDup _ _ _ _) = True -- ...ditto...
+contIsDupable (CoerceIt _ cont)          = contIsDupable cont
+contIsDupable _                          = False
 
 -------------------
 contIsTrivial :: SimplCont -> Bool
@@ -226,28 +231,28 @@ contIsTrivial (CoerceIt _ cont)           = contIsTrivial cont
 contIsTrivial _                           = False
 
 -------------------
-contResultType :: SimplEnv -> OutType -> SimplCont -> OutType
-contResultType env ty cont
-  = go cont ty
-  where
-    subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty
-    subst_co se co = SimplEnv.substCo (se `setInScope` env) co
-
-    go (Stop {})                      ty = ty
-    go (CoerceIt co cont)             _  = go cont (pSnd (coercionKind co))
-    go (StrictBind _ bs body se cont) _  = go cont (subst_ty se (exprType (mkLams bs body)))
-    go (StrictArg ai _ cont)          _  = go cont (funResultTy (argInfoResultTy ai))
-    go (Select _ _ ty _ se cont)      _  = go cont (subst_ty se ty)
-    go (ApplyTo _ arg se cont)        ty = go cont (apply_to_arg ty arg se)
-    go (TickIt _ cont)                ty = go cont ty
-
-    apply_to_arg ty (Type ty_arg)     se = applyTy ty (subst_ty se ty_arg)
-    apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg)
-    apply_to_arg ty _                 _  = funResultTy ty
-
-argInfoResultTy :: ArgInfo -> OutType
-argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args })
-  = foldr (\arg fn_ty -> applyTypeToArg fn_ty arg) (idType fun) args
+contResultType :: SimplCont -> OutType
+contResultType (Stop ty _)            = ty
+contResultType (CoerceIt _ k)         = contResultType k
+contResultType (StrictBind _ _ _ _ k) = contResultType k
+contResultType (StrictArg _ _ k)      = contResultType k
+contResultType (Select _ _ _ _ k)     = contResultType k
+contResultType (ApplyTo _ _ _ k)      = contResultType k
+contResultType (TickIt _ k)           = contResultType k
+
+contInputType :: SimplCont -> OutType
+contInputType (Stop ty _)             = ty
+contInputType (CoerceIt co _)         = pFst (coercionKind co)
+contInputType (Select d b _ se _)     = perhapsSubstTy d se (idType b)
+contInputType (StrictBind b _ _ se _) = substTy se (idType b)
+contInputType (StrictArg ai _ _)      = funArgTy (ai_type ai)
+contInputType (ApplyTo d e se k)      = mkFunTy (perhapsSubstTy d se (exprType e)) (contInputType k)
+contInputType (TickIt _ k)            = contInputType k
+
+perhapsSubstTy :: DupFlag -> SimplEnv -> InType -> OutType
+perhapsSubstTy dup_flag se ty 
+  | isSimplified dup_flag = ty
+  | otherwise             = substTy se ty
 
 -------------------
 countValArgs :: SimplCont -> Int
@@ -328,7 +333,7 @@ interestingCallContext :: SimplCont -> CallCtxt
 interestingCallContext cont
   = interesting cont
   where
-    interesting (Select _ bndr _ _ _ _)
+    interesting (Select _ bndr _ _ _)
        | isDeadBinder bndr = CaseCtxt
        | otherwise         = ArgCtxt False     -- If the binder is used, this
                                                -- is like a strict let
@@ -343,7 +348,7 @@ interestingCallContext cont
 
     interesting (StrictArg _ cci _) = cci
     interesting (StrictBind {})            = BoringCtxt
-    interesting (Stop cci)         = cci
+    interesting (Stop _ cci)       = cci
     interesting (TickIt _ cci)      = interesting cci
     interesting (CoerceIt _ cont)   = interesting cont
        -- If this call is the arg of a strict function, the context
@@ -371,16 +376,19 @@ mkArgInfo :: Id
 
 mkArgInfo fun rules n_val_args call_cont
   | n_val_args < idArity fun           -- Note [Unsaturated functions]
-  = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules
-            , ai_encl = False
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = rules, ai_encl = False
            , ai_strs = vanilla_stricts 
            , ai_discs = vanilla_discounts }
   | otherwise
-  = ArgInfo { ai_fun = fun, ai_args = [], ai_rules = rules
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = rules
             , ai_encl = interestingArgContext rules call_cont
-           , ai_strs  = add_type_str (idType fun) arg_stricts
+           , ai_strs  = add_type_str fun_ty arg_stricts
            , ai_discs = arg_discounts }
   where
+    fun_ty = idType fun
+
     vanilla_discounts, arg_discounts :: [Int]
     vanilla_discounts = repeat 0
     arg_discounts = case idUnfolding fun of
@@ -466,7 +474,7 @@ interestingArgContext rules call_cont
     go (StrictArg _ cci _) = interesting cci
     go (StrictBind {})    = False      -- ??
     go (CoerceIt _ c)     = go c
-    go (Stop cci)          = interesting cci
+    go (Stop _ cci)        = interesting cci
     go (TickIt _ c)        = go c
 
     interesting (ArgCtxt rules) = rules
index 8b361b0..3ff0ebb 100644 (file)
@@ -339,11 +339,14 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                        --    f = /\a. \x. g a x  
                        -- should eta-reduce
 
+                body_out_ty :: OutType
+                body_out_ty = substTy env (exprType body)
+
         ; (body_env, tvs') <- simplBinders rhs_env tvs
                 -- See Note [Floating and type abstraction] in SimplUtils
 
         -- Simplify the RHS
-        ; (body_env1, body1) <- simplExprF body_env body mkRhsStop
+        ; (body_env1, body1) <- simplExprF body_env body (mkRhsStop body_out_ty)
         -- ANF-ise a constructor or PAP rhs
         ; (body_env2, body2) <- prepareRhs top_lvl body_env1 bndr1 body1
 
@@ -879,7 +882,10 @@ might do the same again.
 
 \begin{code}
 simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
-simplExpr env expr = simplExprC env expr mkBoringStop
+simplExpr env expr = simplExprC env expr (mkBoringStop expr_out_ty)
+  where
+    expr_out_ty :: OutType
+    expr_out_ty = substTy env (exprType expr)
 
 simplExprC :: SimplEnv -> CoreExpr -> SimplCont -> SimplM CoreExpr
         -- Simplify an expression, given a continuation
@@ -941,17 +947,19 @@ simplExprF1 env expr@(Lam {}) cont
     zap b | isTyVar b = b
           | otherwise = zapLamIdInfo b
 
-simplExprF1 env (Case scrut bndr ty alts) cont
+simplExprF1 env (Case scrut bndr alts_ty alts) cont
   | sm_case_case (getMode env)
   =     -- Simplify the scrutinee with a Select continuation
-    simplExprF env scrut (Select NoDup bndr ty alts env cont)
+    simplExprF env scrut (Select NoDup bndr alts env cont)
 
   | otherwise
   =     -- If case-of-case is off, simply simplify the case expression
         -- in a vanilla Stop context, and rebuild the result around it
-    do  { case_expr' <- simplExprC env scrut
-                             (Select NoDup bndr ty alts env mkBoringStop)
+    do  { case_expr' <- simplExprC env scrut 
+                             (Select NoDup bndr alts env (mkBoringStop alts_out_ty))
         ; rebuild env case_expr' cont }
+  where
+    alts_out_ty = substTy env alts_ty
 
 simplExprF1 env (Let (Rec pairs) body) cont
   = do  { env' <- simplRecBndrs env (map fst pairs)
@@ -1105,7 +1113,7 @@ simplTick env tickish expr cont
     where (inc,outc) = splitCont c
   splitCont (CoerceIt co c) = (CoerceIt co inc, outc)
     where (inc,outc) = splitCont c
-  splitCont other = (mkBoringStop, other)
+  splitCont other = (mkBoringStop (contInputType other), other)
 
   getDoneId (DoneId id) = id
   getDoneId (DoneEx e)  = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
@@ -1160,7 +1168,7 @@ rebuild env expr cont
       Stop {}                       -> return (env, expr)
       CoerceIt co cont              -> rebuild env (mkCast expr co) cont 
                                     -- NB: mkCast implements the (Coercion co |> g) optimisation
-      Select _ bndr ty alts se cont -> rebuildCase (se `setFloats` env) expr bndr ty alts cont
+      Select _ bndr alts se cont    -> rebuildCase (se `setFloats` env) expr bndr alts cont
       StrictArg info _ cont         -> rebuildCall env (info `addArgTo` expr) cont
       StrictBind b bs body se cont  -> do { env' <- simplNonRecX (se `setFloats` env) b expr
                                           ; simplLam env' bs body cont }
@@ -1380,7 +1388,7 @@ simplIdF env var cont
 ---------------------------------------------------------
 --      Dealing with a call site
 
-completeCall :: SimplEnv -> Id -> SimplCont -> SimplM (SimplEnv, OutExpr)
+completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplEnv, OutExpr)
 completeCall env var cont
   = do  {   ------------- Try inlining ----------------
           dflags <- getDynFlags
@@ -1440,14 +1448,14 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
   = return (env, castBottomExpr res cont_ty)  -- contination to discard, else we do it
   where                                       -- again and again!
     res     = mkApps (Var fun) (reverse rev_args)
-    cont_ty = contResultType env (exprType res) cont
+    cont_ty = contResultType cont
 
 rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont)
   = do { arg_ty' <- if isSimplified dup_flag then return arg_ty
                     else simplType (se `setInScope` env) arg_ty
        ; rebuildCall env (info `addArgTo` Type arg_ty') cont }
 
-rebuildCall env info@(ArgInfo { ai_encl = encl_rules
+rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
                               , ai_strs = str:strs, ai_discs = disc:discs })
             (ApplyTo dup_flag arg arg_se cont)
   | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
@@ -1465,7 +1473,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules
         -- have to be very careful about bogus strictness through
         -- floating a demanded let.
   = do  { arg' <- simplExprC (arg_se `setInScope` env) arg
-                             (mkLazyArgStop cci)
+                             (mkLazyArgStop (funArgTy fun_ty) cci)
         ; rebuildCall env (addArgTo info' arg') cont }
   where
     info' = info { ai_strs = strs, ai_discs = discs }
@@ -1728,7 +1736,6 @@ rebuildCase, reallyRebuildCase
    :: SimplEnv
    -> OutExpr          -- Scrutinee
    -> InId             -- Case binder
-   -> InType           -- Type of alternatives
    -> [InAlt]          -- Alternatives (inceasing order)
    -> SimplCont
    -> SimplM (SimplEnv, OutExpr)
@@ -1737,7 +1744,7 @@ rebuildCase, reallyRebuildCase
 --      1. Eliminate the case if there's a known constructor
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr alts cont
+rebuildCase env scrut case_bndr alts cont
   | Lit lit <- scrut    -- No need for same treatment as constructors
                         -- because literals are inlined more vigorously
   , not (litIsLifted lit)
@@ -1766,7 +1773,7 @@ rebuildCase env scrut case_bndr _ alts cont
 --      2. Eliminate the case if scrutinee is evaluated
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
+rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
   -- See if we can get rid of the case altogether
   -- See Note [Case elimination] 
   -- mkCase made sure that if all the alternatives are equal,
@@ -1816,7 +1823,7 @@ rebuildCase env scrut case_bndr _ [(_, bndrs, rhs)] cont
 --      3. Try seq rules; see Note [User-defined RULES for seq] in MkId
 --------------------------------------------------
 
-rebuildCase env scrut case_bndr alts_ty alts@[(_, bndrs, rhs)] cont
+rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'
   = do { let rhs' = substExpr (text "rebuild-case") env rhs
              out_args = [Type (substTy env (idType case_bndr)), 
@@ -1829,24 +1836,25 @@ rebuildCase env scrut case_bndr alts_ty alts@[(_, bndrs, rhs)] cont
            Just (n_args, res) -> simplExprF (zapSubstEnv env) 
                                            (mkApps res (drop n_args out_args))
                                             cont
-          Nothing -> reallyRebuildCase env scrut case_bndr alts_ty alts cont }
+          Nothing -> reallyRebuildCase env scrut case_bndr alts cont }
 
-rebuildCase env scrut case_bndr alts_ty alts cont
-  = reallyRebuildCase env scrut case_bndr alts_ty alts cont
+rebuildCase env scrut case_bndr alts cont
+  = reallyRebuildCase env scrut case_bndr alts cont
 
 --------------------------------------------------
 --      3. Catch-all case
 --------------------------------------------------
 
-reallyRebuildCase env scrut case_bndr alts_ty alts cont
+reallyRebuildCase env scrut case_bndr alts cont
   = do  {       -- Prepare the continuation;
                 -- The new subst_env is in place
           (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont
 
         -- Simplify the alternatives
-        ; (scrut', case_bndr', alts_ty', alts') <- simplAlts env' scrut case_bndr alts_ty alts dup_cont
+        ; (scrut', case_bndr', alts') <- simplAlts env' scrut case_bndr alts dup_cont
 
         ; dflags <- getDynFlags
+        ; let alts_ty' = contResultType dup_cont
         ; case_expr <- mkCase dflags scrut' case_bndr' alts_ty' alts'
 
        -- Notice that rebuild gets the in-scope set from env', not alt_env
@@ -1935,20 +1943,16 @@ robust here.  (Otherwise, there's a danger that we'll simply drop the
 simplAlts :: SimplEnv
           -> OutExpr
           -> InId                       -- Case binder
-          -> InType
           -> [InAlt]                   -- Non-empty
          -> SimplCont
-          -> SimplM (OutExpr, OutId, OutType, [OutAlt])  -- Includes the continuation
+          -> SimplM (OutExpr, OutId, [OutAlt])  -- Includes the continuation
 -- Like simplExpr, this just returns the simplified alternatives;
 -- it does not return an environment
 -- The returned alternatives can be empty, none are possible
 
-simplAlts env scrut case_bndr alts_ty alts cont'
+simplAlts env scrut case_bndr alts cont'
   = do  { let env0 = zapFloats env
 
-        ; basic_alts_ty' <- simplType env0 alts_ty
-        ; let alts_ty' = contResultType env0 basic_alts_ty' cont'
-
         ; (env1, case_bndr1) <- simplBinder env0 case_bndr
 
         ; fam_envs <- getFamEnvs
@@ -1963,7 +1967,7 @@ simplAlts env scrut case_bndr alts_ty alts cont'
         ; alts' <- mapM (simplAlt alt_env' mb_var_scrut
                              imposs_deflt_cons case_bndr' cont') in_alts
         ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
-          return (scrut', case_bndr', alts_ty', alts') }
+          return (scrut', case_bndr', alts') }
 
 
 ------------------------------------
@@ -2180,11 +2184,9 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp
                -- an inner case has no accessible alternatives before 
                -- it "sees" that the entire branch of an outer case is 
                -- inaccessible.  So we simply put an error case here instead.
-missingAlt env case_bndr alts cont
+missingAlt env case_bndr _ cont
   = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
-    return (env, mkImpossibleExpr res_ty)
-  where
-    res_ty = contResultType env (substTy env (coreAltsType alts)) cont
+    return (env, mkImpossibleExpr (contResultType cont))
 \end{code}
 
 
@@ -2212,7 +2214,7 @@ prepareCaseCont :: SimplEnv
 
 prepareCaseCont env alts cont 
   | many_alts alts = mkDupableCont env cont 
-  | otherwise      = return (env, cont, mkBoringStop)
+  | otherwise      = return (env, cont, mkBoringStop (contResultType cont))
   where
     many_alts :: [InAlt] -> Bool  -- True iff strictly > 1 non-bottom alternative
     many_alts []  = False        -- See Note [Bottom alternatives]
@@ -2241,7 +2243,7 @@ mkDupableCont :: SimplEnv -> SimplCont
 
 mkDupableCont env cont
   | contIsDupable cont
-  = return (env, cont, mkBoringStop)
+  = return (env, cont, mkBoringStop (contResultType cont))
 
 mkDupableCont _   (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
 
@@ -2251,10 +2253,10 @@ mkDupableCont env (CoerceIt ty cont)
 
 -- Duplicating ticks for now, not sure if this is good or not
 mkDupableCont env cont@(TickIt{})
-  = return (env, mkBoringStop, cont)
+  = return (env, mkBoringStop (contInputType cont), cont)
 
 mkDupableCont env cont@(StrictBind {})
-  =  return (env, mkBoringStop, cont)
+  =  return (env, mkBoringStop (contInputType cont), cont)
         -- See Note [Duplicating StrictBind]
 
 mkDupableCont env (StrictArg info cci cont)
@@ -2274,16 +2276,16 @@ mkDupableCont env (ApplyTo _ arg se cont)
         ; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont
         ; return (env'', app_cont, nodup_cont) }
 
-mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
+mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
 --  See Note [Single-alternative case]
 --  | not (exprIsDupable rhs && contIsDupable case_cont)
 --  | not (isDeadBinder case_bndr)
   | all isDeadBinder bs  -- InIds
     && not (isUnLiftedType (idType case_bndr))
     -- Note [Single-alternative-unlifted]
-  = return (env, mkBoringStop, cont)
+  = return (env, mkBoringStop (contInputType cont), cont)
 
-mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
+mkDupableCont env (Select _ case_bndr alts se cont)
   =     -- e.g.         (case [...hole...] of { pi -> ei })
         --      ===>
         --              let ji = \xij -> ei
@@ -2299,8 +2301,6 @@ mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
 
         ; let alt_env = se `setInScope` env'
 
-        ; basic_alts_ty' <- simplType alt_env alts_ty
-        ; let alts_ty' = contResultType alt_env basic_alts_ty' dup_cont
         ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
         ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' dup_cont) alts
         -- Safe to say that there are no handled-cons for the DEFAULT case
@@ -2317,7 +2317,8 @@ mkDupableCont env (Select _ case_bndr alts_ty alts se cont)
 
         ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
         ; return (env'',  -- Note [Duplicated env]
-                  Select OkToDup case_bndr' alts_ty' alts'' (zapSubstEnv env'') mkBoringStop,
+                  Select OkToDup case_bndr' alts'' (zapSubstEnv env'') 
+                         (mkBoringStop (contInputType nodup_cont)),
                   nodup_cont) }