Make dumpIfSet_dyn_or use dumpSDoc

[ghc-hetmet.git] / compiler / coreSyn / CorePrep.lhs

diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index b8dd80f..0405716 100644 (file)
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -11,15 +11,18 @@ module CorePrep (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+import PrelNames       ( lazyIdKey, hasKey )

 import CoreUtils
 import CoreArity
 import CoreFVs
 import CoreUtils
 import CoreArity
 import CoreFVs

-import CoreLint
+import CoreMonad       ( endPass, CoreToDo(..) )

 import CoreSyn
 import CoreSyn

+import CoreSubst
+import OccurAnal        ( occurAnalyseExpr )

 import Type
 import Coercion
 import TyCon
 import Type
 import Coercion
 import TyCon

-import NewDemand
+import Demand

 import Var
 import VarSet
 import VarEnv
 import Var
 import VarSet
 import VarEnv

@@ -34,9 +37,11 @@ import OrdList
 import ErrUtils
 import DynFlags
 import Util
 import ErrUtils
 import DynFlags
 import Util

+import Pair

 import Outputable
 import MonadUtils
 import FastString
 import Outputable
 import MonadUtils
 import FastString

+import Data.List       ( mapAccumL )

 import Control.Monad
 \end{code}
 
 import Control.Monad
 \end{code}
 

@@ -74,9 +79,9 @@ The goal of this pass is to prepare for code generation.
     weaker guarantee of no clashes which the simplifier provides.
     And that is what the code generator needs.
 
     weaker guarantee of no clashes which the simplifier provides.
     And that is what the code generator needs.
 

-    We don't clone TyVars. The code gen doesn't need that, 
+    We don't clone TyVars or CoVars. The code gen doesn't need that, 

     and doing so would be tiresome because then we'd need
     and doing so would be tiresome because then we'd need

-    to substitute in types.
+    to substitute in types and coercions.

 
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is
 
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is

@@ -85,10 +90,11 @@ The goal of this pass is to prepare for code generation.
 8.  Inject bindings for the "implicit" Ids:
        * Constructor wrappers
        * Constructor workers
 8.  Inject bindings for the "implicit" Ids:
        * Constructor wrappers
        * Constructor workers

-       * Record selectors

     We want curried definitions for all of these in case they
     aren't inlined by some caller.
        
     We want curried definitions for all of these in case they
     aren't inlined by some caller.
        

+9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.lhs
+

 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.
 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.

@@ -99,19 +105,21 @@ Invariants
 Here is the syntax of the Core produced by CorePrep:
 
     Trivial expressions 
 Here is the syntax of the Core produced by CorePrep:
 
     Trivial expressions 

-       triv ::= lit |  var  | triv ty  |  /\a. triv  |  triv |> co
+       triv ::= lit |  var  
+              | triv ty  |  /\a. triv 
+              | truv co  |  /\c. triv  |  triv |> co

 
     Applications
 
     Applications

-       app ::= lit  |  var  |  app triv  |  app ty  |  app |> co
+       app ::= lit  |  var  |  app triv  |  app ty  | app co | app |> co

 
     Expressions
        body ::= app  
               | let(rec) x = rhs in body     -- Boxed only
               | case body of pat -> body
 
     Expressions
        body ::= app  
               | let(rec) x = rhs in body     -- Boxed only
               | case body of pat -> body

-             | /\a. body
+             | /\a. body | /\c. body 

               | body |> co
 
               | body |> co
 

-    Right hand sides (only place where lambdas can occur)
+    Right hand sides (only place where value lambdas can occur)

        rhs ::= /\a.rhs  |  \x.rhs  |  body
 
 We define a synonym for each of these non-terminals.  Functions
        rhs ::= /\a.rhs  |  \x.rhs  |  body
 
 We define a synonym for each of these non-terminals.  Functions

@@ -145,7 +153,7 @@ corePrepPgm dflags binds data_tycons = do
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
                       floats2 <- corePrepTopBinds implicit_binds
                       return (deFloatTop (floats1 `appendFloats` floats2))
 

-    endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+    endPass dflags CorePrep binds_out []

     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
     return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr

@@ -193,24 +201,38 @@ And then x will actually end up case-bound
 
 Note [CafInfo and floating]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [CafInfo and floating]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~

-What happens to the CafInfo on the floated bindings?  By default, all
-the CafInfos will be set to MayHaveCafRefs, which is safe.
-
-This might be pessimistic, because the floated binding might not refer
-to any CAFs and the GC will end up doing more traversal than is
-necessary, but it's still better than not floating the bindings at
-all, because then the GC would have to traverse the structure in the
-heap instead.  Given this, we decided not to try to get the CafInfo on
-the floated bindings correct, because it looks difficult.
-
-But that means we can't float anything out of a NoCafRefs binding.
-Consider       f = g (h x)
-If f is NoCafRefs, we don't want to convert to
-              sat = h x
-               f = g sat
-where sat conservatively says HasCafRefs, because now f's info
-is wrong.  I don't think this is common, so we simply switch off
-floating in this case.
+What happens when we try to float bindings to the top level?  At this
+point all the CafInfo is supposed to be correct, and we must make certain
+that is true of the new top-level bindings.  There are two cases
+to consider
+
+a) The top-level binding is marked asCafRefs.  In that case we are
+   basically fine.  The floated bindings had better all be lazy lets,
+   so they can float to top level, but they'll all have HasCafRefs
+   (the default) which is safe.
+
+b) The top-level binding is marked NoCafRefs.  This really happens
+   Example.  CoreTidy produces
+      $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
+   Now CorePrep has to eta-expand to
+      $fApplicativeSTM = let sat = \xy. retry x y
+                         in D:Alternative sat ...blah...
+   So what we *want* is
+      sat [NoCafRefs] = \xy. retry x y
+      $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
+   
+   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
+   *and* substutite the modified 'sat' into the old RHS.  
+
+   It should be the case that 'sat' is itself [NoCafRefs] (a value, no
+   cafs) else the original top-level binding would not itself have been
+   marked [NoCafRefs].  The DEBUG check in CoreToStg for
+   consistentCafInfo will find this.
+
+This is all very gruesome and horrible. It would be better to figure
+out CafInfo later, after CorePrep.  We'll do that in due course. 
+Meanwhile this horrible hack works.
+

 
 Note [Data constructor workers]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 Note [Data constructor workers]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -230,6 +252,61 @@ always fully applied, and the bindings are just there to support
 partial applications. But it's easier to let them through.
 
 
 partial applications. But it's easier to let them through.
 
 

+Note [Dead code in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine that we got an input program like this:
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g True (Just x) + g () (Just x), g)
+    where
+      g :: Show a => a -> Maybe Int -> Int
+      g _ Nothing = x
+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
+
+After specialisation and SpecConstr, we would get something like this:
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
+    where
+      {-# RULES g $dBool = g$Bool 
+                g $dUnit = g$Unit #-}
+      g = ...
+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
+      g$Bool = ...
+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
+      g$Unit = ...
+      g$Bool_True_Just = ...
+      g$Unit_Unit_Just = ...
+
+Note that the g$Bool and g$Unit functions are actually dead code: they are only kept
+alive by the occurrence analyser because they are referred to by the rules of g,
+which is being kept alive by the fact that it is used (unspecialised) in the returned pair.
+
+However, at the CorePrep stage there is no way that the rules for g will ever fire,
+and it really seems like a shame to produce an output program that goes to the trouble
+of allocating a closure for the unreachable g$Bool and g$Unit functions.
+
+The way we fix this is to:
+ * In cloneBndr, drop all unfoldings/rules
+ * In deFloatTop, run the occurrence analyser on each top-level RHS to drop
+   the dead local bindings
+
+The reason we don't just OccAnal the whole output of CorePrep is that the tidier
+ensures that all top-level binders are GlobalIds, so they don't show up in the free
+variables any longer. So if you run the occurrence analyser on the output of CoreTidy
+(or later) you e.g. turn this program:
+
+  Rec {
+  f = ... f ...
+  }
+
+Into this one:
+
+  f = ... f ...
+
+(Since f is not considered to be free in its own RHS.)
+
+

 %************************************************************************
 %*                                                                     *
                The main code
 %************************************************************************
 %*                                                                     *
                The main code

@@ -242,7 +319,7 @@ cpeBind :: TopLevelFlag
        -> UniqSM (CorePrepEnv, Floats)
 cpeBind top_lvl env (NonRec bndr rhs)
   = do { (_, bndr1) <- cloneBndr env bndr
        -> UniqSM (CorePrepEnv, Floats)
 cpeBind top_lvl env (NonRec bndr rhs)
   = do { (_, bndr1) <- cloneBndr env bndr

-       ; let is_strict   = isStrictDmd (idNewDemandInfo bndr)
+       ; let is_strict   = isStrictDmd (idDemandInfo bndr)

              is_unlifted = isUnLiftedType (idType bndr)
        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive 
                                                  (is_strict || is_unlifted) 
              is_unlifted = isUnLiftedType (idType bndr)
        ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive 
                                                  (is_strict || is_unlifted) 

@@ -260,7 +337,7 @@ cpeBind top_lvl env (Rec pairs)
        ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
 
        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff
        ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss
 
        ; let (floats_s, bndrs2, rhss2) = unzip3 stuff

-             all_pairs = foldrOL add_float (bndrs1 `zip` rhss2)
+             all_pairs = foldrOL add_float (bndrs2 `zip` rhss2)

                                           (concatFloats floats_s)
        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
                         unitFloat (FloatLet (Rec all_pairs))) }
                                           (concatFloats floats_s)
        ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
                         unitFloat (FloatLet (Rec all_pairs))) }

@@ -274,38 +351,89 @@ cpeBind top_lvl env (Rec pairs)
 ---------------
 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
        -> CorePrepEnv -> Id -> CoreExpr
 ---------------
 cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
        -> CorePrepEnv -> Id -> CoreExpr

-       -> UniqSM (Floats, Id, CoreExpr)
+       -> UniqSM (Floats, Id, CpeRhs)

 -- Used for all bindings
 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
 -- Used for all bindings
 cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs

-  = do { (floats, rhs') <- cpeRhs want_float (idArity bndr) env rhs
-
-               -- Record if the binder is evaluated
+  = do { (floats1, rhs1) <- cpeRhsE env rhs
+
+       -- See if we are allowed to float this stuff out of the RHS
+       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
+
+       -- Make the arity match up
+       ; (floats3, rhs')
+            <- if manifestArity rhs1 <= arity 
+              then return (floats2, cpeEtaExpand arity rhs2)
+              else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+                              -- Note [Silly extra arguments]
+                   (do { v <- newVar (idType bndr)
+                       ; let float = mkFloat False False v rhs2
+                       ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
+
+       -- Record if the binder is evaluated
+       -- and otherwise trim off the unfolding altogether
+       -- It's not used by the code generator; getting rid of it reduces
+       -- heap usage and, since we may be changing uniques, we'd have
+       -- to substitute to keep it right

        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
        ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding

-                          | otherwise      = bndr
+                          | otherwise      = bndr `setIdUnfolding` noUnfolding

 
 

-       ; return (floats, bndr', rhs') }
+       ; return (floats3, bndr', rhs') }

   where
   where

-    want_float floats rhs 
-     | isTopLevel top_lvl = wantFloatTop bndr floats
-     | otherwise          = wantFloatNested is_rec is_strict_or_unlifted floats rhs
-
-
+    arity = idArity bndr       -- We must match this arity
+
+    ---------------------
+    float_from_rhs floats rhs
+      | isEmptyFloats floats = return (emptyFloats, rhs)
+      | isTopLevel top_lvl    = float_top    floats rhs
+      | otherwise             = float_nested floats rhs
+
+    ---------------------
+    float_nested floats rhs
+      | wantFloatNested is_rec is_strict_or_unlifted floats rhs
+                  = return (floats, rhs)
+      | otherwise = dont_float floats rhs
+
+    ---------------------
+    float_top floats rhs       -- Urhgh!  See Note [CafInfo and floating]
+      | mayHaveCafRefs (idCafInfo bndr)
+      , allLazyTop floats
+      = return (floats, rhs)
+
+      -- So the top-level binding is marked NoCafRefs
+      | Just (floats', rhs') <- canFloatFromNoCaf floats rhs
+      = return (floats', rhs')
+
+      | otherwise
+      = dont_float floats rhs
+
+    ---------------------
+    dont_float floats rhs
+      -- Non-empty floats, but do not want to float from rhs
+      -- So wrap the rhs in the floats
+      -- But: rhs1 might have lambdas, and we can't
+      --      put them inside a wrapBinds
+      = do { body <- rhsToBodyNF rhs
+          ; return (emptyFloats, wrapBinds floats body) } 
+
+{- Note [Silly extra arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we had this
+       f{arity=1} = \x\y. e
+We *must* match the arity on the Id, so we have to generate
+        f' = \x\y. e
+       f  = \x. f' x
+
+It's a bizarre case: why is the arity on the Id wrong?  Reason
+(in the days of __inline_me__): 
+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
+When InlineMe notes go away this won't happen any more.  But
+it seems good for CorePrep to be robust.
+-}

 
 -- ---------------------------------------------------------------------------
 --             CpeRhs: produces a result satisfying CpeRhs
 -- ---------------------------------------------------------------------------
 
 
 -- ---------------------------------------------------------------------------
 --             CpeRhs: produces a result satisfying CpeRhs
 -- ---------------------------------------------------------------------------
 

-cpeRhs :: (Floats -> CpeRhs -> Bool)   -- Float the floats out
-       -> Arity                -- Guarantees an Rhs with this manifest arity
-       -> CorePrepEnv
-       -> CoreExpr     -- Expression and its type
-       -> UniqSM (Floats, CpeRhs)
-cpeRhs want_float arity env expr
-  = do { (floats, rhs) <- cpeRhsE env expr
-       ; if want_float floats rhs
-                then return (floats,      cpeEtaExpand arity rhs)
-                else return (emptyFloats, cpeEtaExpand arity (wrapBinds floats rhs)) }
-

 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- If
 --     e  ===>  (bs, e')
 cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- If
 --     e  ===>  (bs, e')

@@ -315,10 +443,16 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- For example
 --     f (g x)   ===>   ([v = g x], f v)
 
 -- For example
 --     f (g x)   ===>   ([v = g x], f v)
 

-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
-cpeRhsE env expr@(App {})  = cpeApp env expr
-cpeRhsE env expr@(Var {})  = cpeApp env expr
+cpeRhsE _env expr@(Type {})     = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {})      = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {})       = cpeApp env expr
+
+cpeRhsE env (Var f `App` _ `App` arg)
+  | f `hasKey` lazyIdKey         -- Replace (lazy a) by a
+  = cpeRhsE env arg              -- See Note [lazyId magic] in MkId
+
+cpeRhsE env expr@(App {}) = cpeApp env expr

 
 cpeRhsE env (Let bind expr)
   = do { (env', new_binds) <- cpeBind NotTopLevel env bind
 
 cpeRhsE env (Let bind expr)
   = do { (env', new_binds) <- cpeBind NotTopLevel env bind

@@ -377,8 +511,13 @@ cpeBody env expr
        ; return (floats1 `appendFloats` floats2, body) }
 
 --------
        ; return (floats1 `appendFloats` floats2, body) }
 
 --------

+rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
+rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
+                    ; return (wrapBinds floats body) }
+
+--------

 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
 rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)

--- Remove top level lambdas by let-bindinig
+-- Remove top level lambdas by let-binding

 
 rhsToBody (Note n expr)
         -- You can get things like
 
 rhsToBody (Note n expr)
         -- You can get things like

@@ -391,7 +530,7 @@ rhsToBody (Cast e co)
        ; return (floats, Cast e' co) }
 
 rhsToBody expr@(Lam {})
        ; return (floats, Cast e' co) }
 
 rhsToBody expr@(Lam {})

-  | Just no_lam_result <- tryEtaReduce bndrs body
+  | Just no_lam_result <- tryEtaReducePrep bndrs body

   = return (emptyFloats, no_lam_result)
   | all isTyVar bndrs          -- Type lambdas are ok
   = return (emptyFloats, expr)
   = return (emptyFloats, no_lam_result)
   | all isTyVar bndrs          -- Type lambdas are ok
   = return (emptyFloats, expr)

@@ -444,9 +583,13 @@ cpeApp env expr
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 

+    collect_args (App fun arg@(Coercion arg_co)) depth
+      = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+           ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+

     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)

-           ; let
+          ; let

               (ss1, ss_rest)   = case ss of
                                    (ss1:ss_rest) -> (ss1,     ss_rest)
                                    []            -> (lazyDmd, [])
               (ss1, ss_rest)   = case ss of
                                    (ss1:ss_rest) -> (ss1,     ss_rest)
                                    []            -> (lazyDmd, [])

@@ -461,7 +604,7 @@ cpeApp env expr
            ; let v2 = lookupCorePrepEnv env v1
            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
        where
            ; let v2 = lookupCorePrepEnv env v1
            ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) }
        where

-         stricts = case idNewStrictness v of
+         stricts = case idStrictness v of

                        StrictSig (DmdType _ demands _)
                            | listLengthCmp demands depth /= GT -> demands
                                    -- length demands <= depth
                        StrictSig (DmdType _ demands _)
                            | listLengthCmp demands depth /= GT -> demands
                                    -- length demands <= depth

@@ -473,7 +616,7 @@ cpeApp env expr
                -- partial application might be seq'd
 
     collect_args (Cast fun co) depth
                -- partial application might be seq'd
 
     collect_args (Cast fun co) depth

-      = do { let (_ty1,ty2) = coercionKind co
+      = do { let Pair _ty1 ty2 = coercionKind co

            ; (fun', hd, _, floats, ss) <- collect_args fun depth
            ; return (Cast fun' co, hd, ty2, floats, ss) }
           
            ; (fun', hd, _, floats, ss) <- collect_args fun depth
            ; return (Cast fun' co, hd, ty2, floats, ss) }
           

@@ -482,10 +625,10 @@ cpeApp env expr
       = collect_args fun depth  -- They aren't used by the code generator
 
        -- N-variable fun, better let-bind it
       = collect_args fun depth  -- They aren't used by the code generator
 
        -- N-variable fun, better let-bind it

-       -- ToDo: perhaps we can case-bind rather than let-bind this closure,
-       -- since it is sure to be evaluated.

     collect_args fun depth
       = do { (fun_floats, fun') <- cpeArg env True fun ty
     collect_args fun depth
       = do { (fun_floats, fun') <- cpeArg env True fun ty

+                         -- The True says that it's sure to be evaluated,
+                         -- so we'll end up case-binding it

            ; return (fun', (fun', depth), ty, fun_floats, []) }
         where
          ty = exprType fun
            ; return (fun', (fun', depth), ty, fun_floats, []) }
         where
          ty = exprType fun

@@ -498,14 +641,21 @@ cpeApp env expr
 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
        -> UniqSM (Floats, CpeTriv)
 cpeArg env is_strict arg arg_ty
 cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
        -> UniqSM (Floats, CpeTriv)
 cpeArg env is_strict arg arg_ty

-  | cpe_ExprIsTrivial arg      -- Do not eta expand etc a trivial argument
-  = cpeBody env arg    -- Must still do substitution though
-  | otherwise
-  = do { (floats, arg') <- cpeRhs want_float
-                                         (exprArity arg) env arg
-       ; v <- newVar arg_ty
-       ; let arg_float = mkFloat is_strict is_unlifted v arg'
-       ; return (addFloat floats arg_float, Var v) }
+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
+       ; (floats2, arg2) <- if want_float floats1 arg1 
+                                   then return (floats1, arg1)
+                                   else do { body1 <- rhsToBodyNF arg1
+                                   ; return (emptyFloats, wrapBinds floats1 body1) } 
+               -- Else case: arg1 might have lambdas, and we can't
+               --            put them inside a wrapBinds
+
+       ; if cpe_ExprIsTrivial arg2    -- Do not eta expand a trivial argument
+         then return (floats2, arg2)
+         else do
+       { v <- newVar arg_ty
+       ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
+                    arg_float = mkFloat is_strict is_unlifted v arg3
+       ; return (addFloat floats2 arg_float, Var v) } }

   where
     is_unlifted = isUnLiftedType arg_ty
     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
   where
     is_unlifted = isUnLiftedType arg_ty
     want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)

@@ -551,9 +701,7 @@ maybeSaturate fn expr n_args
 
 -------------
 saturateDataToTag :: CpeApp -> UniqSM CpeApp
 
 -------------
 saturateDataToTag :: CpeApp -> UniqSM CpeApp

--- Horrid: ensure that the arg of data2TagOp is evaluated
---   (data2tag x) -->  (case x of y -> data2tag y)
--- (yuk yuk) take into account the lambdas we've now introduced
+-- See Note [dataToTag magic]

 saturateDataToTag sat_expr
   = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
        ; eta_body' <- eval_data2tag_arg eta_body
 saturateDataToTag sat_expr
   = do { let (eta_bndrs, eta_body) = collectBinders sat_expr
        ; eta_body' <- eval_data2tag_arg eta_body

@@ -577,7 +725,14 @@ saturateDataToTag sat_expr
        = pprPanic "eval_data2tag" (ppr other)
 \end{code}
 
        = pprPanic "eval_data2tag" (ppr other)
 \end{code}
 

+Note [dataToTag magic]
+~~~~~~~~~~~~~~~~~~~~~~
+Horrid: we must ensure that the arg of data2TagOp is evaluated
+  (data2tag x) -->  (case x of y -> data2tag y)
+(yuk yuk) take into account the lambdas we've now introduced

 
 

+How might it not be evaluated?  Well, we might have floated it out
+of the scope of a `seq`, or dropped the `seq` altogether.

 
 
 %************************************************************************
 
 
 %************************************************************************

@@ -597,7 +752,6 @@ ignoreNote :: Note -> Bool
 -- want to get this:
 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 ignoreNote (CoreNote _) = True 
 -- want to get this:
 --     unzip = /\ab \xs. (__inline_me__ ...) a b xs
 ignoreNote (CoreNote _) = True 

-ignoreNote InlineMe     = True

 ignoreNote _other       = False
 
 
 ignoreNote _other       = False
 
 

@@ -605,10 +759,10 @@ cpe_ExprIsTrivial :: CoreExpr -> Bool
 -- Version that doesn't consider an scc annotation to be trivial.
 cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True
 -- Version that doesn't consider an scc annotation to be trivial.
 cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True

+cpe_ExprIsTrivial (Coercion _)             = True

 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e

-cpe_ExprIsTrivial (Note (SCC _) _)         = False
-cpe_ExprIsTrivial (Note _ e)               = cpe_ExprIsTrivial e
+cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e

 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False

@@ -655,7 +809,7 @@ Instead CoreArity.etaExpand gives
                f = /\a -> \y -> let s = h 3 in g s y
 
 \begin{code}
                f = /\a -> \y -> let s = h 3 in g s y
 
 \begin{code}

-cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr
+cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs

 cpeEtaExpand arity expr
   | arity == 0 = expr
   | otherwise  = etaExpand arity expr
 cpeEtaExpand arity expr
   | arity == 0 = expr
   | otherwise  = etaExpand arity expr

@@ -673,8 +827,8 @@ get to a partial application:
     ==> case x of { p -> map f }
 
 \begin{code}
     ==> case x of { p -> map f }
 
 \begin{code}

-tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
-tryEtaReduce bndrs expr@(App _ _)
+tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
+tryEtaReducePrep bndrs expr@(App _ _)

   | ok_to_eta_reduce f &&
     n_remaining >= 0 &&
     and (zipWith ok bndrs last_args) &&
   | ok_to_eta_reduce f &&
     n_remaining >= 0 &&
     and (zipWith ok bndrs last_args) &&

@@ -694,15 +848,15 @@ tryEtaReduce bndrs expr@(App _ _)
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
     ok_to_eta_reduce _       = False --safe. ToDo: generalise
 

-tryEtaReduce bndrs (Let bind@(NonRec _ r) body)
+tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)

   | not (any (`elemVarSet` fvs) bndrs)
   | not (any (`elemVarSet` fvs) bndrs)

-  = case tryEtaReduce bndrs body of
+  = case tryEtaReducePrep bndrs body of

        Just e -> Just (Let bind e)
        Nothing -> Nothing
   where
     fvs = exprFreeVars r
 
        Just e -> Just (Let bind e)
        Nothing -> Nothing
   where
     fvs = exprFreeVars r
 

-tryEtaReduce _ _ = Nothing
+tryEtaReducePrep _ _ = Nothing

 \end{code}
 
 
 \end{code}
 
 

@@ -722,18 +876,37 @@ type RhsDemand = Bool  -- True => used strictly; hence not top-level, non-recurs
 
 \begin{code}
 data FloatingBind 
 
 \begin{code}
 data FloatingBind 

-  = FloatLet CoreBind          -- Rhs of bindings are CpeRhss
-  | FloatCase Id CpeBody Bool   -- The bool indicates "ok-for-speculation"
+  = FloatLet CoreBind   -- Rhs of bindings are CpeRhss
+                        -- They are always of lifted type;
+                        -- unlifted ones are done with FloatCase
+ 
+ | FloatCase 
+      Id CpeBody 
+      Bool             -- The bool indicates "ok-for-speculation"

 
 data Floats = Floats OkToSpec (OrdList FloatingBind)
 
 
 data Floats = Floats OkToSpec (OrdList FloatingBind)
 

+instance Outputable FloatingBind where
+  ppr (FloatLet b) = ppr b
+  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
+
+instance Outputable Floats where
+  ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
+                         braces (vcat (map ppr (fromOL fs)))
+
+instance Outputable OkToSpec where
+  ppr OkToSpec    = ptext (sLit "OkToSpec")
+  ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk")
+  ppr NotOkToSpec = ptext (sLit "NotOkToSpec")
+ 

 -- Can we float these binds out of the rhs of a let?  We cache this decision
 -- to avoid having to recompute it in a non-linear way when there are
 -- deeply nested lets.
 data OkToSpec
 -- Can we float these binds out of the rhs of a let?  We cache this decision
 -- to avoid having to recompute it in a non-linear way when there are
 -- deeply nested lets.
 data OkToSpec

-   = NotOkToSpec       -- definitely not
-   | OkToSpec          -- yes
-   | IfUnboxedOk       -- only if floating an unboxed binding is ok
+   = OkToSpec          -- Lazy bindings of lifted type
+   | IfUnboxedOk       -- A mixture of lazy lifted bindings and n
+                       -- ok-to-speculate unlifted bindings
+   | NotOkToSpec       -- Some not-ok-to-speculate unlifted bindings

 
 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
 mkFloat is_strict is_unlifted bndr rhs
 
 mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind
 mkFloat is_strict is_unlifted bndr rhs

@@ -748,7 +921,10 @@ mkFloat is_strict is_unlifted bndr rhs
 emptyFloats :: Floats
 emptyFloats = Floats OkToSpec nilOL
 
 emptyFloats :: Floats
 emptyFloats = Floats OkToSpec nilOL
 

-wrapBinds :: Floats -> CoreExpr -> CoreExpr
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats _ bs) = isNilOL bs
+
+wrapBinds :: Floats -> CpeBody -> CpeBody

 wrapBinds (Floats _ binds) body
   = foldrOL mk_bind body binds
   where
 wrapBinds (Floats _ binds) body
   = foldrOL mk_bind body binds
   where

@@ -785,27 +961,70 @@ combine IfUnboxedOk _ = IfUnboxedOk
 combine _ IfUnboxedOk = IfUnboxedOk
 combine _ _           = OkToSpec
     
 combine _ IfUnboxedOk = IfUnboxedOk
 combine _ _           = OkToSpec
     

-instance Outputable FloatingBind where
-  ppr (FloatLet bind)        = text "FloatLet" <+> ppr bind
-  ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs
-

 deFloatTop :: Floats -> [CoreBind]
 -- For top level only; we don't expect any FloatCases
 deFloatTop (Floats _ floats)
   = foldrOL get [] floats
   where
 deFloatTop :: Floats -> [CoreBind]
 -- For top level only; we don't expect any FloatCases
 deFloatTop (Floats _ floats)
   = foldrOL get [] floats
   where

-    get (FloatLet b) bs = b:bs
+    get (FloatLet b) bs = occurAnalyseRHSs b : bs

     get b            _  = pprPanic "corePrepPgm" (ppr b)
     get b            _  = pprPanic "corePrepPgm" (ppr b)

+    
+    -- See Note [Dead code in CorePrep]
+    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e)
+    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]

 
 -------------------------------------------
 
 -------------------------------------------

-wantFloatTop :: Id -> Floats -> Bool
+canFloatFromNoCaf ::  Floats -> CpeRhs -> Maybe (Floats, CpeRhs)

        -- Note [CafInfo and floating]
        -- Note [CafInfo and floating]

-wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr)
-                          && allLazyTop floats
+canFloatFromNoCaf (Floats ok_to_spec fs) rhs
+  | OkToSpec <- ok_to_spec          -- Worth trying
+  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
+  = Just (Floats OkToSpec fs', subst_expr subst rhs)
+  | otherwise              
+  = Nothing
+  where
+    subst_expr = substExpr (text "CorePrep")
+
+    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
+       -> Maybe (Subst, OrdList FloatingBind)
+
+    go (subst, fbs_out) [] = Just (subst, fbs_out)
+    
+    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) 
+      | rhs_ok r
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
+      where
+        (subst', b') = set_nocaf_bndr subst b
+        new_fb = FloatLet (NonRec b' (subst_expr subst r))
+
+    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
+      | all rhs_ok rs
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
+      where
+        (bs,rs) = unzip prs
+        (subst', bs') = mapAccumL set_nocaf_bndr subst bs
+        rs' = map (subst_expr subst') rs
+        new_fb = FloatLet (Rec (bs' `zip` rs'))
+
+    go _ _ = Nothing     -- Encountered a caffy binding
+
+    ------------
+    set_nocaf_bndr subst bndr 
+      = (extendIdSubst subst bndr (Var bndr'), bndr')
+      where
+        bndr' = bndr `setIdCafInfo` NoCafRefs
+
+    ------------
+    rhs_ok :: CoreExpr -> Bool
+    -- We can only float to top level from a NoCaf thing if
+    -- the new binding is static. However it can't mention
+    -- any non-static things or it would *already* be Caffy
+    rhs_ok = rhsIsStatic (\_ -> False)

 
 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec strict_or_unlifted floats rhs
 
 wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec strict_or_unlifted floats rhs

-  = strict_or_unlifted
+  =  isEmptyFloats floats
+  || strict_or_unlifted

   || (allLazyNested is_rec floats && exprIsHNF rhs)
        -- Why the test for allLazyNested? 
        --      v = f (x `divInt#` y)
   || (allLazyNested is_rec floats && exprIsHNF rhs)
        -- Why the test for allLazyNested? 
        --      v = f (x `divInt#` y)

@@ -860,13 +1079,19 @@ cloneBndrs env bs = mapAccumLM cloneBndr env bs
 
 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 cloneBndr env bndr
 
 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 cloneBndr env bndr

-  | isLocalId bndr
+  | isLocalId bndr, not (isCoVar bndr)

   = do bndr' <- setVarUnique bndr <$> getUniqueM
   = do bndr' <- setVarUnique bndr <$> getUniqueM

-       return (extendCorePrepEnv env bndr bndr', bndr')
+       
+       -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
+       -- so that we can drop more stuff as dead code.
+       -- See also Note [Dead code in CorePrep]
+       let bndr'' = bndr' `setIdUnfolding` noUnfolding
+                          `setIdSpecialisation` emptySpecInfo
+       return (extendCorePrepEnv env bndr bndr'', bndr'')

 
   | otherwise  -- Top level things, which we don't want
                -- to clone, have become GlobalIds by now
 
   | otherwise  -- Top level things, which we don't want
                -- to clone, have become GlobalIds by now

-               -- And we don't clone tyvars
+               -- And we don't clone tyvars, or coercion variables

   = return (env, bndr)
   
 
   = return (env, bndr)