[project @ 2004-10-01 16:39:26 by simonpj]
[ghc-hetmet.git] / ghc / compiler / coreSyn / CorePrep.lhs
index 6b3877d..925a51f 100644 (file)
@@ -10,29 +10,31 @@ module CorePrep (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 
-import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand )
+import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
 import CoreFVs ( exprFreeVars )
 import CoreLint        ( endPass )
 import CoreSyn
 import CoreFVs ( exprFreeVars )
 import CoreLint        ( endPass )
 import CoreSyn
-import Type    ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
-                 isUnLiftedType, isUnboxedTupleType, repType,  
-                 uaUTy, usOnce, usMany, seqType )
-import Demand  ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
-import PrimOp  ( PrimOp(..), setCCallUnique )
-import Var     ( Var, Id, setVarUnique, globalIdDetails, setGlobalIdDetails )
+import Type    ( Type, applyTy, splitFunTy_maybe, 
+                 isUnLiftedType, isUnboxedTupleType, seqType )
+import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
+import Var     ( Var, Id, setVarUnique )
 import VarSet
 import VarEnv
 import VarSet
 import VarEnv
-import Id      ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
-                 setIdType, isPrimOpId_maybe, isLocalId, modifyIdInfo,
-                 hasNoBinding
+import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity,
+                 isFCallId, isGlobalId, isImplicitId,
+                 isLocalId, hasNoBinding, idNewStrictness, 
+                 idUnfolding, isDataConWorkId_maybe
                )
                )
-import IdInfo  ( GlobalIdDetails(..) )
-import HscTypes ( ModDetails(..) )
+import HscTypes   ( TypeEnv, typeEnvElts, TyThing( AnId ) )
+import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+                   RecFlag(..), isNonRec
+                 )
 import UniqSupply
 import Maybes
 import OrdList
 import ErrUtils
 import CmdLineOpts
 import UniqSupply
 import Maybes
 import OrdList
 import ErrUtils
 import CmdLineOpts
+import Util       ( listLengthCmp )
 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 
@@ -61,98 +63,271 @@ The goal of this pass is to prepare for code generation.
 4.  Ensure that lambdas only occur as the RHS of a binding
     (The code generator can't deal with anything else.)
 
 4.  Ensure that lambdas only occur as the RHS of a binding
     (The code generator can't deal with anything else.)
 
-5.  Do the seq/par munging.  See notes with mkCase below.
+5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
+
+6.  Clone all local Ids.
+    This means that all such Ids are unique, rather than the 
+    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, 
+    and doing so would be tiresome because then we'd need
+    to substitute in types.
 
 
-6.  Clone all local Ids.  This means that Tidy Core has the property
-    that all Ids are unique, rather than the weaker guarantee of
-    no clashes which the simplifier provides.
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is
     rather like the cloning step above.
 
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is
     rather like the cloning step above.
 
+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.
+       
 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.
 
   
 
-
 -- -----------------------------------------------------------------------------
 -- Top level stuff
 -- -----------------------------------------------------------------------------
 
 \begin{code}
 -- -----------------------------------------------------------------------------
 -- Top level stuff
 -- -----------------------------------------------------------------------------
 
 \begin{code}
-corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
-corePrepPgm dflags mod_details
+corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
+corePrepPgm dflags binds types
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
-       let new_binds = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
-        endPass dflags "CorePrep" Opt_D_dump_sat new_binds
-       return (mod_details { md_binds = new_binds })
+
+       let implicit_binds = mkImplicitBinds types
+               -- NB: we must feed mkImplicitBinds through corePrep too
+               -- so that they are suitably cloned and eta-expanded
+
+           binds_out = initUs_ us (
+                         corePrepTopBinds binds        `thenUs` \ floats1 ->
+                         corePrepTopBinds implicit_binds       `thenUs` \ floats2 ->
+                         returnUs (deFloatTop (floats1 `appendFloats` floats2))
+                       )
+           
+        endPass dflags "CorePrep" Opt_D_dump_prep binds_out
+       return binds_out
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
        let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
        let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
-       dumpIfSet_dyn dflags Opt_D_dump_sat "CorePrep" 
+       dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" 
                     (ppr new_expr)
        return new_expr
                     (ppr new_expr)
        return new_expr
+\end{code}
+
+-- -----------------------------------------------------------------------------
+-- Implicit bindings
+-- -----------------------------------------------------------------------------
+
+Create any necessary "implicit" bindings (data constructors etc).
+Namely:
+       * Constructor workers
+       * Constructor wrappers
+       * Data type record selectors
+       * Class op selectors
+
+In the latter three cases, the Id contains the unfolding to use for
+the binding.  In the case of data con workers we create the rather 
+strange (non-recursive!) binding
+
+       $wC = \x y -> $wC x y
+
+i.e. a curried constructor that allocates.  This means that we can
+treat the worker for a constructor like any other function in the rest
+of the compiler.  The point here is that CoreToStg will generate a
+StgConApp for the RHS, rather than a call to the worker (which would
+give a loop).  As Lennart says: the ice is thin here, but it works.
+
+Hmm.  Should we create bindings for dictionary constructors?  They are
+always fully applied, and the bindings are just there to support
+partial applications. But it's easier to let them through.
+
+\begin{code}
+mkImplicitBinds type_env
+  = [ NonRec id (get_unfolding id)
+    | AnId id <- typeEnvElts type_env, isImplicitId id ]
+       -- The type environment already contains all the implicit Ids, 
+       -- so we just filter them out
+       --
+       -- The etaExpand is so that the manifest arity of the
+       -- binding matches its claimed arity, which is an 
+       -- invariant of top level bindings going into the code gen
+
+get_unfolding id       -- See notes above
+  | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
+                                                       -- CorePrep will eta-expand it
+  | otherwise                                = unfoldingTemplate (idUnfolding id)
+\end{code}
+       
 
 
+\begin{code}
 -- ---------------------------------------------------------------------------
 -- Dealing with bindings
 -- ---------------------------------------------------------------------------
 
 data FloatingBind = FloatLet CoreBind
 -- ---------------------------------------------------------------------------
 -- Dealing with bindings
 -- ---------------------------------------------------------------------------
 
 data FloatingBind = FloatLet CoreBind
-                 | FloatCase Id CoreExpr
+                 | FloatCase Id CoreExpr Bool
+                       -- The bool indicates "ok-for-speculation"
 
 
-type CloneEnv = IdEnv Id       -- Clone local Ids
+data Floats = Floats OkToSpec (OrdList FloatingBind)
 
 
-allLazy :: OrdList FloatingBind -> Bool
-allLazy floats = foldOL check True floats
-              where
-                check (FloatLet _)    y = y
-                check (FloatCase _ _) y = False
+-- 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
 
 
-corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
-corePrepTopBinds env [] = returnUs []
+emptyFloats :: Floats
+emptyFloats = Floats OkToSpec nilOL
 
 
-corePrepTopBinds env (bind : binds)
-  = corePrepBind env bind      `thenUs` \ (env', floats) ->
-    ASSERT( allLazy floats )
-    corePrepTopBinds env' binds        `thenUs` \ binds' ->
-    returnUs (foldOL add binds' floats)
+addFloat :: Floats -> FloatingBind -> Floats
+addFloat (Floats ok_to_spec floats) new_float
+  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
   where
   where
-    add (FloatLet bind) binds = bind : binds
+    check (FloatLet _)               = OkToSpec
+    check (FloatCase _ _ ok_for_spec) 
+       | ok_for_spec  =  IfUnboxedOk
+       | otherwise    =  NotOkToSpec
+       -- The ok-for-speculation flag says that it's safe to
+       -- float this Case out of a let, and thereby do it more eagerly
+       -- We need the top-level flag because it's never ok to float
+       -- an unboxed binding to the top level
+
+unitFloat :: FloatingBind -> Floats
+unitFloat = addFloat emptyFloats
+
+appendFloats :: Floats -> Floats -> Floats
+appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
+  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
+
+concatFloats :: [Floats] -> Floats
+concatFloats = foldr appendFloats emptyFloats
+
+combine NotOkToSpec _ = NotOkToSpec
+combine _ NotOkToSpec = NotOkToSpec
+combine IfUnboxedOk _ = IfUnboxedOk
+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
 
 
+type CloneEnv = IdEnv Id       -- Clone local Ids
+
+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 b           bs = pprPanic "corePrepPgm" (ppr b)
+
+allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool
+allLazy top_lvl is_rec (Floats ok_to_spec _)
+  = case ok_to_spec of
+       OkToSpec -> True
+       NotOkToSpec -> False
+       IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec
 
 -- ---------------------------------------------------------------------------
 --                     Bindings
 -- ---------------------------------------------------------------------------
 
 
 -- ---------------------------------------------------------------------------
 --                     Bindings
 -- ---------------------------------------------------------------------------
 
-corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
--- Used for non-top-level bindings
+corePrepTopBinds :: [CoreBind] -> UniqSM Floats
+corePrepTopBinds binds 
+  = go emptyVarEnv binds
+  where
+    go env []            = returnUs emptyFloats
+    go env (bind : binds) = corePrepTopBind env bind   `thenUs` \ (env', bind') ->
+                           go env' binds               `thenUs` \ binds' ->
+                           returnUs (bind' `appendFloats` binds')
+
+-- NB: we do need to float out of top-level bindings
+-- Consider    x = length [True,False]
+-- We want to get
+--             s1 = False : []
+--             s2 = True  : s1
+--             x  = length s2
+
 -- We return a *list* of bindings, because we may start with
 --     x* = f (g y)
 -- where x is demanded, in which case we want to finish with
 --     a = g y
 --     x* = f a
 -- And then x will actually end up case-bound
 -- We return a *list* of bindings, because we may start with
 --     x* = f (g y)
 -- where x is demanded, in which case we want to finish with
 --     a = g y
 --     x* = f a
 -- And then x will actually end up case-bound
-
+--
+-- 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 eg. s1 & s2
+-- 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.
+
+--------------------------------
+corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats)
+corePrepTopBind env (NonRec bndr rhs) 
+  = cloneBndr env bndr                                 `thenUs` \ (env', bndr') ->
+    corePrepRhs TopLevel NonRecursive env (bndr, rhs)  `thenUs` \ (floats, rhs') -> 
+    returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))
+
+corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
+
+--------------------------------
+corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats)
+       -- This one is used for *local* bindings
 corePrepBind env (NonRec bndr rhs)
 corePrepBind env (NonRec bndr rhs)
-  = corePrepExprFloat env rhs                  `thenUs` \ (floats, rhs') ->
-    cloneBndr env bndr                         `thenUs` \ (env', bndr') ->
-    mkNonRec bndr' (bdrDem bndr') floats rhs'  `thenUs` \ floats' ->
+  = etaExpandRhs bndr rhs                              `thenUs` \ rhs1 ->
+    corePrepExprFloat env rhs1                         `thenUs` \ (floats, rhs2) ->
+    cloneBndr env bndr                                 `thenUs` \ (env', bndr') ->
+    mkLocalNonRec bndr' (bdrDem bndr') floats rhs2     `thenUs` \ floats' ->
     returnUs (env', floats')
 
     returnUs (env', floats')
 
-corePrepBind env (Rec pairs)
-       -- Don't bother to try to float bindings out of RHSs
-       -- (compare mkNonRec, which does try)
-  = cloneBndrs env bndrs                       `thenUs` \ (env', bndrs') ->
-    mapUs (corePrepAnExpr env') rhss           `thenUs` \ rhss' ->
-    returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
+corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
+
+--------------------------------
+corePrepRecPairs :: TopLevelFlag -> CloneEnv
+                -> [(Id,CoreExpr)]     -- Recursive bindings
+                -> UniqSM (CloneEnv, Floats)
+-- Used for all recursive bindings, top level and otherwise
+corePrepRecPairs lvl env pairs
+  = cloneBndrs env (map fst pairs)                             `thenUs` \ (env', bndrs') ->
+    mapAndUnzipUs (corePrepRhs lvl Recursive env') pairs       `thenUs` \ (floats_s, rhss') ->
+    returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))
   where
   where
-    (bndrs, rhss) = unzip pairs
+       -- Flatten all the floats, and the currrent
+       -- group into a single giant Rec
+    flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
+
+    get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
+    get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
+
+--------------------------------
+corePrepRhs :: TopLevelFlag -> RecFlag
+           -> CloneEnv -> (Id, CoreExpr)
+           -> UniqSM (Floats, CoreExpr)
+-- Used for top-level bindings, and local recursive bindings
+corePrepRhs top_lvl is_rec env (bndr, rhs)
+  = etaExpandRhs bndr rhs      `thenUs` \ rhs' ->
+    corePrepExprFloat env rhs' `thenUs` \ floats_w_rhs ->
+    floatRhs top_lvl is_rec bndr floats_w_rhs
 
 
 -- ---------------------------------------------------------------------------
 
 
 -- ---------------------------------------------------------------------------
@@ -161,17 +336,24 @@ corePrepBind env (Rec pairs)
 
 -- This is where we arrange that a non-trivial argument is let-bound
 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
 
 -- This is where we arrange that a non-trivial argument is let-bound
 corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
-          -> UniqSM (OrdList FloatingBind, CoreArg)
+          -> UniqSM (Floats, CoreArg)
 corePrepArg env arg dem
   = corePrepExprFloat env arg          `thenUs` \ (floats, arg') ->
 corePrepArg env arg dem
   = corePrepExprFloat env arg          `thenUs` \ (floats, arg') ->
-    if needs_binding arg'
-       then returnUs (floats, arg')
-       else newVar (exprType arg')     `thenUs` \ v ->
-            mkNonRec v dem floats arg' `thenUs` \ floats' -> 
-            returnUs (floats', Var v)
-
-needs_binding | opt_KeepStgTypes = exprIsAtom
-             | otherwise        = exprIsTrivial
+    if exprIsTrivial arg'
+    then returnUs (floats, arg')
+    else newVar (exprType arg')                        `thenUs` \ v ->
+        mkLocalNonRec v dem floats arg'        `thenUs` \ floats' -> 
+        returnUs (floats', Var v)
+
+-- version that doesn't consider an scc annotation to be trivial.
+exprIsTrivial (Var v)                 = True
+exprIsTrivial (Type _)                = True
+exprIsTrivial (Lit lit)               = True
+exprIsTrivial (App e arg)             = isTypeArg arg && exprIsTrivial e
+exprIsTrivial (Note (SCC _) e)                = False
+exprIsTrivial (Note _ e)              = exprIsTrivial e
+exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
+exprIsTrivial other                   = False
 
 -- ---------------------------------------------------------------------------
 -- Dealing with expressions
 
 -- ---------------------------------------------------------------------------
 -- Dealing with expressions
@@ -183,7 +365,7 @@ corePrepAnExpr env expr
     mkBinds floats expr
 
 
     mkBinds floats expr
 
 
-corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
+corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)
 -- If
 --     e  ===>  (bs, e')
 -- then        
 -- If
 --     e  ===>  (bs, e')
 -- then        
@@ -196,39 +378,43 @@ corePrepExprFloat env (Var v)
   = fiddleCCall v                              `thenUs` \ v1 ->
     let v2 = lookupVarEnv env v1 `orElse` v1 in
     maybeSaturate v2 (Var v2) 0 (idType v2)    `thenUs` \ app ->
   = fiddleCCall v                              `thenUs` \ v1 ->
     let v2 = lookupVarEnv env v1 `orElse` v1 in
     maybeSaturate v2 (Var v2) 0 (idType v2)    `thenUs` \ app ->
-    returnUs (nilOL, app)
+    returnUs (emptyFloats, app)
 
 corePrepExprFloat env expr@(Type _)
 
 corePrepExprFloat env expr@(Type _)
-  = returnUs (nilOL, expr)
+  = returnUs (emptyFloats, expr)
 
 corePrepExprFloat env expr@(Lit lit)
 
 corePrepExprFloat env expr@(Lit lit)
-  = returnUs (nilOL, expr)
+  = returnUs (emptyFloats, expr)
 
 corePrepExprFloat env (Let bind body)
   = corePrepBind env bind              `thenUs` \ (env', new_binds) ->
     corePrepExprFloat env' body                `thenUs` \ (floats, new_body) ->
 
 corePrepExprFloat env (Let bind body)
   = corePrepBind env bind              `thenUs` \ (env', new_binds) ->
     corePrepExprFloat env' body                `thenUs` \ (floats, new_body) ->
-    returnUs (new_binds `appOL` floats, new_body)
+    returnUs (new_binds `appendFloats` floats, new_body)
 
 corePrepExprFloat env (Note n@(SCC _) expr)
   = corePrepAnExpr env expr            `thenUs` \ expr1 ->
 
 corePrepExprFloat env (Note n@(SCC _) expr)
   = corePrepAnExpr env expr            `thenUs` \ expr1 ->
-    deLam expr1                                `thenUs` \ expr2 ->
-    returnUs (nilOL, Note n expr2)
+    deLamFloat expr1                   `thenUs` \ (floats, expr2) ->
+    returnUs (floats, Note n expr2)
 
 corePrepExprFloat env (Note other_note expr)
   = corePrepExprFloat env expr         `thenUs` \ (floats, expr') ->
     returnUs (floats, Note other_note expr')
 
 corePrepExprFloat env expr@(Lam _ _)
 
 corePrepExprFloat env (Note other_note expr)
   = corePrepExprFloat env expr         `thenUs` \ (floats, expr') ->
     returnUs (floats, Note other_note expr')
 
 corePrepExprFloat env expr@(Lam _ _)
-  = corePrepAnExpr env body            `thenUs` \ body' ->
-    returnUs (nilOL, mkLams bndrs body')
+  = cloneBndrs env bndrs               `thenUs` \ (env', bndrs') ->
+    corePrepAnExpr env' body           `thenUs` \ body' ->
+    returnUs (emptyFloats, mkLams bndrs' body')
   where
     (bndrs,body) = collectBinders expr
 
   where
     (bndrs,body) = collectBinders expr
 
-corePrepExprFloat env (Case scrut bndr alts)
-  = corePrepExprFloat env scrut                `thenUs` \ (floats, scrut') ->
+-- gaw 2004
+corePrepExprFloat env (Case scrut bndr ty alts)
+  = corePrepExprFloat env scrut                `thenUs` \ (floats1, scrut1) ->
+    deLamFloat scrut1                  `thenUs` \ (floats2, scrut2) ->
     cloneBndr env bndr                 `thenUs` \ (env', bndr') ->
     mapUs (sat_alt env') alts          `thenUs` \ alts' ->
     cloneBndr env bndr                 `thenUs` \ (env', bndr') ->
     mapUs (sat_alt env') alts          `thenUs` \ alts' ->
-    returnUs (floats, mkCase scrut' bndr' alts')
+-- gaw 2004
+    returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts')
   where
     sat_alt env (con, bs, rhs)
          = cloneBndrs env bs           `thenUs` \ (env', bs') ->
   where
     sat_alt env (con, bs, rhs)
          = cloneBndrs env bs           `thenUs` \ (env', bs') ->
@@ -262,7 +448,7 @@ corePrepExprFloat env expr@(App _ _)
                   (CoreExpr,Int),        -- the head of the application,
                                          -- and no. of args it was applied to
                   Type,                  -- type of the whole expr
                   (CoreExpr,Int),        -- the head of the application,
                                          -- and no. of args it was applied to
                   Type,                  -- type of the whole expr
-                  OrdList FloatingBind,  -- any floats we pulled out
+                  Floats,                -- any floats we pulled out
                   [Demand])              -- remaining argument demands
 
     collect_args (App fun arg@(Type arg_ty)) depth
                   [Demand])              -- remaining argument demands
 
     collect_args (App fun arg@(Type arg_ty)) depth
@@ -273,24 +459,24 @@ corePrepExprFloat env expr@(App _ _)
         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
          let
              (ss1, ss_rest)   = case ss of
         = collect_args fun (depth+1)   `thenUs` \ (fun',hd,fun_ty,floats,ss) ->
          let
              (ss1, ss_rest)   = case ss of
-                                  (ss1:ss_rest) -> (ss1, ss_rest)
-                                  []          -> (wwLazy, [])
+                                  (ss1:ss_rest) -> (ss1,     ss_rest)
+                                  []            -> (lazyDmd, [])
               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
                                  splitFunTy_maybe fun_ty
          in
          corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
               (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
                                  splitFunTy_maybe fun_ty
          in
          corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
-         returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
+         returnUs (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest)
 
     collect_args (Var v) depth
        = fiddleCCall v `thenUs` \ v1 ->
          let v2 = lookupVarEnv env v1 `orElse` v1 in
 
     collect_args (Var v) depth
        = fiddleCCall v `thenUs` \ v1 ->
          let v2 = lookupVarEnv env v1 `orElse` v1 in
-         returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
+         returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)
        where
        where
-         stricts = case idStrictness v of
-                       StrictnessInfo demands _ 
-                           | depth >= length demands -> demands
-                           | otherwise               -> []
-                       other                         -> []
+         stricts = case idNewStrictness v of
+                       StrictSig (DmdType _ demands _)
+                           | listLengthCmp demands depth /= GT -> demands
+                                   -- length demands <= depth
+                           | otherwise                         -> []
                -- If depth < length demands, then we have too few args to 
                -- satisfy strictness  info so we have to  ignore all the 
                -- strictness info, e.g. + (error "urk")
                -- If depth < length demands, then we have too few args to 
                -- satisfy strictness  info so we have to  ignore all the 
                -- strictness info, e.g. + (error "urk")
@@ -308,18 +494,21 @@ corePrepExprFloat env expr@(App _ _)
          returnUs (Note note fun', hd, fun_ty, floats, ss)
 
        -- non-variable fun, better let-bind it
          returnUs (Note note fun', hd, fun_ty, floats, ss)
 
        -- non-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
     collect_args fun depth
-       = corePrepExprFloat env fun             `thenUs` \ (fun_floats, fun) ->
-         newVar ty                             `thenUs` \ fn_id ->
-          mkNonRec fn_id onceDem fun_floats fun        `thenUs` \ floats ->
+       = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
+         newVar ty                                     `thenUs` \ fn_id ->
+          mkLocalNonRec fn_id onceDem fun_floats fun'  `thenUs` \ floats ->
          returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
         where
          ty = exprType fun
 
          returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
         where
          ty = exprType fun
 
-    ignore_note        InlineCall = True
-    ignore_note        InlineMe   = True
-    ignore_note        _other     = False
-       -- we don't ignore SCCs, since they require some code generation
+    ignore_note        (CoreNote _) = True 
+    ignore_note        InlineCall   = True
+    ignore_note        InlineMe     = True
+    ignore_note        _other       = False
+       -- We don't ignore SCCs, since they require some code generation
 
 ------------------------------------------------------------------------------
 -- Building the saturated syntax
 
 ------------------------------------------------------------------------------
 -- Building the saturated syntax
@@ -330,89 +519,145 @@ corePrepExprFloat env expr@(App _ _)
 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 maybeSaturate fn expr n_args ty
   | hasNoBinding fn = saturate_it
 maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
 maybeSaturate fn expr n_args ty
   | hasNoBinding fn = saturate_it
-  | otherwise     = returnUs expr
+  | otherwise       = returnUs expr
   where
     fn_arity    = idArity fn
     excess_arity = fn_arity - n_args
   where
     fn_arity    = idArity fn
     excess_arity = fn_arity - n_args
-    saturate_it  = getUs       `thenUs` \ us ->
+    saturate_it  = getUniquesUs                `thenUs` \ us ->
                   returnUs (etaExpand excess_arity us expr ty)
 
 -- ---------------------------------------------------------------------------
 -- Precipitating the floating bindings
 -- ---------------------------------------------------------------------------
 
                   returnUs (etaExpand excess_arity us expr ty)
 
 -- ---------------------------------------------------------------------------
 -- Precipitating the floating bindings
 -- ---------------------------------------------------------------------------
 
--- mkNonRec is used for both top level and local bindings
-mkNonRec :: Id  -> RhsDemand                   -- Lhs: id with demand
-        -> OrdList FloatingBind -> CoreExpr    -- Rhs: let binds in body
-        -> UniqSM (OrdList FloatingBind)
-mkNonRec bndr dem floats rhs
-  | exprIsValue rhs && allLazy floats          -- Notably constructor applications
-  =    -- Why the test for allLazy? You might think that the only 
-       -- floats we can get out of a value are eta expansions 
-       -- e.g.  C $wJust ==> let s = \x -> $wJust x in C s
-       -- Here we want to float the s binding.
-       --
-       -- But if the programmer writes this:
-       --      f x = case x of { (a,b) -> \y -> a }
-       -- then the strictness analyser may say that f has strictness "S"
-       -- Later the eta expander will transform to
-       --      f x y = case x of { (a,b) -> a }
-       -- So now f has arity 2.  Now CorePrep may see
-       --      v = f E
-       -- so the E argument will turn into a FloatCase.  
-       -- Indeed we should end up with
-       --      v = case E of { r -> f r }
-       -- That is, we should not float, even though (f r) is a value
-       --
-       -- Similarly, given 
+floatRhs :: TopLevelFlag -> RecFlag
+        -> Id
+        -> (Floats, CoreExpr)  -- Rhs: let binds in body
+        -> UniqSM (Floats,     -- Floats out of this bind
+                   CoreExpr)   -- Final Rhs
+
+floatRhs top_lvl is_rec bndr (floats, rhs)
+  | isTopLevel top_lvl || exprIsValue rhs,     -- Float to expose value or 
+    allLazy top_lvl is_rec floats              -- at top level
+  =    -- Why the test for allLazy? 
        --      v = f (x `divInt#` y)
        -- we don't want to float the case, even if f has arity 2,
        -- because floating the case would make it evaluated too early
        --      v = f (x `divInt#` y)
        -- we don't want to float the case, even if f has arity 2,
        -- because floating the case would make it evaluated too early
-    returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
+       --
+       -- Finally, eta-expand the RHS, for the benefit of the code gen
+    returnUs (floats, rhs)
     
     
-  |  isUnLiftedType bndr_rep_ty        || isStrictDem dem 
-       -- It's a strict let, or the binder is unlifted,
-       -- so we definitely float all the bindings
-  = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
-    returnUs (floats `snocOL` FloatCase bndr rhs)
+  | otherwise
+       -- Don't float; the RHS isn't a value
+  = mkBinds floats rhs         `thenUs` \ rhs' ->
+    returnUs (emptyFloats, rhs')
+
+-- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
+mkLocalNonRec :: Id  -> RhsDemand      -- Lhs: id with demand
+             -> Floats -> CoreExpr     -- Rhs: let binds in body
+             -> UniqSM Floats
+
+mkLocalNonRec bndr dem floats rhs
+  | isUnLiftedType (idType bndr)
+       -- If this is an unlifted binding, we always make a case for it.
+  = ASSERT( not (isUnboxedTupleType (idType bndr)) )
+    let
+       float = FloatCase bndr rhs (exprOkForSpeculation rhs)
+    in
+    returnUs (addFloat floats float)
+
+  | isStrict dem 
+       -- It's a strict let so we definitely float all the bindings
+ = let         -- Don't make a case for a value binding,
+               -- even if it's strict.  Otherwise we get
+               --      case (\x -> e) of ...!
+       float | exprIsValue rhs = FloatLet (NonRec bndr rhs)
+             | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
+    in
+    returnUs (addFloat floats float)
 
   | otherwise
 
   | otherwise
-       -- Don't float
-  = mkBinds floats rhs `thenUs` \ rhs' ->
-    returnUs (unitOL (FloatLet (NonRec bndr rhs')))
+  = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)       `thenUs` \ (floats', rhs') ->
+    returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')))
 
 
-  where
-    bndr_rep_ty  = repType (idType bndr)
 
 
-mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr
-mkBinds binds body 
+mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr
+mkBinds (Floats _ binds) body 
   | isNilOL binds = returnUs body
   | otherwise    = deLam body          `thenUs` \ body' ->
   | isNilOL binds = returnUs body
   | otherwise    = deLam body          `thenUs` \ body' ->
-                   returnUs (foldOL mk_bind body' binds)
+                   returnUs (foldrOL mk_bind body' binds)
+  where
+-- gaw 2004
+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
+    mk_bind (FloatLet bind)        body = Let bind body
+
+etaExpandRhs bndr rhs
+  =    -- Eta expand to match the arity claimed by the binder
+       -- Remember, after CorePrep we must not change arity
+       --
+       -- Eta expansion might not have happened already, 
+       -- because it is done by the simplifier only when 
+       -- there at least one lambda already.
+       -- 
+       -- NB1:we could refrain when the RHS is trivial (which can happen
+       --     for exported things).  This would reduce the amount of code
+       --     generated (a little) and make things a little words for
+       --     code compiled without -O.  The case in point is data constructor
+       --     wrappers.
+       --
+       -- NB2: we have to be careful that the result of etaExpand doesn't
+       --    invalidate any of the assumptions that CorePrep is attempting
+       --    to establish.  One possible cause is eta expanding inside of
+       --    an SCC note - we're now careful in etaExpand to make sure the
+       --    SCC is pushed inside any new lambdas that are generated.
+       --
+       -- NB3: It's important to do eta expansion, and *then* ANF-ising
+       --              f = /\a -> g (h 3)      -- h has arity 2
+       -- If we ANF first we get
+       --              f = /\a -> let s = h 3 in g s
+       -- and now eta expansion gives
+       --              f = /\a -> \ y -> (let s = h 3 in g s) y
+       -- which is horrible.
+       -- Eta expanding first gives
+       --              f = /\a -> \y -> let s = h 3 in g s y
+       --
+    getUniquesUs               `thenUs` \ us ->
+    returnUs (etaExpand arity us rhs (idType bndr))
   where
   where
-    mk_bind (FloatCase bndr rhs) body = mkCase rhs bndr [(DEFAULT, [], body)]
-    mk_bind (FloatLet bind)      body = Let bind body
+       -- For a GlobalId, take the Arity from the Id.
+       -- It was set in CoreTidy and must not change
+       -- For all others, just expand at will
+    arity | isGlobalId bndr = idArity bndr
+         | otherwise       = exprArity rhs
 
 -- ---------------------------------------------------------------------------
 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 -- We arrange that they only show up as the RHS of a let(rec)
 -- ---------------------------------------------------------------------------
 
 
 -- ---------------------------------------------------------------------------
 -- Eliminate Lam as a non-rhs (STG doesn't have such a thing)
 -- We arrange that they only show up as the RHS of a let(rec)
 -- ---------------------------------------------------------------------------
 
-deLam :: CoreExpr -> UniqSM CoreExpr   
+deLam :: CoreExpr -> UniqSM CoreExpr
+deLam expr = 
+  deLamFloat expr   `thenUs` \ (floats, expr) ->
+  mkBinds floats expr
+
+
+deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr)
 -- Remove top level lambdas by let-bindinig
 
 -- Remove top level lambdas by let-bindinig
 
-deLam (Note n expr)
+deLamFloat (Note n expr)
   =    -- You can get things like
        --      case e of { p -> coerce t (\s -> ...) }
   =    -- You can get things like
        --      case e of { p -> coerce t (\s -> ...) }
-    deLam expr `thenUs` \ expr' ->
-    returnUs (Note n expr')
-
-deLam expr 
-  | null bndrs = returnUs expr
-  | otherwise  = case tryEta bndrs body of
-                  Just no_lam_result -> returnUs no_lam_result
-                  Nothing            -> newVar (exprType expr) `thenUs` \ fn ->
-                                        returnUs (Let (NonRec fn expr) (Var fn))
+    deLamFloat expr    `thenUs` \ (floats, expr') ->
+    returnUs (floats, Note n expr')
+
+deLamFloat expr 
+  | null bndrs = returnUs (emptyFloats, expr)
+  | otherwise 
+  = case tryEta bndrs body of
+      Just no_lam_result -> returnUs (emptyFloats, no_lam_result)
+      Nothing           -> newVar (exprType expr)      `thenUs` \ fn ->
+                           returnUs (unitFloat (FloatLet (NonRec fn expr)), 
+                                     Var fn)
   where
     (bndrs,body) = collectBinders expr
 
   where
     (bndrs,body) = collectBinders expr
 
@@ -435,7 +680,7 @@ tryEta bndrs expr@(App _ _)
     n_remaining = length args - length bndrs
 
     ok bndr (Var arg) = bndr == arg
     n_remaining = length args - length bndrs
 
     ok bndr (Var arg) = bndr == arg
-    ok bndr other          = False
+    ok bndr other     = False
 
          -- we can't eta reduce something which must be saturated.
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
 
          -- we can't eta reduce something which must be saturated.
     ok_to_eta_reduce (Var f) = not (hasNoBinding f)
@@ -454,89 +699,30 @@ tryEta bndrs _ = Nothing
 
 
 -- -----------------------------------------------------------------------------
 
 
 -- -----------------------------------------------------------------------------
---     Do the seq and par transformation
--- -----------------------------------------------------------------------------
-
-Here we do two pre-codegen transformations:
-
-1.     case seq# a of {
-         0       -> seqError ...
-         DEFAULT -> rhs }
-  ==>
-       case a of { DEFAULT -> rhs }
-
-
-2.     case par# a of {
-         0       -> parError ...
-         DEFAULT -> rhs }
-  ==>
-       case par# a of {
-         DEFAULT -> rhs }
-
-NB:    seq# :: a -> Int#       -- Evaluate value and return anything
-       par# :: a -> Int#       -- Spark value and return anything
-
-These transformations can't be done earlier, or else we might
-think that the expression was strict in the variables in which 
-rhs is strict --- but that would defeat the purpose of seq and par.
-
-
-\begin{code}
-mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
-  = case isPrimOpId_maybe fn of
-       Just ParOp -> Case scrut bndr     [deflt_alt]
-       Just SeqOp -> Case arg   new_bndr [deflt_alt]
-       other      -> Case scrut bndr alts
-  where
-    (deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts]
-
-       -- The binder shouldn't be used in the expression!
-    new_bndr = ASSERT2( not (bndr `elemVarSet` exprFreeVars rhs), ppr bndr )
-              setIdType bndr (exprType arg)
-       -- NB:  SeqOp :: forall a. a -> Int#
-       -- So bndr has type Int# 
-       -- But now we are going to scrutinise the SeqOp's argument directly,
-       -- so we must change the type of the case binder to match that
-       -- of the argument expression e.
-
-mkCase scrut bndr alts = Case scrut bndr alts
-\end{code}
-
-
--- -----------------------------------------------------------------------------
 -- Demands
 -- -----------------------------------------------------------------------------
 
 \begin{code}
 data RhsDemand
 -- Demands
 -- -----------------------------------------------------------------------------
 
 \begin{code}
 data RhsDemand
-     = RhsDemand { isStrictDem :: Bool,  -- True => used at least once
+     = RhsDemand { isStrict :: Bool,  -- True => used at least once
                    isOnceDem   :: Bool   -- True => used at most once
                  }
 
 mkDem :: Demand -> Bool -> RhsDemand
                    isOnceDem   :: Bool   -- True => used at most once
                  }
 
 mkDem :: Demand -> Bool -> RhsDemand
-mkDem strict once = RhsDemand (isStrict strict) once
+mkDem strict once = RhsDemand (isStrictDmd strict) once
 
 mkDemTy :: Demand -> Type -> RhsDemand
 
 mkDemTy :: Demand -> Type -> RhsDemand
-mkDemTy strict ty = RhsDemand (isStrict strict) (isOnceTy ty)
-
-isOnceTy :: Type -> Bool
-isOnceTy ty
-  =
-#ifdef USMANY
-    opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
-#endif
-    once
-  where
-    u = uaUTy ty
-    once | u == usOnce  = True
-         | u == usMany  = False
-         | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany
+mkDemTy strict ty = RhsDemand (isStrictDmd strict) 
+                             False {- For now -}
 
 bdrDem :: Id -> RhsDemand
 
 bdrDem :: Id -> RhsDemand
-bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))
+bdrDem id = mkDem (idNewDemandInfo id)
+                 False {- For now -}
 
 
-safeDem, onceDem :: RhsDemand
-safeDem = RhsDemand False False  -- always safe to use this
+-- safeDem :: RhsDemand
+-- safeDem = RhsDemand False False  -- always safe to use this
+
+onceDem :: RhsDemand
 onceDem = RhsDemand False True   -- used at most once
 \end{code}
 
 onceDem = RhsDemand False True   -- used at most once
 \end{code}
 
@@ -559,15 +745,18 @@ cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 
 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 cloneBndr env bndr
 
 cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
 cloneBndr env bndr
-  | isId bndr && isLocalId bndr                -- Top level things, which we don't want
-                                       -- to clone, have become ConstantIds by now
+  | isLocalId bndr
   = getUniqueUs   `thenUs` \ uniq ->
     let
        bndr' = setVarUnique bndr uniq
     in
     returnUs (extendVarEnv env bndr bndr', bndr')
 
   = getUniqueUs   `thenUs` \ uniq ->
     let
        bndr' = setVarUnique bndr uniq
     in
     returnUs (extendVarEnv env bndr bndr', bndr')
 
-  | otherwise = returnUs (env, bndr)
+  | otherwise  -- Top level things, which we don't want
+               -- to clone, have become GlobalIds by now
+               -- And we don't clone tyvars
+  = returnUs (env, bndr)
+  
 
 ------------------------------------------------------------------------------
 -- Cloning ccall Ids; each must have a unique name,
 
 ------------------------------------------------------------------------------
 -- Cloning ccall Ids; each must have a unique name,
@@ -576,13 +765,9 @@ cloneBndr env bndr
 
 fiddleCCall :: Id -> UniqSM Id
 fiddleCCall id 
 
 fiddleCCall :: Id -> UniqSM Id
 fiddleCCall id 
-  = case globalIdDetails id of
-         PrimOpId (CCallOp ccall) ->
-           -- Make a guaranteed unique name for a dynamic ccall.
-           getUniqueUs         `thenUs` \ uniq ->
-           returnUs (setGlobalIdDetails id 
-                           (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
-        other -> returnUs id
+  | isFCallId id = getUniqueUs         `thenUs` \ uniq ->
+                  returnUs (id `setVarUnique` uniq)
+  | otherwise    = returnUs id
 
 ------------------------------------------------------------------------------
 -- Generating new binders
 
 ------------------------------------------------------------------------------
 -- Generating new binders
@@ -590,7 +775,7 @@ fiddleCCall id
 
 newVar :: Type -> UniqSM Id
 newVar ty
 
 newVar :: Type -> UniqSM Id
 newVar ty
- = getUniqueUs                 `thenUs` \ uniq ->
-   seqType ty                  `seq`
-   returnUs (mkSysLocal SLIT("sat") uniq ty)
+ = seqType ty                  `seq`
+   getUniqueUs                 `thenUs` \ uniq ->
+   returnUs (mkSysLocal FSLIT("sat") uniq ty)
 \end{code}
 \end{code}