Fix Trac #5658: strict bindings not floated in

Two changes here

* The main change here is to enhance the FloatIn pass so that it can
  float case-bindings inwards.  In particular the case bindings for
  array indexing.

* Also change the code in Simplify, to allow a case on array
  indexing (ie can_fail is true) to be discarded altogether if its
  results are unused.

Lots of new comments in PrimOp about can_fail and has_side_effects

Some refactoring to share the FloatBind data structure between
FloatIn and FloatOut

8 files changed, 237 insertions, 159 deletions

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index a8985d0019..ed288096f7 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -26,7 +26,7 @@ import CoreFVs
 import CoreMonad	( endPass, CoreToDo(..) )
 import CoreSyn
 import CoreSubst
-import MkCore
+import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here
 import Type
 import Literal
 import Coercion
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index d3a2ca5cbb..4b83e8cef6 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -21,7 +21,8 @@ module CoreUtils (
         exprType, coreAltType, coreAltsType,
         exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
-        exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
+        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects,
+        exprIsBig, exprIsConLike,
         rhsIsStatic, isCheapApp, isExpandableApp,
 
         -- * Expression and bindings size
@@ -752,35 +753,39 @@ it's applied only to dictionaries.
 --
 -- We can only do this if the @y + 1@ is ok for speculation: it has no
 -- side effects, and can't diverge or raise an exception.
-exprOkForSpeculation :: Expr b -> Bool
+exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
+exprOkForSpeculation = expr_ok primOpOkForSpeculation
+exprOkForSideEffects = expr_ok primOpOkForSideEffects
   -- Polymorphic in binder type
   -- There is one call at a non-Id binder type, in SetLevels
-exprOkForSpeculation (Lit _)      = True
-exprOkForSpeculation (Type _)     = True
-exprOkForSpeculation (Coercion _) = True
-exprOkForSpeculation (Var v)      = appOkForSpeculation v []
-exprOkForSpeculation (Cast e _)   = exprOkForSpeculation e
+
+expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
+expr_ok _ (Lit _)      = True
+expr_ok _ (Type _)     = True
+expr_ok _ (Coercion _) = True
+expr_ok primop_ok (Var v)      = app_ok primop_ok v []
+expr_ok primop_ok (Cast e _)   = expr_ok primop_ok e
 
 -- Tick annotations that *tick* cannot be speculated, because these
 -- are meant to identify whether or not (and how often) the particular
 -- source expression was evaluated at runtime.
-exprOkForSpeculation (Tick tickish e)
+expr_ok primop_ok (Tick tickish e)
    | tickishCounts tickish = False
-   | otherwise             = exprOkForSpeculation e
+   | otherwise             = expr_ok primop_ok e
 
-exprOkForSpeculation (Case e _ _ alts)
-  =  exprOkForSpeculation e  -- Note [exprOkForSpeculation: case expressions]
-  && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts
-  && altsAreExhaustive alts     -- Note [exprOkForSpeculation: exhaustive alts]
+expr_ok primop_ok (Case e _ _ alts)
+  =  expr_ok primop_ok e  -- Note [exprOkForSpeculation: case expressions]
+  && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
+  && altsAreExhaustive alts     -- Note [Exhaustive alts]
 
-exprOkForSpeculation other_expr
+expr_ok primop_ok other_expr
   = case collectArgs other_expr of
-        (Var f, args) -> appOkForSpeculation f args
+        (Var f, args) -> app_ok primop_ok f args
         _             -> False
 
 -----------------------------
-appOkForSpeculation :: Id -> [Expr b] -> Bool
-appOkForSpeculation fun args
+app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
+app_ok primop_ok fun args
   = case idDetails fun of
       DFunId new_type ->  not new_type
          -- DFuns terminate, unless the dict is implemented 
@@ -794,7 +799,7 @@ appOkForSpeculation fun args
       PrimOpId op
         | isDivOp op              -- Special case for dividing operations that fail
         , [arg1, Lit lit] <- args -- only if the divisor is zero
-        -> not (isZeroLit lit) && exprOkForSpeculation arg1
+        -> not (isZeroLit lit) && expr_ok primop_ok arg1
                   -- Often there is a literal divisor, and this
                   -- can get rid of a thunk in an inner looop
 
@@ -802,14 +807,14 @@ appOkForSpeculation fun args
         -> True
 
         | otherwise
-        -> primOpOkForSpeculation op &&
-           all exprOkForSpeculation args
-                                  -- A bit conservative: we don't really need
+        -> primop_ok op        -- A bit conservative: we don't really need
+        && all (expr_ok primop_ok) args
+                                  
                                   -- to care about lazy arguments, but this is easy
 
       _other -> isUnLiftedType (idType fun)          -- c.f. the Var case of exprIsHNF
              || idArity fun > n_val_args             -- Partial apps
-             || (n_val_args ==0 && 
+             || (n_val_args == 0 && 
                  isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
              where
                n_val_args = valArgCount args
@@ -872,13 +877,13 @@ If exprOkForSpeculation doesn't look through case expressions, you get this:
 
 The inner case is redundant, and should be nuked.
 
-Note [exprOkForSpeculation: exhaustive alts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Exhaustive alts]
+~~~~~~~~~~~~~~~~~~~~~~
 We might have something like
   case x of {
     A -> ...
     _ -> ...(case x of { B -> ...; C -> ... })...
-Here, the inner case is fine, becuase the A alternative
+Here, the inner case is fine, because the A alternative
 can't happen, but it's not ok to float the inner case outside
 the outer one (even if we know x is evaluated outside), because
 then it would be non-exhaustive. See Trac #5453.
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index dd41184994..15b43b45ee 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -21,6 +21,9 @@ module MkCore (
         mkFloatExpr, mkDoubleExpr,
         mkCharExpr, mkStringExpr, mkStringExprFS,
 
+        -- * Floats
+        FloatBind(..), wrapFloat,
+
         -- * Constructing/deconstructing implicit parameter boxes
         mkIPUnbox, mkIPBox,
 
@@ -389,6 +392,25 @@ mkBigCoreTupTy :: [Type] -> Type
 mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
 \end{code}
 
+
+%************************************************************************
+%*                                                                      *
+                Floats
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+data FloatBind 
+  = FloatLet  CoreBind
+  | FloatCase CoreExpr Id AltCon [Var]       
+      -- case e of y { C ys -> ... }
+      -- See Note [Floating cases] in SetLevels
+
+wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
+wrapFloat (FloatLet defns)       body = Let defns body
+wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
+\end{code}
+
 %************************************************************************
 %*                                                                      *
 \subsection{Tuple destructors}
diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs
index d57d1f926e..39bee1fb9d 100644
--- a/compiler/prelude/PrimOp.lhs
+++ b/compiler/prelude/PrimOp.lhs
@@ -12,7 +12,8 @@ module PrimOp (
         tagToEnumKey,
 
         primOpOutOfLine, primOpCodeSize,
-        primOpOkForSpeculation, primOpIsCheap,
+        primOpOkForSpeculation, primOpOkForSideEffects,
+        primOpIsCheap,
 
         getPrimOpResultInfo,  PrimOpResultInfo(..),
 
@@ -307,77 +308,93 @@ primOpOutOfLine :: PrimOp -> Bool
 
 Note [PrimOp can_fail and has_side_effects]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- * A primop that is neither can_fail nor has_side_effects can be
-   executed speculatively, any number of times
+Both can_fail and has_side_effects mean that the primop has
+some effect that is not captured entirely by its result value.
+
+   ----------  has_side_effects ---------------------
+   Has some imperative side effect, perhaps on the world (I/O),
+   or perhaps on some mutable data structure (writeIORef).
+   Generally speaking all such primops have a type like
+      State -> input -> (State, output)
+   so the state token guarantees ordering, and also ensures
+   that the primop is executed even if 'output' is discarded.
+
+   ----------  can_fail ----------------------------
+   Can fail with a seg-fault or divide-by-zero error on some elements
+   of its input domain.  Main examples:
+      division (fails on zero demoninator
+      array indexing (fails if the index is out of bounds)
+   However (ASSUMPTION), these can_fail primops are ALWAYS surrounded
+   with a test that checks for the bad cases.  
+
+Consequences:
+
+* You can discard a can_fail primop, or float it _inwards_.
+  But you cannot float it _outwards_, lest you escape the
+  dynamic scope of the test.  Example:
+      case d ># 0# of
+        True  -> case x /# d of r -> r +# 1
+        False -> 0
+  Here we must not float the case outwards to give
+      case x/# d of r ->
+      case d ># 0# of
+        True  -> r +# 1
+        False -> 0
+
+* I believe that exactly the same rules apply to a has_side_effects
+  primop; you can discard it (remember, the state token will keep
+  it alive if necessary), or float it in, but not float it out.
+
+  Example of the latter
+       if blah then let! s1 = writeMutVar s0 v True in s1
+               else s0
+  Notice that s0 is mentioned in both branches of the 'if', but 
+  only one of these two will actually be consumed.  But if we
+  float out to
+      let! s1 = writeMutVar s0 v True
+      in if blah then s1 else s0
+  the writeMutVar will be performed in both branches, which is
+  utterly wrong.
+
+* You cannot duplicate a has_side_effect primop.  You might wonder
+  how this can occur given the state token threading, but just look
+  at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get something like
+  this
+        p = case readMutVar# s v of
+              (# s', r #) -> (S# s', r)
+        s' = case p of (s', r) -> s'
+        r  = case p of (s', r) -> r
+
+  (All these bindings are boxed.)  If we inline p at its two call
+  sites, we get a catastrophe: because the read is performed once when
+  s' is demanded, and once when 'r' is demanded, which may be much 
+  later.  Utterly wrong.  Trac #3207 is real example of this happening.
+
+  However, it's fine to duplicate a can_fail primop.  That is
+  the difference between can_fail and has_side_effects.
+
+            can_fail     has_side_effects
+Discard        YES           YES
+Float in       YES           YES
+Float out      NO            NO
+Duplicate      YES           NO
+
+How do we achieve these effects?
 
- * A primop that is marked can_fail cannot be executed speculatively,
-   (becuase the might provoke the failure), but it can be repeated.
-   Why would you want to do that? Perhaps it might enable some
-   eta-expansion, if you can prove that the lambda is definitely
-   applied at least once. I guess we don't currently do that.
+Note [primOpOkForSpeculation]
+  * The "no-float-out" thing is achieved by ensuring that we never
+    let-bind a can_fail or has_side_effects primop.  The RHS of a
+    let-binding (which can float in and out freely) satisfies
+    exprOkForSpeculation.  And exprOkForSpeculation is false of
+    can_fail and no_side_effect.
 
- * A primop that is marked has_side_effects can be neither speculated
-   nor repeated; it must be executed exactly the right number of
-   times.
+  * So can_fail and no_side_effect primops will appear only as the
+    scrutinees of cases, and that's why the FloatIn pass is capable
+    of floating case bindings inwards.
 
-So has_side_effects implies can_fail.  We don't currently exploit
-the case of primops that can_fail but do not have_side_effects.
+  * The no-duplicate thing is done via primOpIsCheap, by making
+    has_side_effects things (very very very) not-cheap!
 
-Note [primOpOkForSpeculation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Sometimes we may choose to execute a PrimOp even though it isn't
-certain that its result will be required; ie execute them
-``speculatively''.  The same thing as ``cheap eagerness.'' Usually
-this is OK, because PrimOps are usually cheap, but it isn't OK for
-  * PrimOps that are expensive 
-  * PrimOps which can fail
-  * PrimOps that have side effects
-
-Ok-for-speculation also means that it's ok *not* to execute the
-primop. For example
-        case op a b of
-          r -> 3
-Here the result is not used, so we can discard the primop.  Anything
-that has side effects mustn't be dicarded in this way, of course!
-
-See also @primOpIsCheap@ (below).
-
-Note [primOpHasSideEffects]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Some primops have side-effects and so, for example, must not be
-duplicated.
-
-This predicate means a little more than just "modifies the state of
-the world".  What it really means is "it cosumes the state on its
-input".  To see what this means, consider
-
- let
-     t = case readMutVar# v s0 of (# s1, x #) -> (S# s1, x)
-     y = case t of (s,x) -> x
- in
-     ... y ... y ...
-
-Now, this is part of an ST or IO thread, so we are guaranteed by
-construction that the program uses the state in a single-threaded way.
-Whenever the state resulting from the readMutVar# is demanded, the
-readMutVar# will be performed, and it will be ordered correctly with
-respect to other operations in the monad.
-
-But there's another way this could go wrong: GHC can inline t into y,
-and inline y.  Then although the original readMutVar# will still be
-correctly ordered with respect to the other operations, there will be
-one or more extra readMutVar#s performed later, possibly out-of-order.
-This really happened; see #3207.
-
-The property we need to capture about readMutVar# is that it consumes
-the State# value on its input.  We must retain the linearity of the
-State#.
-
-Our fix for this is to declare any primop that must be used linearly
-as having side-effects.  When primOpHasSideEffects is True,
-primOpOkForSpeculation will be False, and hence primOpIsCheap will
-also be False, and applications of the primop will never be
-duplicated.
 
 \begin{code}
 primOpHasSideEffects :: PrimOp -> Bool
@@ -387,15 +404,19 @@ primOpCanFail :: PrimOp -> Bool
 #include "primop-can-fail.hs-incl"
 
 primOpOkForSpeculation :: PrimOp -> Bool
-  -- See Note [primOpOkForSpeculation]
+  -- See Note [primOpOkForSpeculation and primOpOkForFloatOut]
   -- See comments with CoreUtils.exprOkForSpeculation
 primOpOkForSpeculation op
   = not (primOpHasSideEffects op || primOpOutOfLine op || primOpCanFail op)
+
+primOpOkForSideEffects :: PrimOp -> Bool
+primOpOkForSideEffects op
+  = not (primOpHasSideEffects op)
 \end{code}
 
 
-primOpIsCheap
-~~~~~~~~~~~~~
+Note [primOpIsCheap]
+~~~~~~~~~~~~~~~~~~~~
 @primOpIsCheap@, as used in \tr{SimplUtils.lhs}.  For now (HACK
 WARNING), we just borrow some other predicates for a
 what-should-be-good-enough test.  "Cheap" means willing to call it more
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index 6745fda8cb..0601d7b7bf 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -24,7 +24,8 @@ module FloatIn ( floatInwards ) where
 #include "HsVersions.h"
 
 import CoreSyn
-import CoreUtils	( exprIsHNF, exprIsDupable )
+import MkCore
+import CoreUtils	( exprIsDupable, exprIsExpandable, exprOkForSideEffects )
 import CoreFVs		( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars )
 import Id		( isOneShotBndr, idType )
 import Var
@@ -119,26 +120,28 @@ the closure for a is not built.
 %************************************************************************
 
 \begin{code}
-type FreeVarsSet   = IdSet
+type FreeVarSet  = IdSet
+type BoundVarSet = IdSet
 
-type FloatingBinds = [(CoreBind, FreeVarsSet)]
-	-- In reverse dependency order (innermost binder first)
-
-	-- The FreeVarsSet is the free variables of the binding.  In the case
+data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
+	-- The FreeVarSet is the free variables of the binding.  In the case
 	-- of recursive bindings, the set doesn't include the bound
 	-- variables.
 
-fiExpr :: FloatingBinds		-- Binds we're trying to drop
+type FloatInBinds = [FloatInBind]
+	-- In reverse dependency order (innermost binder first)
+
+fiExpr :: FloatInBinds		-- Binds we're trying to drop
 				-- as far "inwards" as possible
        -> CoreExprWithFVs	-- Input expr
        -> CoreExpr		-- Result
 
 fiExpr to_drop (_, AnnLit lit)     = ASSERT( null to_drop ) Lit lit
 fiExpr to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty
-fiExpr to_drop (_, AnnVar v)       = mkCoLets' to_drop (Var v)
-fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co)
+fiExpr to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)
+fiExpr to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
 fiExpr to_drop (_, AnnCast expr (fvs_co, co))
-  = mkCoLets' (drop_here ++ co_drop) $
+  = wrapFloats (drop_here ++ co_drop) $
     Cast (fiExpr e_drop expr) co
   where
     [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop
@@ -149,10 +152,16 @@ need to get at all the arguments.  The next simplifier run will
 pull out any silly ones.
 
 \begin{code}
-fiExpr to_drop (_,AnnApp fun arg)
-  = mkCoLets' drop_here (App (fiExpr fun_drop fun) (fiExpr arg_drop arg))
+fiExpr to_drop (_,AnnApp fun arg@(arg_fvs, ann_arg))
+  | noFloatIntoRhs ann_arg  = wrapFloats drop_here $ wrapFloats arg_drop $
+                              App (fiExpr fun_drop fun) (fiExpr [] arg)
+       -- It's inconvenient to test for an unlifted arg here,
+       -- and it really doesn't matter if we float into one
+  | otherwise               = wrapFloats drop_here $
+                              App (fiExpr fun_drop fun) (fiExpr arg_drop arg)
   where
-    [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop
+    [drop_here, fun_drop, arg_drop] 
+      = sepBindsByDropPoint False [freeVarsOf fun, arg_fvs] to_drop
 \end{code}
 
 Note [Floating in past a lambda group]
@@ -199,7 +208,7 @@ fiExpr to_drop lam@(_, AnnLam _ _)
   = mkLams bndrs (fiExpr to_drop body)
 
   | otherwise	 	-- Dump it all here
-  = mkCoLets' to_drop (mkLams bndrs (fiExpr [] body))
+  = wrapFloats to_drop (mkLams bndrs (fiExpr [] body))
 
   where
     (bndrs, body) = collectAnnBndrs lam
@@ -220,7 +229,7 @@ We don't float lets inwards past an SCC.
 fiExpr to_drop (_, AnnTick tickish expr)
   | tickishScoped tickish
   =     -- Wimp out for now - we could push values in
-    mkCoLets' to_drop (Tick tickish (fiExpr [] expr))
+    wrapFloats to_drop (Tick tickish (fiExpr [] expr))
 
   | otherwise
   = Tick tickish (fiExpr to_drop expr)
@@ -266,7 +275,7 @@ can't have unboxed bindings.
 So we make "extra_fvs" which is the rhs_fvs of such bindings, and
 arrange to dump bindings that bind extra_fvs before the entire let.
 
-Note [extra_fvs (s): free variables of rules]
+Note [extra_fvs (2): free variables of rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider 
   let x{rule mentioning y} = rhs in body 
@@ -280,13 +289,13 @@ idFreeVars.
 fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
   = fiExpr new_to_drop body
   where
-    body_fvs = freeVarsOf body
+    body_fvs = freeVarsOf body `delVarSet` id
 
     rule_fvs = idRuleAndUnfoldingVars id	-- See Note [extra_fvs (2): free variables of rules]
     extra_fvs | noFloatIntoRhs ann_rhs
 	      || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs
 	      | otherwise		    = rule_fvs
-	-- See Note [extra_fvs (2): avoid floating into RHS]
+	-- See Note [extra_fvs (1): avoid floating into RHS]
 	-- No point in floating in only to float straight out again
 	-- Ditto ok-for-speculation unlifted RHSs
 
@@ -294,7 +303,8 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body)
 	= sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop
 
     new_to_drop = body_binds ++				-- the bindings used only in the body
-		  [(NonRec id rhs', rhs_fvs')] ++ 	-- the new binding itself
+		  [FB (unitVarSet id) rhs_fvs'
+                      (FloatLet (NonRec id rhs'))] ++ 	-- the new binding itself
 		  extra_binds ++			-- bindings from extra_fvs
 		  shared_binds  			-- the bindings used both in rhs and body
 
@@ -308,7 +318,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
   where
     (ids, rhss) = unzip bindings
     rhss_fvs = map freeVarsOf rhss
-    body_fvs = freeVarsOf body
+    body_fvs = freeVarsOf body 
 
 	-- See Note [extra_fvs (1,2)]
     rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids
@@ -320,7 +330,8 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
 	= sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop
 
     new_to_drop = body_binds ++		-- the bindings used only in the body
-		  [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++
+		  [FB (mkVarSet ids) rhs_fvs' 
+                      (FloatLet (Rec (fi_bind rhss_binds bindings)))] ++
 					-- The new binding itself
 		  extra_binds ++	-- Note [extra_fvs (1,2)]
 		  shared_binds		-- Used in more than one place
@@ -330,7 +341,7 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body)
 	       rule_fvs		-- Don't forget the rule variables!
 
     -- Push rhs_binds into the right hand side of the binding
-    fi_bind :: [FloatingBinds]	    -- one per "drop pt" conjured w/ fvs_of_rhss
+    fi_bind :: [FloatInBinds]	    -- one per "drop pt" conjured w/ fvs_of_rhss
 	    -> [(Id, CoreExprWithFVs)]
 	    -> [(Id, CoreExpr)]
 
@@ -344,17 +355,32 @@ bindings are: (a)~inside the scrutinee, (b)~inside one of the
 alternatives/default [default FVs always {\em first}!].
 
 \begin{code}
+fiExpr to_drop (_, AnnCase scrut case_bndr _ [(DEFAULT,[],rhs)])
+  | isUnLiftedType (idType case_bndr)
+  , exprOkForSideEffects (deAnnotate scrut)
+  = wrapFloats shared_binds $
+    fiExpr (case_float : rhs_binds) rhs
+  where
+    case_float = FB (unitVarSet case_bndr) scrut_fvs 
+                    (FloatCase scrut' case_bndr DEFAULT [])
+    scrut' = fiExpr scrut_binds scrut
+    [shared_binds, scrut_binds, rhs_binds]
+       = sepBindsByDropPoint False [freeVarsOf scrut, rhs_fvs] to_drop
+    rhs_fvs   = freeVarsOf rhs `delVarSet` case_bndr
+    scrut_fvs = freeVarsOf scrut
+
 fiExpr to_drop (_, AnnCase scrut case_bndr ty alts)
-  = mkCoLets' drop_here1 $
-    mkCoLets' drop_here2 $
+  = wrapFloats drop_here1 $
+    wrapFloats drop_here2 $
     Case (fiExpr scrut_drops scrut) case_bndr ty
 	 (zipWith fi_alt alts_drops_s alts)
   where
 	-- Float into the scrut and alts-considered-together just like App
-    [drop_here1, scrut_drops, alts_drops] = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
+    [drop_here1, scrut_drops, alts_drops] 
+       = sepBindsByDropPoint False [scrut_fvs, all_alts_fvs] to_drop
 
 	-- Float into the alts with the is_case flag set
-    (drop_here2 : alts_drops_s)           = sepBindsByDropPoint True alts_fvs alts_drops
+    (drop_here2 : alts_drops_s) = sepBindsByDropPoint True alts_fvs alts_drops
 
     scrut_fvs    = freeVarsOf scrut
     alts_fvs     = map alt_fvs alts
@@ -376,7 +402,9 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b)
 	-- boxing constructor into it, else we box it every time which is very bad
 	-- news indeed.
 
-noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs)	-- We'd just float right back out again...
+noFloatIntoRhs rhs = exprIsExpandable (deAnnotate' rhs)	
+       -- We'd just float right back out again...
+       -- Should match the test in SimplEnv.doFloatFromRhs
 
 is_one_shot :: Var -> Bool
 is_one_shot b = isId b && isOneShotBndr b
@@ -407,9 +435,9 @@ We have to maintain the order on these drop-point-related lists.
 \begin{code}
 sepBindsByDropPoint
     :: Bool		    -- True <=> is case expression
-    -> [FreeVarsSet]	    -- One set of FVs per drop point
-    -> FloatingBinds 	    -- Candidate floaters
-    -> [FloatingBinds]      -- FIRST one is bindings which must not be floated
+    -> [FreeVarSet]	    -- One set of FVs per drop point
+    -> FloatInBinds 	    -- Candidate floaters
+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated
 			    -- inside any drop point; the rest correspond
 			    -- one-to-one with the input list of FV sets
 
@@ -419,7 +447,7 @@ sepBindsByDropPoint
 -- a binding (let x = E in B) might have a specialised version of
 -- x (say x') stored inside x, but x' isn't free in E or B.
 
-type DropBox = (FreeVarsSet, FloatingBinds)
+type DropBox = (FreeVarSet, FloatInBinds)
 
 sepBindsByDropPoint _is_case drop_pts []
   = [] : [[] | _ <- drop_pts]	-- cut to the chase scene; it happens
@@ -427,19 +455,19 @@ sepBindsByDropPoint _is_case drop_pts []
 sepBindsByDropPoint is_case drop_pts floaters
   = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts))
   where
-    go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
+    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
 	-- The *first* one in the argument list is the drop_here set
-	-- The FloatingBinds in the lists are in the reverse of
-	-- the normal FloatingBinds order; that is, they are the right way round!
+	-- The FloatInBinds in the lists are in the reverse of
+	-- the normal FloatInBinds order; that is, they are the right way round!
 
     go [] drop_boxes = map (reverse . snd) drop_boxes
 
-    go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
+    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
 	= go binds new_boxes
 	where
 	  -- "here" means the group of bindings dropped at the top of the fork
 
-	  (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind)
+	  (used_here : used_in_flags) = [ fvs `intersectsVarSet` bndrs
 					| (fvs, _) <- drop_boxes]
 
 	  drop_here = used_here || not can_push
@@ -460,7 +488,7 @@ sepBindsByDropPoint is_case drop_pts floaters
 		   || (is_case && 		-- We are looking at case alternatives
 		       n_used_alts > 1 && 	-- It's used in more than one
 		       n_used_alts < n_alts &&	-- ...but not all
-		       bindIsDupable bind)	-- and we can duplicate the binding
+		       floatIsDupable bind)	-- and we can duplicate the binding
 
 	  new_boxes | drop_here = (insert here_box : fork_boxes)
 		    | otherwise = (here_box : new_fork_boxes)
@@ -476,14 +504,19 @@ sepBindsByDropPoint is_case drop_pts floaters
     go _ _ = panic "sepBindsByDropPoint/go"
 
 
-floatedBindsFVs :: FloatingBinds -> FreeVarsSet
-floatedBindsFVs binds = unionVarSets (map snd binds)
+floatedBindsFVs :: FloatInBinds -> FreeVarSet
+floatedBindsFVs binds = foldr (unionVarSet . fbFVs) emptyVarSet binds
+
+fbFVs :: FloatInBind -> VarSet
+fbFVs (FB _ fvs _) = fvs
 
-mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
-mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop
-	-- Remember to_drop is in *reverse* dependency order
+wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
+-- Remember FloatInBinds is in *reverse* dependency order
+wrapFloats []               e = e
+wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
 
-bindIsDupable :: Bind CoreBndr -> Bool
-bindIsDupable (Rec prs)    = all (exprIsDupable . snd) prs
-bindIsDupable (NonRec _ r) = exprIsDupable r
+floatIsDupable :: FloatBind -> Bool
+floatIsDupable (FloatCase scrut _ _ _) = exprIsDupable scrut
+floatIsDupable (FloatLet (Rec prs))    = all (exprIsDupable . snd) prs
+floatIsDupable (FloatLet (NonRec _ r)) = exprIsDupable r
 \end{code}
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index 00d6554790..18fc9b4af4 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -17,12 +17,12 @@ module FloatOut ( floatOutwards ) where
 
 import CoreSyn
 import CoreUtils
+import MkCore
 import CoreArity	( etaExpand )
 import CoreMonad	( FloatOutSwitches(..) )
 
 import DynFlags		( DynFlags, DynFlag(..) )
 import ErrUtils		( dumpIfSet_dyn )
-import DataCon          ( DataCon )
 import Id		( Id, idArity, isBottomingId )
 import Var		( Var )
 import SetLevels
@@ -326,7 +326,7 @@ floatExpr (Let bind body)
 floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
   = case case_spec of
       FloatMe dest_lvl  -- Case expression moves  
-        | [(DataAlt con, bndrs, rhs)] <- alts
+        | [(con@(DataAlt {}), bndrs, rhs)] <- alts
         -> case floatExpr scrut of { (fse, fde, scrut') ->
     	   case floatExpr rhs   of { (fsb, fdb, rhs') ->
     	   let 
@@ -444,13 +444,6 @@ partitionByMajorLevel.
 
 
 \begin{code}
-data FloatBind 
-  = FloatLet FloatLet  
-
-  | FloatCase CoreExpr Id DataCon [Var]       
-      -- case e of y { C ys -> ... }
-      -- See Note [Floating cases] in SetLevels
-
 type FloatLet = CoreBind	-- INVARIANT: a FloatLet is always lifted
 type MajorEnv = M.IntMap MinorEnv	  -- Keyed by major level
 type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level
@@ -491,7 +484,7 @@ flattenMinor = M.fold unionBags emptyBag
 emptyFloats :: FloatBinds
 emptyFloats = FB emptyBag M.empty
 
-unitCaseFloat :: Level -> CoreExpr -> Id -> DataCon -> [Var] -> FloatBinds
+unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds
 unitCaseFloat (Level major minor) e b con bs 
   = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs))))
 
@@ -514,12 +507,7 @@ plusMinor = M.unionWith unionBags
 
 install :: Bag FloatBind -> CoreExpr -> CoreExpr
 install defn_groups expr
-  = foldrBag install_group expr defn_groups
-  where
-    install_group (FloatLet defns) body 
-       = Let defns body
-    install_group (FloatCase e b con bs) body 
-       = Case e b (exprType body) [(DataAlt con, bs, body)]
+  = foldrBag wrapFloat expr defn_groups
 
 partitionByLevel
 	:: Level		-- Partitioning level
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 62f96e7c6e..8661d71e04 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -397,6 +397,7 @@ classifyFF (NonRec bndr rhs)
   | otherwise		     = FltCareful
 
 doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> OutExpr -> SimplEnv -> Bool
+-- If you change this function look also at FloatIn.noFloatFromRhs
 doFloatFromRhs lvl rec str rhs (SimplEnv {seFloats = Floats fs ff}) 
   =  not (isNilOL fs) && want_to_float && can_float
   where
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 2d84249e97..3bd95a71dc 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1766,7 +1766,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
  | all isDeadBinder bndrs       -- bndrs are [InId]
 
  , if isUnLiftedType (idType case_bndr)
-   then ok_for_spec         -- Satisfy the let-binding invariant
+   then elim_unlifted        -- Satisfy the let-binding invariant
    else elim_lifted
   = do  { -- pprTrace "case elim" (vcat [ppr case_bndr, ppr (exprIsHNF scrut),
           --                            ppr strict_case_bndr, ppr (scrut_is_var scrut),
@@ -1786,6 +1786,14 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
      || (is_plain_seq && ok_for_spec)
               -- Note: not the same as exprIsHNF
 
+    elim_unlifted 
+      | is_plain_seq = exprOkForSideEffects scrut
+            -- The entire case is dead, so we can drop it,
+            -- _unless_ the scrutinee has side effects
+      | otherwise    = exprOkForSpeculation scrut
+            -- The case-binder is alive, but we may be able
+            -- turn the case into a let, if the expression is ok-for-spec
+
     ok_for_spec      = exprOkForSpeculation scrut
     is_plain_seq     = isDeadBinder case_bndr	-- Evaluation *only* for effect
     strict_case_bndr = isStrictDmd (idDemandInfo case_bndr)