Comments and layout
[ghc-hetmet.git] / compiler / simplCore / Simplify.lhs
index 17a6bcc..45cda38 100644 (file)
@@ -13,7 +13,7 @@ import DynFlags       ( dopt, DynFlag(Opt_D_dump_inlinings),
                        )
 import SimplMonad
 import SimplEnv        
                        )
 import SimplMonad
 import SimplEnv        
-import SimplUtils      ( mkCase, mkLam,
+import SimplUtils      ( mkCase, mkLam, 
                          SimplCont(..), DupFlag(..), LetRhsFlag(..), 
                          mkRhsStop, mkBoringStop,  mkLazyArgStop, pushContArgs,
                          contResultType, countArgs, contIsDupable, contIsRhsOrArg,
                          SimplCont(..), DupFlag(..), LetRhsFlag(..), 
                          mkRhsStop, mkBoringStop,  mkLazyArgStop, pushContArgs,
                          contResultType, countArgs, contIsDupable, contIsRhsOrArg,
@@ -26,17 +26,12 @@ import Id           ( Id, idType, idInfo, idArity, isDataConWorkId,
                          idNewDemandInfo, setIdInfo, 
                          setIdOccInfo, zapLamIdInfo, setOneShotLambda
                        )
                          idNewDemandInfo, setIdInfo, 
                          setIdOccInfo, zapLamIdInfo, setOneShotLambda
                        )
-import MkId            ( eRROR_ID )
-import Literal         ( mkStringLit )
-import IdInfo          ( OccInfo(..), isLoopBreaker,
-                         setArityInfo, zapDemandInfo,
-                         setUnfoldingInfo, 
-                         occInfo
+import IdInfo          ( OccInfo(..), setArityInfo, zapDemandInfo,
+                         setUnfoldingInfo, occInfo
                        )
 import NewDemand       ( isStrictDmd )
                        )
 import NewDemand       ( isStrictDmd )
-import Unify           ( coreRefineTys, dataConCanMatch )
-import DataCon         ( DataCon, dataConTyCon, dataConRepStrictness, isVanillaDataCon,
-                         dataConInstArgTys, dataConTyVars )
+import TcGadt          ( dataConCanMatch )
+import DataCon         ( dataConTyCon, dataConRepStrictness )
 import TyCon           ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
 import CoreSyn
 import PprCore         ( pprParendExpr, pprCoreExpr )
 import TyCon           ( tyConArity, isAlgTyCon, isNewTyCon, tyConDataCons_maybe )
 import CoreSyn
 import PprCore         ( pprParendExpr, pprCoreExpr )
@@ -45,24 +40,24 @@ import CoreUtils    ( exprIsDupable, exprIsTrivial, needsCaseBinding,
                          exprIsConApp_maybe, mkPiTypes, findAlt, 
                          exprType, exprIsHNF, findDefault, mergeAlts,
                          exprOkForSpeculation, exprArity, 
                          exprIsConApp_maybe, mkPiTypes, findAlt, 
                          exprType, exprIsHNF, findDefault, mergeAlts,
                          exprOkForSpeculation, exprArity, 
-                         mkCoerce, mkCoerce2, mkSCC, mkInlineMe, applyTypeToArg
+                         mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
+                          dataConRepInstPat
                        )
 import Rules           ( lookupRule )
 import BasicTypes      ( isMarkedStrict )
 import CostCentre      ( currentCCS )
 import Type            ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
                        )
 import Rules           ( lookupRule )
 import BasicTypes      ( isMarkedStrict )
 import CostCentre      ( currentCCS )
 import Type            ( TvSubstEnv, isUnLiftedType, seqType, tyConAppArgs, funArgTy,
-                         splitFunTy_maybe, splitFunTy, coreEqType, splitTyConApp_maybe,
-                         isTyVarTy, mkTyVarTys
+                         coreEqType, splitTyConApp_maybe,
+                         isTyVarTy, isFunTy, tcEqType
                        )
                        )
-import Var             ( tyVarKind, mkTyVar )
+import Coercion         ( Coercion, coercionKind,
+                          mkTransCoercion, mkSymCoercion, splitCoercionKind_maybe, decomposeCo  )
 import VarEnv          ( elemVarEnv, emptyVarEnv )
 import TysPrim         ( realWorldStatePrimTy )
 import PrelInfo                ( realWorldPrimId )
 import BasicTypes      ( TopLevelFlag(..), isTopLevel, 
 import VarEnv          ( elemVarEnv, emptyVarEnv )
 import TysPrim         ( realWorldStatePrimTy )
 import PrelInfo                ( realWorldPrimId )
 import BasicTypes      ( TopLevelFlag(..), isTopLevel, 
-                         RecFlag(..), isNonRec
+                         RecFlag(..), isNonRec, isNonRuleLoopBreaker
                        )
                        )
-import Name            ( mkSysTvName )
-import StaticFlags     ( opt_PprStyle_Debug )
 import OrdList
 import List            ( nub )
 import Maybes          ( orElse )
 import OrdList
 import List            ( nub )
 import Maybes          ( orElse )
@@ -320,13 +315,7 @@ simplNonRecBind' env bndr rhs rhs_se cont_ty thing_inside
     let
        (env2,bndr2) = addLetIdInfo env1 bndr bndr1
     in
     let
        (env2,bndr2) = addLetIdInfo env1 bndr bndr1
     in
-    if needsCaseBinding bndr_ty rhs1
-    then
-      thing_inside env2                                        `thenSmpl` \ (floats, body) ->
-      returnSmpl (emptyFloats env2, Case rhs1 bndr2 (exprType body) 
-                                       [(DEFAULT, [], wrapFloats floats body)])
-    else
-      completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
+    completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside
 
   | otherwise                                                  -- Normal, lazy case
   =    -- Don't use simplBinder because that doesn't keep 
 
   | otherwise                                                  -- Normal, lazy case
   =    -- Don't use simplBinder because that doesn't keep 
@@ -351,7 +340,21 @@ simplNonRecX :: SimplEnv
             -> SimplM FloatsWithExpr
 
 simplNonRecX env bndr new_rhs thing_inside
             -> SimplM FloatsWithExpr
 
 simplNonRecX env bndr new_rhs thing_inside
-  | needsCaseBinding (idType bndr) new_rhs
+  = do { (env, bndr') <- simplBinder env bndr
+       ; completeNonRecX env False {- Non-strict; pessimistic -} 
+                         bndr bndr' new_rhs thing_inside }
+
+
+completeNonRecX :: SimplEnv
+               -> Bool                 -- Strict binding
+               -> InId                 -- Old binder
+               -> OutId                -- New binder
+               -> OutExpr              -- Simplified RHS
+               -> (SimplEnv -> SimplM FloatsWithExpr)
+               -> SimplM FloatsWithExpr
+
+completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
+  | needsCaseBinding (idType new_bndr) new_rhs
        -- Make this test *before* the preInlineUnconditionally
        -- Consider     case I# (quotInt# x y) of 
        --                I# v -> let w = J# v in ...
        -- Make this test *before* the preInlineUnconditionally
        -- Consider     case I# (quotInt# x y) of 
        --                I# v -> let w = J# v in ...
@@ -359,12 +362,20 @@ simplNonRecX env bndr new_rhs thing_inside
        -- extra thunk:
        --                let w = J# (quotInt# x y) in ...
        -- because quotInt# can fail.
        -- extra thunk:
        --                let w = J# (quotInt# x y) in ...
        -- because quotInt# can fail.
-  = simplBinder env bndr       `thenSmpl` \ (env, bndr') ->
-    thing_inside env           `thenSmpl` \ (floats, body) ->
-    let body' = wrapFloats floats body in 
-    returnSmpl (emptyFloats env, Case new_rhs bndr' (exprType body') [(DEFAULT, [], body')])
+  = do { (floats, body) <- thing_inside env
+       ; let body' = wrapFloats floats body
+       ; return (emptyFloats env, Case new_rhs new_bndr (exprType body) 
+                                       [(DEFAULT, [], body')]) }
 
 
-{- No, no, no!  Do not try preInlineUnconditionally 
+  | otherwise
+  =    -- Make the arguments atomic if necessary, 
+       -- adding suitable bindings
+    mkAtomicArgsE env is_strict new_rhs                $ \ env new_rhs ->
+    completeLazyBind env NotTopLevel
+                    old_bndr new_bndr new_rhs  `thenSmpl` \ (floats, env) ->
+    addFloats env floats thing_inside
+
+{- No, no, no!  Do not try preInlineUnconditionally in completeNonRecX
    Doing so risks exponential behaviour, because new_rhs has been simplified once already
    In the cases described by the folowing commment, postInlineUnconditionally will 
    catch many of the relevant cases.
    Doing so risks exponential behaviour, because new_rhs has been simplified once already
    In the cases described by the folowing commment, postInlineUnconditionally will 
    catch many of the relevant cases.
@@ -378,24 +389,9 @@ simplNonRecX env bndr new_rhs thing_inside
        -- If a,b occur once we can avoid constructing the let binding for them.
   | preInlineUnconditionally env NotTopLevel bndr new_rhs
   = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
        -- If a,b occur once we can avoid constructing the let binding for them.
   | preInlineUnconditionally env NotTopLevel bndr new_rhs
   = thing_inside (extendIdSubst env bndr (DoneEx new_rhs))
--}
-
-  | otherwise
-  = simplBinder env bndr       `thenSmpl` \ (env, bndr') ->
-    completeNonRecX env False {- Non-strict; pessimistic -} 
-                   bndr bndr' new_rhs thing_inside
-
-completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside
-  = mkAtomicArgs is_strict 
-                True {- OK to float unlifted -} 
-                new_rhs                        `thenSmpl` \ (aux_binds, rhs2) ->
 
 
-       -- Make the arguments atomic if necessary, 
-       -- adding suitable bindings
-    addAtomicBindsE env (fromOL aux_binds)     $ \ env ->
-    completeLazyBind env NotTopLevel
-                    old_bndr new_bndr rhs2     `thenSmpl` \ (floats, env) ->
-    addFloats env floats thing_inside
+  -- NB: completeLazyBind uses postInlineUnconditionally; no need to do that here
+-}
 \end{code}
 
 
 \end{code}
 
 
@@ -535,8 +531,8 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                -- we only float if (a) arg' is a WHNF, or (b) it's going to top level
                -- and so there can't be any 'will be demanded' bindings in the floats.
                -- Hence the warning
                -- we only float if (a) arg' is a WHNF, or (b) it's going to top level
                -- and so there can't be any 'will be demanded' bindings in the floats.
                -- Hence the warning
-        ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)), 
-                ppr (filter demanded_float (floatBinds floats)) )
+        WARN( not (is_top_level || not (any demanded_float (floatBinds floats))), 
+             ppr (filter demanded_float (floatBinds floats)) )
 
        tick LetFloatFromLet                    `thenSmpl_` (
        addFloats env1 floats                   $ \ env2 ->
 
        tick LetFloatFromLet                    `thenSmpl_` (
        addFloats env1 floats                   $ \ env2 ->
@@ -594,21 +590,24 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
   | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
   =            -- Drop the binding
     tick (PostInlineUnconditionally old_bndr)  `thenSmpl_`
   | postInlineUnconditionally env top_lvl new_bndr occ_info new_rhs unfolding
   =            -- Drop the binding
     tick (PostInlineUnconditionally old_bndr)  `thenSmpl_`
+    -- pprTrace "Inline unconditionally" (ppr old_bndr <+> ppr new_bndr <+> ppr new_rhs) $
     returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
                -- Use the substitution to make quite, quite sure that the substitution
                -- will happen, since we are going to discard the binding
 
   |  otherwise
   = let
     returnSmpl (emptyFloats env, extendIdSubst env old_bndr (DoneEx new_rhs))
                -- Use the substitution to make quite, quite sure that the substitution
                -- will happen, since we are going to discard the binding
 
   |  otherwise
   = let
-               -- Add arity info
+       --      Arity info
        new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
 
        new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs
 
+       --      Unfolding info
        -- Add the unfolding *only* for non-loop-breakers
        -- Making loop breakers not have an unfolding at all 
        -- means that we can avoid tests in exprIsConApp, for example.
        -- This is important: if exprIsConApp says 'yes' for a recursive
        -- thing, then we can get into an infinite loop
 
        -- Add the unfolding *only* for non-loop-breakers
        -- Making loop breakers not have an unfolding at all 
        -- means that we can avoid tests in exprIsConApp, for example.
        -- This is important: if exprIsConApp says 'yes' for a recursive
        -- thing, then we can get into an infinite loop
 
+       --      Demand info
        -- If the unfolding is a value, the demand info may
        -- go pear-shaped, so we nuke it.  Example:
        --      let x = (a,b) in
        -- If the unfolding is a value, the demand info may
        -- go pear-shaped, so we nuke it.  Example:
        --      let x = (a,b) in
@@ -632,11 +631,11 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs
                -- These seqs forces the Id, and hence its IdInfo,
                -- and hence any inner substitutions
     final_id                                   `seq`
                -- These seqs forces the Id, and hence its IdInfo,
                -- and hence any inner substitutions
     final_id                                   `seq`
+    -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $
     returnSmpl (unitFloat env final_id new_rhs, env)
     returnSmpl (unitFloat env final_id new_rhs, env)
-
   where 
     unfolding    = mkUnfolding (isTopLevel top_lvl) new_rhs
   where 
     unfolding    = mkUnfolding (isTopLevel top_lvl) new_rhs
-    loop_breaker = isLoopBreaker occ_info
+    loop_breaker = isNonRuleLoopBreaker occ_info
     old_info     = idInfo old_bndr
     occ_info     = occInfo old_info
 \end{code}    
     old_info     = idInfo old_bndr
     occ_info     = occInfo old_info
 \end{code}    
@@ -711,7 +710,9 @@ simplExprF env (Var v)              cont = simplVar env v cont
 simplExprF env (Lit lit)       cont = rebuild env (Lit lit) cont
 simplExprF env expr@(Lam _ _)   cont = simplLam env expr cont
 simplExprF env (Note note expr) cont = simplNote env note expr cont
 simplExprF env (Lit lit)       cont = rebuild env (Lit lit) cont
 simplExprF env expr@(Lam _ _)   cont = simplLam env expr cont
 simplExprF env (Note note expr) cont = simplNote env note expr cont
-simplExprF env (App fun arg)    cont = simplExprF env fun (ApplyTo NoDup arg (Just env) cont)
+simplExprF env (Cast body co)   cont = simplCast env body co cont
+simplExprF env (App fun arg)    cont = simplExprF env fun 
+                                        (ApplyTo NoDup arg (Just env) cont)
 
 simplExprF env (Type ty) cont
   = ASSERT( contIsRhsOrArg cont )
 
 simplExprF env (Type ty) cont
   = ASSERT( contIsRhsOrArg cont )
@@ -764,6 +765,69 @@ simplType env ty
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
+simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont -> SimplM FloatsWithExpr
+simplCast env body co cont
+  = let
+       addCoerce co cont 
+         | (s1, k1) <- coercionKind co
+         , s1 `tcEqType` k1 = cont
+       addCoerce co1 (CoerceIt co2 cont)
+         | (s1, k1) <- coercionKind co1
+         , (l1, t1) <- coercionKind co2
+                --     coerce T1 S1 (coerce S1 K1 e)
+               -- ==>
+               --      e,                      if T1=K1
+               --      coerce T1 K1 e,         otherwise
+               --
+               -- For example, in the initial form of a worker
+               -- we may find  (coerce T (coerce S (\x.e))) y
+               -- and we'd like it to simplify to e[y/x] in one round 
+               -- of simplification
+         , s1 `coreEqType` t1  = cont           -- The coerces cancel out  
+         | otherwise           = CoerceIt (mkTransCoercion co1 co2) cont
+    
+       addCoerce co (ApplyTo dup arg arg_se cont)
+         | not (isTypeArg arg)    -- This whole case only works for value args
+                               -- Could upgrade to have equiv thing for type apps too  
+         , Just (s1s2, t1t2) <- splitCoercionKind_maybe co
+         , isFunTy s1s2
+                -- co : s1s2 :=: t1t2
+               --      (coerce (T1->T2) (S1->S2) F) E
+               -- ===> 
+               --      coerce T2 S2 (F (coerce S1 T1 E))
+               --
+               -- t1t2 must be a function type, T1->T2, because it's applied
+               -- to something but s1s2 might conceivably not be
+               --
+               -- When we build the ApplyTo we can't mix the out-types
+               -- with the InExpr in the argument, so we simply substitute
+               -- to make it all consistent.  It's a bit messy.
+               -- But it isn't a common case.
+         = result
+         where
+           -- we split coercion t1->t2 :=: s1->s2 into t1 :=: s1 and 
+           -- t2 :=: s2 with left and right on the curried form: 
+           --    (->) t1 t2 :=: (->) s1 s2
+           [co1, co2] = decomposeCo 2 co
+           new_arg    = mkCoerce (mkSymCoercion co1) arg'
+          arg'       = case arg_se of
+                         Nothing     -> arg
+                         Just arg_se -> substExpr (setInScope arg_se env) arg
+           result     = ApplyTo dup new_arg (Just $ zapSubstEnv env) 
+                               (addCoerce co2 cont)
+       addCoerce co cont = CoerceIt co cont
+    in
+    simplType env co           `thenSmpl` \ co' ->
+    simplExprF env body (addCoerce co' cont)
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{Lambdas}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
 simplLam env fun cont
   = go env fun cont
   where
 simplLam env fun cont
   = go env fun cont
   where
@@ -825,56 +889,6 @@ mkLamBndrZapper fun n_args
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}
-simplNote env (Coerce to from) body cont
-  = let
-       addCoerce s1 k1 cont    -- Drop redundant coerces.  This can happen if a polymoprhic
-                               -- (coerce a b e) is instantiated with a=ty1 b=ty2 and the
-                               -- two are the same. This happens a lot in Happy-generated parsers
-         | s1 `coreEqType` k1 = cont
-
-       addCoerce s1 k1 (CoerceIt t1 cont)
-               --      coerce T1 S1 (coerce S1 K1 e)
-               -- ==>
-               --      e,                      if T1=K1
-               --      coerce T1 K1 e,         otherwise
-               --
-               -- For example, in the initial form of a worker
-               -- we may find  (coerce T (coerce S (\x.e))) y
-               -- and we'd like it to simplify to e[y/x] in one round 
-               -- of simplification
-         | t1 `coreEqType` k1  = cont                  -- The coerces cancel out
-         | otherwise           = CoerceIt t1 cont      -- They don't cancel, but 
-                                                       -- the inner one is redundant
-
-       addCoerce t1t2 s1s2 (ApplyTo dup arg mb_arg_se cont)
-         | not (isTypeArg arg),        -- This whole case only works for value args
-                                       -- Could upgrade to have equiv thing for type apps too  
-           Just (s1, s2) <- splitFunTy_maybe s1s2
-               --      (coerce (T1->T2) (S1->S2) F) E
-               -- ===> 
-               --      coerce T2 S2 (F (coerce S1 T1 E))
-               --
-               -- t1t2 must be a function type, T1->T2, because it's applied to something
-               -- but s1s2 might conceivably not be
-               --
-               -- When we build the ApplyTo we can't mix the out-types
-               -- with the InExpr in the argument, so we simply substitute
-               -- to make it all consistent.  It's a bit messy.
-               -- But it isn't a common case.
-         = let 
-               (t1,t2) = splitFunTy t1t2
-               new_arg = mkCoerce2 s1 t1 arg'
-               arg' = case mb_arg_se of
-                         Nothing -> arg
-                         Just arg_se -> substExpr (setInScope arg_se env) arg
-           in
-           ApplyTo dup new_arg Nothing (addCoerce t2 s2 cont)
-                       
-       addCoerce to' _ cont = CoerceIt to' cont
-    in
-    simplType env to           `thenSmpl` \ to' ->
-    simplType env from         `thenSmpl` \ from' ->
-    simplExprF env body (addCoerce to' from' cont)
 
                
 -- Hack: we only distinguish subsumed cost centre stacks for the purposes of
 
                
 -- Hack: we only distinguish subsumed cost centre stacks for the purposes of
@@ -912,7 +926,7 @@ simplVar env var cont
   = case substId env var of
        DoneEx e         -> simplExprF (zapSubstEnv env) e cont
        ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
   = case substId env var of
        DoneEx e         -> simplExprF (zapSubstEnv env) e cont
        ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont
-       DoneId var1 occ  -> completeCall (zapSubstEnv env) var1 occ cont
+       DoneId var1      -> completeCall (zapSubstEnv env) var1 cont
                -- Note [zapSubstEnv]
                -- The template is already simplified, so don't re-substitute.
                -- This is VITAL.  Consider
                -- Note [zapSubstEnv]
                -- The template is already simplified, so don't re-substitute.
                -- This is VITAL.  Consider
@@ -926,7 +940,7 @@ simplVar env var cont
 ---------------------------------------------------------
 --     Dealing with a call site
 
 ---------------------------------------------------------
 --     Dealing with a call site
 
-completeCall env var occ_info cont
+completeCall env var cont
   =     -- Simplify the arguments
     getDOptsSmpl                                       `thenSmpl` \ dflags ->
     let
   =     -- Simplify the arguments
     getDOptsSmpl                                       `thenSmpl` \ dflags ->
     let
@@ -991,8 +1005,8 @@ completeCall env var occ_info cont
        interesting_cont = interestingCallContext (notNull args)
                                                  (notNull arg_infos)
                                                  call_cont
        interesting_cont = interestingCallContext (notNull args)
                                                  (notNull arg_infos)
                                                  call_cont
-       active_inline = activeInline env var occ_info
-       maybe_inline  = callSiteInline dflags active_inline occ_info
+       active_inline = activeInline env var
+       maybe_inline  = callSiteInline dflags active_inline
                                       var arg_infos interesting_cont
     in
     case maybe_inline of {
                                       var arg_infos interesting_cont
     in
     case maybe_inline of {
@@ -1153,6 +1167,38 @@ a *strict* let, then it would be a good thing to do.  Hence the
 context information.
 
 \begin{code}
 context information.
 
 \begin{code}
+mkAtomicArgsE :: SimplEnv 
+             -> Bool   -- A strict binding
+             -> OutExpr                                                -- The rhs
+             -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr)
+             -> SimplM FloatsWithExpr
+
+mkAtomicArgsE env is_strict rhs thing_inside
+  | (Var fun, args) <- collectArgs rhs,                                -- It's an application
+    isDataConWorkId fun || valArgCount args < idArity fun      -- And it's a constructor or PAP
+  = go env (Var fun) args
+
+  | otherwise = thing_inside env rhs
+
+  where
+    go env fun [] = thing_inside env fun
+
+    go env fun (arg : args) 
+       |  exprIsTrivial arg    -- Easy case
+       || no_float_arg         -- Can't make it atomic
+       = go env (App fun arg) args
+
+       | otherwise
+       = do { arg_id <- newId FSLIT("a") arg_ty
+            ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
+              go env (App fun (Var arg_id)) args }
+       where
+         arg_ty = exprType arg
+         no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
+
+
+-- Old code: consider rewriting to be more like mkAtomicArgsE
+
 mkAtomicArgs :: Bool   -- A strict binding
             -> Bool    -- OK to float unlifted args
             -> OutExpr
 mkAtomicArgs :: Bool   -- A strict binding
             -> Bool    -- OK to float unlifted args
             -> OutExpr
@@ -1199,25 +1245,6 @@ addAtomicBinds :: SimplEnv -> [(OutId,OutExpr)]
 addAtomicBinds env []         thing_inside = thing_inside env
 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env -> 
                                             addAtomicBinds env bs thing_inside
 addAtomicBinds env []         thing_inside = thing_inside env
 addAtomicBinds env ((v,r):bs) thing_inside = addAuxiliaryBind env (NonRec v r) $ \ env -> 
                                             addAtomicBinds env bs thing_inside
-
-addAtomicBindsE :: SimplEnv -> [(OutId,OutExpr)]
-               -> (SimplEnv -> SimplM FloatsWithExpr)
-               -> SimplM FloatsWithExpr
--- Same again, but this time we're in an expression context,
--- and may need to do some case bindings
-
-addAtomicBindsE env [] thing_inside 
-  = thing_inside env
-addAtomicBindsE env ((v,r):bs) thing_inside 
-  | needsCaseBinding (idType v) r
-  = addAtomicBindsE (addNewInScopeIds env [v]) bs thing_inside `thenSmpl` \ (floats, expr) ->
-    WARN( exprIsTrivial expr, ppr v <+> pprCoreExpr expr )
-    (let body = wrapFloats floats expr in 
-     returnSmpl (emptyFloats env, Case r v (exprType body) [(DEFAULT,[],body)]))
-
-  | otherwise
-  = addAuxiliaryBind env (NonRec v r)  $ \ env -> 
-    addAtomicBindsE env bs thing_inside
 \end{code}
 
 
 \end{code}
 
 
@@ -1232,7 +1259,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr
 
 rebuild env expr (Stop _ _ _)                = rebuildDone env expr
 rebuild env expr (ArgOf _ _ _ cont_fn)       = cont_fn env expr
 
 rebuild env expr (Stop _ _ _)                = rebuildDone env expr
 rebuild env expr (ArgOf _ _ _ cont_fn)       = cont_fn env expr
-rebuild env expr (CoerceIt to_ty cont)       = rebuild env (mkCoerce to_ty expr) cont
+rebuild env expr (CoerceIt co cont)          = rebuild env (mkCoerce co expr) cont
 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
 rebuild env expr (ApplyTo _ arg mb_se cont)   = rebuildApp  env expr arg mb_se cont
 
 rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
 rebuild env expr (ApplyTo _ arg mb_se cont)   = rebuildApp  env expr arg mb_se cont
 
@@ -1271,11 +1298,11 @@ rebuildCase env scrut case_bndr alts cont
   | Just (con,args) <- exprIsConApp_maybe scrut        
        -- Works when the scrutinee is a variable with a known unfolding
        -- as well as when it's an explicit constructor application
   | Just (con,args) <- exprIsConApp_maybe scrut        
        -- Works when the scrutinee is a variable with a known unfolding
        -- as well as when it's an explicit constructor application
-  = knownCon env (DataAlt con) args case_bndr alts cont
+  = knownCon env scrut (DataAlt con) args case_bndr alts cont
 
   | Lit lit <- scrut   -- No need for same treatment as constructors
                        -- because literals are inlined more vigorously
 
   | Lit lit <- scrut   -- No need for same treatment as constructors
                        -- because literals are inlined more vigorously
-  = knownCon env (LitAlt lit) [] case_bndr alts cont
+  = knownCon env scrut (LitAlt lit) [] case_bndr alts cont
 
   | otherwise
   =    -- Prepare the continuation;
 
   | otherwise
   =    -- Prepare the continuation;
@@ -1314,8 +1341,8 @@ 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 1
-~~~~~~
+Note [no-case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~
 There is a time we *don't* want to do that, namely when
 -fno-case-of-case is on.  This happens in the first simplifier pass,
 and enhances full laziness.  Here's the bad case:
 There is a time we *don't* want to do that, namely when
 -fno-case-of-case is on.  This happens in the first simplifier pass,
 and enhances full laziness.  Here's the bad case:
@@ -1326,6 +1353,15 @@ in action in spectral/cichelli/Prog.hs:
         [(m,n) | m <- [1..max], n <- [1..max]]
 Hence the check for NoCaseOfCase.
 
         [(m,n) | m <- [1..max], n <- [1..max]]
 Hence the check for NoCaseOfCase.
 
+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 2
 ~~~~~~
 There is another situation when we don't want to do it.  If we have
 Note 2
 ~~~~~~
 There is another situation when we don't want to do it.  If we have
@@ -1364,8 +1400,8 @@ 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.
 
 x1) has unfolding MkT y1.  THe straightforward thing to do is to do
 the binder-swap.  So this whole note is a no-op.
 
-Note 3
-~~~~~~
+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
 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
@@ -1391,23 +1427,32 @@ after the outer case, and that makes (a,b) alive.  At least we do unless
 the case binder is guaranteed dead.
 
 \begin{code}
 the case binder is guaranteed dead.
 
 \begin{code}
-simplCaseBinder env (Var v) case_bndr
-  | not (switchIsOn (getSwitchChecker env) NoCaseOfCase)
+simplCaseBinder env scrut case_bndr
+  | switchIsOn (getSwitchChecker env) NoCaseOfCase
+       -- See Note [no-case-of-case]
+  = do { (env, case_bndr') <- simplBinder env case_bndr
+       ; return (env, case_bndr') }
 
 
+simplCaseBinder env (Var v) case_bndr
 -- Failed try [see Note 2 above]
 --     not (isEvaldUnfolding (idUnfolding v))
 -- Failed try [see Note 2 above]
 --     not (isEvaldUnfolding (idUnfolding v))
-
-  = simplBinder env (zap case_bndr)            `thenSmpl` \ (env, case_bndr') ->
-    returnSmpl (modifyInScope env v case_bndr', case_bndr')
+  = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
+       ; return (modifyInScope env v case_bndr', case_bndr') }
        -- We could extend the substitution instead, but it would be
        -- a hack because then the substitution wouldn't be idempotent
        -- any more (v is an OutId).  And this does just as well.
        -- We could extend the substitution instead, but it would be
        -- a hack because then the substitution wouldn't be idempotent
        -- any more (v is an OutId).  And this does just as well.
-  where
-    zap b = b `setIdOccInfo` NoOccInfo
            
            
+simplCaseBinder env (Cast (Var v) co) case_bndr                -- Note [Case of cast]
+  = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr)
+       ; let rhs = Cast (Var case_bndr') (mkSymCoercion co)
+       ; return (addBinderUnfolding env v rhs, case_bndr') }
+
 simplCaseBinder env other_scrut case_bndr 
 simplCaseBinder env other_scrut case_bndr 
-  = simplBinder env case_bndr          `thenSmpl` \ (env, case_bndr') ->
-    returnSmpl (env, case_bndr')
+  = do { (env, case_bndr') <- simplBinder env case_bndr
+       ; return (env, case_bndr') }
+
+zapOccInfo :: InId -> InId     -- See Note [zapOccInfo]
+zapOccInfo b = b `setIdOccInfo` NoOccInfo
 \end{code}
 
 
 \end{code}
 
 
@@ -1487,6 +1532,7 @@ simplDefault :: SimplEnv
 
 simplDefault env case_bndr' imposs_cons cont Nothing
   = return []  -- No default branch
 
 simplDefault env case_bndr' imposs_cons cont Nothing
   = return []  -- No default branch
+
 simplDefault env case_bndr' imposs_cons cont (Just rhs)
   |    -- This branch handles the case where we are 
        -- scrutinisng an algebraic data type
 simplDefault env case_bndr' imposs_cons cont (Just rhs)
   |    -- This branch handles the case where we are 
        -- scrutinisng an algebraic data type
@@ -1518,7 +1564,11 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
                                -- altogether if it can't match
 
        [con] ->        -- It matches exactly one constructor, so fill it in
                                -- altogether if it can't match
 
        [con] ->        -- It matches exactly one constructor, so fill it in
-                do { con_alt <- mkDataConAlt case_bndr' con inst_tys rhs
+                do { tick (FillInCaseDefault case_bndr')
+                    ; us <- getUniquesSmpl
+                    ; let (ex_tvs, co_tvs, arg_ids) =
+                              dataConRepInstPat us con inst_tys
+                    ; let con_alt = (DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)
                    ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
                        -- The simplAlt must succeed with Just because we have
                        -- already filtered out construtors that can't match
                    ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
                        -- The simplAlt must succeed with Just because we have
                        -- already filtered out construtors that can't match
@@ -1526,40 +1576,17 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
 
        two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
 
 
        two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
 
-  | otherwise
+  | otherwise 
   = simplify_default imposs_cons
   where
     cant_match tys data_con = not (dataConCanMatch data_con tys)
 
     simplify_default imposs_cons
   = simplify_default imposs_cons
   where
     cant_match tys data_con = not (dataConCanMatch data_con tys)
 
     simplify_default imposs_cons
-       = do { let env' = mk_rhs_env env case_bndr' (mkOtherCon imposs_cons)
+       = do { let env' = addBinderOtherCon env case_bndr' imposs_cons
                -- Record the constructors that the case-binder *can't* be.
             ; rhs' <- simplExprC env' rhs cont
             ; return [(DEFAULT, [], rhs')] }
 
                -- Record the constructors that the case-binder *can't* be.
             ; rhs' <- simplExprC env' rhs cont
             ; return [(DEFAULT, [], rhs')] }
 
-mkDataConAlt :: Id -> DataCon -> [OutType] -> InExpr -> SimplM InAlt
--- Make a data-constructor alternative to replace the DEFAULT case
--- NB: there's something a bit bogus here, because we put OutTypes into an InAlt
-mkDataConAlt case_bndr con tys rhs
-  = do         { tick (FillInCaseDefault case_bndr)
-       ; args <- mk_args con tys
-       ; return (DataAlt con, args, rhs) }
-  where
-    mk_args con inst_tys
-      = do { (tv_bndrs, inst_tys') <- mk_tv_bndrs con inst_tys
-          ; let arg_tys = dataConInstArgTys con inst_tys'
-          ; arg_ids <- mapM (newId FSLIT("a")) arg_tys
-          ; returnSmpl (tv_bndrs ++ arg_ids) }
-
-    mk_tv_bndrs con inst_tys
-      | isVanillaDataCon con
-      = return ([], inst_tys)
-      | otherwise
-      = do { tv_uniqs <- getUniquesSmpl
-          ; let new_tvs    = zipWith mk tv_uniqs (dataConTyVars con)
-                mk uniq tv = mkTyVar (mkSysTvName uniq FSLIT("t")) (tyVarKind tv)
-          ; return (new_tvs, mkTyVarTys new_tvs) }
-
 simplAlt :: SimplEnv
         -> [AltCon]    -- These constructors can't be present when
                        -- matching this alternative
 simplAlt :: SimplEnv
         -> [AltCon]    -- These constructors can't be present when
                        -- matching this alternative
@@ -1583,7 +1610,7 @@ simplAlt env handled_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
     simplExprC env' rhs cont'  `thenSmpl` \ rhs' ->
     returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs')))
   where
     simplExprC env' rhs cont'  `thenSmpl` \ rhs' ->
     returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs')))
   where
-    env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons)
+    env' = addBinderOtherCon env case_bndr' handled_cons
        -- Record the constructors that the case-binder *can't* be.
 
 simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
        -- Record the constructors that the case-binder *can't* be.
 
 simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
@@ -1591,10 +1618,9 @@ simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs)
     simplExprC env' rhs cont'  `thenSmpl` \ rhs' ->
     returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs')))
   where
     simplExprC env' rhs cont'  `thenSmpl` \ rhs' ->
     returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs')))
   where
-    env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit))
+    env' = addBinderUnfolding env case_bndr' (Lit lit)
 
 simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
 
 simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
-  | isVanillaDataCon con
   =    -- Deal with the pattern-bound variables
        -- Mark the ones that are in ! positions in the data constructor
        -- as certainly-evaluated.
   =    -- Deal with the pattern-bound variables
        -- Mark the ones that are in ! positions in the data constructor
        -- as certainly-evaluated.
@@ -1604,52 +1630,12 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
     simplBinders env (add_evals con vs)                `thenSmpl` \ (env, vs') ->
 
                -- Bind the case-binder to (con args)
     simplBinders env (add_evals con vs)                `thenSmpl` \ (env, vs') ->
 
                -- Bind the case-binder to (con args)
-    let unf       = mkUnfolding False (mkConApp con con_args)
-       inst_tys' = tyConAppArgs (idType case_bndr')
-       con_args  = map Type inst_tys' ++ map varToCoreExpr vs' 
-       env'      = mk_rhs_env env case_bndr' unf
+    let inst_tys' = tyConAppArgs (idType case_bndr')
+       con_args  = map Type inst_tys' ++ varsToCoreExprs vs' 
+       env'      = addBinderUnfolding env case_bndr' (mkConApp con con_args)
     in
     simplExprC env' rhs cont'  `thenSmpl` \ rhs' ->
     returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
     in
     simplExprC env' rhs cont'  `thenSmpl` \ rhs' ->
     returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs')))
-
-  | otherwise  -- GADT case
-  = let
-       (tvs,ids) = span isTyVar vs
-    in
-    simplBinders env tvs                       `thenSmpl` \ (env1, tvs') ->
-    case coreRefineTys con tvs' (idType case_bndr') of {
-       Nothing         -- Inaccessible
-           | opt_PprStyle_Debug        -- Hack: if debugging is on, generate an error case 
-                                       --       so we can see it
-           ->  let rhs' = mkApps (Var eRROR_ID) 
-                               [Type (substTy env (exprType rhs)),
-                                Lit (mkStringLit "Impossible alternative (GADT)")]
-               in 
-               simplBinders env1 ids           `thenSmpl` \ (env2, ids') -> 
-               returnSmpl (Just (emptyVarEnv, (DataAlt con, tvs' ++ ids', rhs'))) 
-
-           | otherwise -- Filter out the inaccessible branch
-           -> return Nothing ; 
-
-       Just refine@(tv_subst_env, _) ->        -- The normal case
-
-    let 
-       env2 = refineSimplEnv env1 refine
-       -- Simplify the Ids in the refined environment, so their types
-       -- reflect the refinement.  Usually this doesn't matter, but it helps
-       -- in mkDupableAlt, when we want to float a lambda that uses these binders
-       -- Furthermore, it means the binders contain maximal type information
-    in
-    simplBinders env2 (add_evals con ids)      `thenSmpl` \ (env3, ids') ->
-    let unf        = mkUnfolding False con_app
-       con_app    = mkConApp con con_args
-       con_args   = map varToCoreExpr vs'      -- NB: no inst_tys'
-       env_w_unf  = mk_rhs_env env3 case_bndr' unf
-       vs'        = tvs' ++ ids'
-    in
-    simplExprC env_w_unf rhs cont'     `thenSmpl` \ rhs' ->
-    returnSmpl (Just (tv_subst_env, (DataAlt con, vs', rhs'))) }
-
   where
        -- add_evals records the evaluated-ness of the bound variables of
        -- a case pattern.  This is *important*.  Consider
   where
        -- add_evals records the evaluated-ness of the bound variables of
        -- a case pattern.  This is *important*.  Consider
@@ -1677,11 +1663,17 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs)
        -- 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
        -- 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
+       -- Note [Aug06] I can't see why this actually matters
     zap_occ_info | isDeadBinder case_bndr' = \id -> id
     zap_occ_info | isDeadBinder case_bndr' = \id -> id
-                | otherwise               = \id -> id `setIdOccInfo` NoOccInfo
+                | otherwise               = zapOccInfo
 
 
-mk_rhs_env env case_bndr' case_bndr_unf
-  = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf)
+addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv
+addBinderUnfolding env bndr rhs
+  = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs)
+
+addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv
+addBinderOtherCon env bndr cons
+  = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons)
 \end{code}
 
 
 \end{code}
 
 
@@ -1705,54 +1697,66 @@ and then
 All this should happen in one sweep.
 
 \begin{code}
 All this should happen in one sweep.
 
 \begin{code}
-knownCon :: SimplEnv -> AltCon -> [OutExpr]
+knownCon :: SimplEnv -> OutExpr -> AltCon -> [OutExpr]
         -> InId -> [InAlt] -> SimplCont
         -> SimplM FloatsWithExpr
 
         -> InId -> [InAlt] -> SimplCont
         -> SimplM FloatsWithExpr
 
-knownCon env con args bndr alts cont
-  = tick (KnownBranch bndr)    `thenSmpl_`
+knownCon env scrut con args bndr alts cont
+  = tick (KnownBranch bndr)            `thenSmpl_`
     case findAlt con alts of
        (DEFAULT, bs, rhs)     -> ASSERT( null bs )
                                  simplNonRecX env bndr scrut   $ \ env ->
     case findAlt con alts of
        (DEFAULT, bs, rhs)     -> ASSERT( null bs )
                                  simplNonRecX env bndr scrut   $ \ env ->
-                                       -- This might give rise to a binding with non-atomic args
-                                       -- like x = Node (f x) (g x)
-                                       -- but no harm will be done
+                               -- This might give rise to a binding with non-atomic args
+                               -- like x = Node (f x) (g x)
+                               -- but simplNonRecX will atomic-ify it
                                  simplExprF env rhs cont
                                  simplExprF env rhs cont
-                               where
-                                 scrut = case con of
-                                           LitAlt lit -> Lit lit
-                                           DataAlt dc -> mkConApp dc args
 
        (LitAlt lit, bs, rhs) ->  ASSERT( null bs )
 
        (LitAlt lit, bs, rhs) ->  ASSERT( null bs )
-                                 simplNonRecX env bndr (Lit lit)       $ \ env ->
+                                 simplNonRecX env bndr scrut   $ \ env ->
                                  simplExprF env rhs cont
 
        (DataAlt dc, bs, rhs)  
                                  simplExprF env rhs cont
 
        (DataAlt dc, bs, rhs)  
-               -> ASSERT( n_drop_tys + length bs == length args )
-                  bind_args env bs (drop n_drop_tys args)      $ \ env ->
+               -> -- ASSERT( n_drop_tys + length bs == length args )
+                  bind_args env dead_bndr bs (drop n_drop_tys args)    $ \ env ->
                   let
                   let
-                       con_app  = mkConApp dc (take n_drop_tys args ++ con_args)
+                       -- It's useful to bind bndr to scrut, rather than to a fresh
+                       -- binding      x = Con arg1 .. argn
+                       -- because very often the scrut is a variable, so we avoid
+                       -- creating, and then subsequently eliminating, a let-binding
+                       -- BUT, if scrut is a not a variable, we must be careful
+                       -- about duplicating the arg redexes; in that case, make
+                       -- a new con-app from the args
+                       bndr_rhs  = case scrut of
+                                       Var v -> scrut
+                                       other -> con_app
+                       con_app = mkConApp dc (take n_drop_tys args ++ con_args)
                        con_args = [substExpr env (varToCoreExpr b) | b <- bs]
                                        -- args are aready OutExprs, but bs are InIds
                   in
                        con_args = [substExpr env (varToCoreExpr b) | b <- bs]
                                        -- args are aready OutExprs, but bs are InIds
                   in
-                  simplNonRecX env bndr con_app                $ \ env ->
+                  simplNonRecX env bndr bndr_rhs               $ \ env ->
                   simplExprF env rhs cont
                where
                   simplExprF env rhs cont
                where
-                  n_drop_tys | isVanillaDataCon dc = tyConArity (dataConTyCon dc)
-                             | otherwise           = 0
-                       -- Vanilla data constructors lack type arguments in the pattern
+                  dead_bndr  = isDeadBinder bndr
+                  n_drop_tys = tyConArity (dataConTyCon dc)
 
 -- Ugh!
 
 -- Ugh!
-bind_args env [] _ thing_inside = thing_inside env
+bind_args env dead_bndr [] _ thing_inside = thing_inside env
 
 
-bind_args env (b:bs) (Type ty : args) thing_inside
+bind_args env dead_bndr (b:bs) (Type ty : args) thing_inside
   = ASSERT( isTyVar b )
   = ASSERT( isTyVar b )
-    bind_args (extendTvSubst env b ty) bs args thing_inside
+    bind_args (extendTvSubst env b ty) dead_bndr bs args thing_inside
     
     
-bind_args env (b:bs) (arg : args) thing_inside
+bind_args env dead_bndr (b:bs) (arg : args) thing_inside
   = ASSERT( isId b )
   = ASSERT( isId b )
-    simplNonRecX env b arg     $ \ env ->
-    bind_args env bs args thing_inside
+    let
+       b' = if dead_bndr then b else zapOccInfo b
+               -- Note that the binder might be "dead", because it doesn't occur 
+               -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
+               -- Nevertheless we must keep it if the case-binder is alive, because it may
+               -- be used in the con_app.  See Note [zapOccInfo]
+    in
+    simplNonRecX env b' arg    $ \ env ->
+    bind_args env dead_bndr bs args thing_inside
 \end{code}
 
 
 \end{code}
 
 
@@ -1826,6 +1830,75 @@ mkDupableCont env (ApplyTo _ arg mb_se cont)
        ; (floats2, arg2) <- mkDupableArg env arg1
        ; return (floats2, (ApplyTo OkToDup arg2 Nothing dup_cont, nondup_cont)) }}
 
        ; (floats2, arg2) <- mkDupableArg env arg1
        ; return (floats2, (ApplyTo OkToDup arg2 Nothing dup_cont, nondup_cont)) }}
 
+mkDupableCont env cont@(Select _ case_bndr [(_,bs,rhs)] se case_cont)
+--   | not (exprIsDupable rhs && contIsDupable case_cont)      -- See notes below
+--  | not (isDeadBinder case_bndr)
+  | all isDeadBinder bs
+  = returnSmpl (emptyFloats env, (mkBoringStop scrut_ty, cont))
+  where
+    scrut_ty = substTy se (idType case_bndr)
+
+{-     Note [Single-alternative cases]
+       ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This case is just like the ArgOf case.  Here's an example:
+       data T a = MkT !a
+       ...(MkT (abs x))...
+Then we get
+       case (case x of I# x' -> 
+             case x' <# 0# of
+               True  -> I# (negate# x')
+               False -> I# x') of y {
+         DEFAULT -> MkT y
+Because the (case x) has only one alternative, we'll transform to
+       case x of I# x' ->
+       case (case x' <# 0# of
+               True  -> I# (negate# x')
+               False -> I# x') of y {
+         DEFAULT -> MkT y
+But now we do *NOT* want to make a join point etc, giving 
+       case x of I# x' ->
+       let $j = \y -> MkT y
+       in case x' <# 0# of
+               True  -> $j (I# (negate# x'))
+               False -> $j (I# x')
+In this case the $j will inline again, but suppose there was a big
+strict computation enclosing the orginal call to MkT.  Then, it won't
+"see" the MkT any more, because it's big and won't get duplicated.
+And, what is worse, nothing was gained by the case-of-case transform.
+
+When should use this case of mkDupableCont?  
+However, matching on *any* single-alternative case is a *disaster*;
+  e.g. case (case ....) of (a,b) -> (# a,b #)
+  We must push the outer case into the inner one!
+Other choices:
+
+   * Match [(DEFAULT,_,_)], but in the common case of Int, 
+     the alternative-filling-in code turned the outer case into
+               case (...) of y { I# _ -> MkT y }
+
+   * Match on single alternative plus (not (isDeadBinder case_bndr))
+     Rationale: pushing the case inwards won't eliminate the construction.
+     But there's a risk of
+               case (...) of y { (a,b) -> let z=(a,b) in ... }
+     Now y looks dead, but it'll come alive again.  Still, this
+     seems like the best option at the moment.
+
+   * Match on single alternative plus (all (isDeadBinder bndrs))
+     Rationale: this is essentially  seq.
+
+   * Match when the rhs is *not* duplicable, and hence would lead to a
+     join point.  This catches the disaster-case above.  We can test
+     the *un-simplified* rhs, which is fine.  It might get bigger or
+     smaller after simplification; if it gets smaller, this case might
+     fire next time round.  NB also that we must test contIsDupable
+     case_cont *btoo, because case_cont might be big!
+
+     HOWEVER: I found that this version doesn't work well, because
+     we can get        let x = case (...) of { small } in ...case x...
+     When x is inlined into its full context, we find that it was a bad
+     idea to have pushed the outer case inside the (...) case.
+-}
+
 mkDupableCont env (Select _ case_bndr alts se cont)
   =    -- e.g.         (case [...hole...] of { pi -> ei })
        --      ===>
 mkDupableCont env (Select _ case_bndr alts se cont)
   =    -- e.g.         (case [...hole...] of { pi -> ei })
        --      ===>
@@ -1961,7 +2034,7 @@ mkDupableAlt env case_bndr' cont alt
        then newId FSLIT("w") realWorldStatePrimTy      `thenSmpl` \ rw_id ->
             returnSmpl ([rw_id], [Var realWorldPrimId])
        else 
        then newId FSLIT("w") realWorldStatePrimTy      `thenSmpl` \ rw_id ->
             returnSmpl ([rw_id], [Var realWorldPrimId])
        else 
-            returnSmpl (used_bndrs', map varToCoreExpr used_bndrs')
+            returnSmpl (used_bndrs', varsToCoreExprs used_bndrs')
     )                                                  `thenSmpl` \ (final_bndrs', final_args) ->
 
        -- See comment about "$j" name above
     )                                                  `thenSmpl` \ (final_bndrs', final_args) ->
 
        -- See comment about "$j" name above