remove empty dir

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

diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs
index 63c1d95..e5165f0 100644 (file)
--- a/ghc/compiler/coreSyn/CorePrep.lhs
+++ b/ghc/compiler/coreSyn/CorePrep.lhs
@@ -10,24 +10,24 @@ module CorePrep (
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

-import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation )
+import CoreUtils( exprType, exprIsHNF, 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, seqType )
+import Type    ( Type, applyTy, splitFunTy_maybe, 
+                 isUnLiftedType, isUnboxedTupleType, seqType )
+import TyCon   ( TyCon, tyConDataCons )

 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
 import NewDemand  ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )

-import PrimOp  ( PrimOp(..) )

 import Var     ( Var, Id, setVarUnique )
 import VarSet
 import VarEnv
 import Var     ( Var, Id, setVarUnique )
 import VarSet
 import VarEnv

-import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity,
-                 setIdType, isPrimOpId_maybe, isFCallId, isGlobalId, 
+import Id      ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType,
+                 isFCallId, isGlobalId, 

                  isLocalId, hasNoBinding, idNewStrictness, 
                  isLocalId, hasNoBinding, idNewStrictness, 

-                 isDataConId_maybe, idUnfolding
+                 isPrimOpId_maybe

                )
                )

-import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
-import Unique  ( mkBuiltinUnique )
+import DataCon   ( isVanillaDataCon, dataConWorkId )
+import PrimOp    ( PrimOp( DataToTagOp ) )

 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )
 import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
                    RecFlag(..), isNonRec
                  )

@@ -35,7 +35,7 @@ import UniqSupply
 import Maybes
 import OrdList
 import ErrUtils
 import Maybes
 import OrdList
 import ErrUtils

-import CmdLineOpts
+import DynFlags

 import Util       ( listLengthCmp )
 import Outputable
 \end{code}
 import Util       ( listLengthCmp )
 import Outputable
 \end{code}

@@ -65,7 +65,7 @@ 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 
 
 6.  Clone all local Ids.
     This means that all such Ids are unique, rather than the 

@@ -98,29 +98,29 @@ any trivial or useless bindings.
 -- -----------------------------------------------------------------------------
 
 \begin{code}
 -- -----------------------------------------------------------------------------
 
 \begin{code}

-corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
-corePrepPgm dflags mod_details
+corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind]
+corePrepPgm dflags binds data_tycons

   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 

-       let implicit_binds = mkImplicitBinds (md_types mod_details)
+       let implicit_binds = mkDataConWorkers data_tycons

                -- NB: we must feed mkImplicitBinds through corePrep too
                -- so that they are suitably cloned and eta-expanded
 
            binds_out = initUs_ us (
                -- NB: we must feed mkImplicitBinds through corePrep too
                -- so that they are suitably cloned and eta-expanded
 
            binds_out = initUs_ us (

-                         corePrepTopBinds (md_binds mod_details)       `thenUs` \ floats1 ->
-                         corePrepTopBinds implicit_binds               `thenUs` \ floats2 ->
-                         returnUs (deFloatTop (floats1 `appOL` floats2))
+                         corePrepTopBinds binds        `thenUs` \ floats1 ->
+                         corePrepTopBinds implicit_binds       `thenUs` \ floats2 ->
+                         returnUs (deFloatTop (floats1 `appendFloats` floats2))

                        )
            
         endPass dflags "CorePrep" Opt_D_dump_prep binds_out
                        )
            
         endPass dflags "CorePrep" Opt_D_dump_prep binds_out

-       return (mod_details { md_binds = binds_out })
+       return binds_out

 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'
 
 corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
 corePrepExpr dflags expr
   = do showPass dflags "CorePrep"
        us <- mkSplitUniqSupply 's'

-       let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
+       let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr)

        dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" 
                     (ppr new_expr)
        return new_expr
        dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" 
                     (ppr new_expr)
        return new_expr

@@ -130,16 +130,8 @@ corePrepExpr dflags expr
 -- Implicit bindings
 -- -----------------------------------------------------------------------------
 
 -- 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
+Create any necessary "implicit" bindings for data con workers.  We
+create the rather strange (non-recursive!) binding

 
        $wC = \x y -> $wC x y
 
 
        $wC = \x y -> $wC x y
 

@@ -154,18 +146,11 @@ always fully applied, and the bindings are just there to support
 partial applications. But it's easier to let them through.
 
 \begin{code}
 partial applications. But it's easier to let them through.
 
 \begin{code}

-mkImplicitBinds type_env
-  = [ NonRec id (get_unfolding id)
-    | id <- implicitTyThingIds (typeEnvElts type_env) ]
-       -- 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
-  where
-    tmpl_uniqs = map mkBuiltinUnique [1..]
-
-get_unfolding id       -- See notes above
-  | Just data_con <- isDataConId_maybe id = Var id     -- The ice is thin here, but it works
-  | otherwise                            = unfoldingTemplate (idUnfolding id)
+mkDataConWorkers data_tycons
+  = [ NonRec id (Var id)       -- The ice is thin here, but it works
+    | tycon <- data_tycons,    -- CorePrep will eta-expand it
+      data_con <- tyConDataCons tycon,
+      let id = dataConWorkId data_con ]

 \end{code}
        
 
 \end{code}
        
 

@@ -178,45 +163,79 @@ data FloatingBind = FloatLet CoreBind
                  | FloatCase Id CoreExpr Bool
                        -- The bool indicates "ok-for-speculation"
 
                  | FloatCase Id CoreExpr Bool
                        -- The bool indicates "ok-for-speculation"
 

+data Floats = Floats OkToSpec (OrdList FloatingBind)
+
+-- 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
+
+emptyFloats :: Floats
+emptyFloats = Floats OkToSpec nilOL
+
+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
+    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
 
 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 :: OrdList FloatingBind -> [CoreBind]
+deFloatTop :: Floats -> [CoreBind]

 -- For top level only; we don't expect any FloatCases
 -- For top level only; we don't expect any FloatCases

-deFloatTop floats
+deFloatTop (Floats _ floats)

   = foldrOL get [] floats
   where
     get (FloatLet b) bs = b:bs
     get b           bs = pprPanic "corePrepPgm" (ppr b)
 
   = foldrOL get [] floats
   where
     get (FloatLet b) bs = b:bs
     get b           bs = pprPanic "corePrepPgm" (ppr b)
 

-allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool
-allLazy top_lvl is_rec floats 
-  = foldrOL check True floats
-  where
-    unboxed_ok = isNotTopLevel top_lvl && isNonRec is_rec
-
-    check (FloatLet _)               y = y
-    check (FloatCase _ _ ok_for_spec) y = unboxed_ok && ok_for_spec && y
-       -- 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
+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
 -- ---------------------------------------------------------------------------
 

-corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind)
+corePrepTopBinds :: [CoreBind] -> UniqSM Floats

 corePrepTopBinds binds 
 corePrepTopBinds binds 

-  = go emptyVarEnv binds
+  = go emptyCorePrepEnv binds

   where
   where

-    go env []            = returnUs nilOL
+    go env []            = returnUs emptyFloats

     go env (bind : binds) = corePrepTopBind env bind   `thenUs` \ (env', bind') ->
                            go env' binds               `thenUs` \ binds' ->
     go env (bind : binds) = corePrepTopBind env bind   `thenUs` \ (env', bind') ->
                            go env' binds               `thenUs` \ binds' ->

-                           returnUs (bind' `appOL` binds')
+                           returnUs (bind' `appendFloats` binds')

 
 -- NB: we do need to float out of top-level bindings
 -- Consider    x = length [True,False]
 
 -- NB: we do need to float out of top-level bindings
 -- Consider    x = length [True,False]

@@ -231,49 +250,65 @@ corePrepTopBinds binds
 --     a = g y
 --     x* = f a
 -- And then x will actually end up case-bound
 --     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, OrdList FloatingBind)
+corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)

 corePrepTopBind env (NonRec bndr rhs) 
   = cloneBndr env bndr                                 `thenUs` \ (env', bndr') ->
     corePrepRhs TopLevel NonRecursive env (bndr, rhs)  `thenUs` \ (floats, rhs') -> 
 corePrepTopBind env (NonRec bndr rhs) 
   = cloneBndr env bndr                                 `thenUs` \ (env', bndr') ->
     corePrepRhs TopLevel NonRecursive env (bndr, rhs)  `thenUs` \ (floats, rhs') -> 

-    returnUs (env', floats `snocOL` FloatLet (NonRec bndr' rhs'))
+    returnUs (env', addFloat floats (FloatLet (NonRec bndr' rhs')))

 
 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 
 --------------------------------
 
 corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs
 
 --------------------------------

-corePrepBind ::  CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
+corePrepBind ::  CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats)

        -- This one is used for *local* bindings
 corePrepBind env (NonRec bndr rhs)
   = etaExpandRhs bndr rhs                              `thenUs` \ rhs1 ->
     corePrepExprFloat env rhs1                         `thenUs` \ (floats, rhs2) ->
        -- This one is used for *local* bindings
 corePrepBind env (NonRec bndr rhs)
   = 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')
+    cloneBndr env bndr                                 `thenUs` \ (_, bndr') ->
+    mkLocalNonRec bndr' (bdrDem bndr) floats rhs2      `thenUs` \ (floats', bndr'') ->
+       -- We want bndr'' in the envt, because it records
+       -- the evaluated-ness of the binder
+    returnUs (extendCorePrepEnv env bndr bndr'', floats')

 
 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 
 --------------------------------
 
 corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs
 
 --------------------------------

-corePrepRecPairs :: TopLevelFlag -> CloneEnv
+corePrepRecPairs :: TopLevelFlag -> CorePrepEnv

                 -> [(Id,CoreExpr)]     -- Recursive bindings
                 -> [(Id,CoreExpr)]     -- Recursive bindings

-                -> UniqSM (CloneEnv, OrdList FloatingBind)
+                -> UniqSM (CorePrepEnv, 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') ->
 -- 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', unitOL (FloatLet (Rec (flatten (concatOL floats_s) bndrs' rhss'))))
+    returnUs (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss'))))

   where
        -- Flatten all the floats, and the currrent
        -- group into a single giant Rec
   where
        -- Flatten all the floats, and the currrent
        -- group into a single giant Rec

-    flatten floats bndrs rhss = foldrOL get (bndrs `zip` rhss) floats
+    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
 
     get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
     get (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2

+    get b                      prs2 = pprPanic "corePrepRecPairs" (ppr b)

 
 --------------------------------
 corePrepRhs :: TopLevelFlag -> RecFlag
 
 --------------------------------
 corePrepRhs :: TopLevelFlag -> RecFlag

-           -> CloneEnv -> (Id, CoreExpr)
-           -> UniqSM (OrdList FloatingBind, CoreExpr)
+           -> CorePrepEnv -> (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' ->
 -- Used for top-level bindings, and local recursive bindings
 corePrepRhs top_lvl is_rec env (bndr, rhs)
   = etaExpandRhs bndr rhs      `thenUs` \ rhs' ->

@@ -286,15 +321,15 @@ corePrepRhs top_lvl is_rec env (bndr, rhs)
 -- ---------------------------------------------------------------------------
 
 -- This is where we arrange that a non-trivial argument is let-bound
 -- ---------------------------------------------------------------------------
 
 -- This is where we arrange that a non-trivial argument is let-bound

-corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
-          -> UniqSM (OrdList FloatingBind, CoreArg)
+corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand
+          -> UniqSM (Floats, CoreArg)

 corePrepArg env arg dem
   = corePrepExprFloat env arg          `thenUs` \ (floats, arg') ->
     if exprIsTrivial arg'
     then returnUs (floats, arg')
     else newVar (exprType arg')                        `thenUs` \ v ->
 corePrepArg env arg dem
   = corePrepExprFloat env arg          `thenUs` \ (floats, arg') ->
     if exprIsTrivial arg'
     then returnUs (floats, arg')
     else newVar (exprType arg')                        `thenUs` \ v ->

-        mkLocalNonRec v dem floats arg'        `thenUs` \ floats' -> 
-        returnUs (floats', Var v)
+        mkLocalNonRec v dem floats arg'        `thenUs` \ (floats', v') -> 
+        returnUs (floats', Var v')

 
 -- version that doesn't consider an scc annotation to be trivial.
 exprIsTrivial (Var v)                 = True
 
 -- version that doesn't consider an scc annotation to be trivial.
 exprIsTrivial (Var v)                 = True

@@ -310,13 +345,13 @@ exprIsTrivial other                      = False
 -- Dealing with expressions
 -- ---------------------------------------------------------------------------
 
 -- Dealing with expressions
 -- ---------------------------------------------------------------------------
 

-corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
+corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr

 corePrepAnExpr env expr
   = corePrepExprFloat env expr         `thenUs` \ (floats, expr) ->
     mkBinds floats expr
 
 
 corePrepAnExpr env expr
   = corePrepExprFloat env expr         `thenUs` \ (floats, expr) ->
     mkBinds floats expr
 
 

-corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
+corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr)

 -- If
 --     e  ===>  (bs, e')
 -- then        
 -- If
 --     e  ===>  (bs, e')
 -- then        

@@ -327,25 +362,26 @@ corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreE
 
 corePrepExprFloat env (Var v)
   = fiddleCCall v                              `thenUs` \ v1 ->
 
 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 ->
-    returnUs (nilOL, app)
+    let 
+       v2 = lookupCorePrepEnv env v1
+    in
+    maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2)

 
 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') ->
 
 corePrepExprFloat env (Note other_note expr)
   = corePrepExprFloat env expr         `thenUs` \ (floats, expr') ->

@@ -354,19 +390,27 @@ corePrepExprFloat env (Note other_note expr)
 corePrepExprFloat env expr@(Lam _ _)
   = cloneBndrs env bndrs               `thenUs` \ (env', bndrs') ->
     corePrepAnExpr env' body           `thenUs` \ body' ->
 corePrepExprFloat env expr@(Lam _ _)
   = cloneBndrs env bndrs               `thenUs` \ (env', bndrs') ->
     corePrepAnExpr env' body           `thenUs` \ body' ->

-    returnUs (nilOL, mkLams bndrs' 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') ->
-    cloneBndr env bndr                 `thenUs` \ (env', bndr') ->
+corePrepExprFloat env (Case scrut bndr ty alts)
+  = corePrepExprFloat env scrut                `thenUs` \ (floats1, scrut1) ->
+    deLamFloat scrut1                  `thenUs` \ (floats2, scrut2) ->
+    let
+       bndr1 = bndr `setIdUnfolding` evaldUnfolding
+       -- Record that the case binder is evaluated in the alternatives
+    in
+    cloneBndr env bndr1                        `thenUs` \ (env', bndr2) ->

     mapUs (sat_alt env') alts          `thenUs` \ alts' ->
     mapUs (sat_alt env') alts          `thenUs` \ alts' ->

-    returnUs (floats, mkCase scrut' bndr' alts')
+    returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts')

   where
     sat_alt env (con, bs, rhs)
   where
     sat_alt env (con, bs, rhs)

-         = cloneBndrs env bs           `thenUs` \ (env', bs') ->
-           corePrepAnExpr env' rhs     `thenUs` \ rhs1 ->
+         = let 
+               env1 = setGadt env con
+           in
+           cloneBndrs env1 bs          `thenUs` \ (env2, bs') ->
+           corePrepAnExpr env2 rhs     `thenUs` \ rhs1 ->

            deLam rhs1                  `thenUs` \ rhs2 ->
            returnUs (con, bs', rhs2)
 
            deLam rhs1                  `thenUs` \ rhs2 ->
            returnUs (con, bs', rhs2)
 

@@ -376,9 +420,7 @@ corePrepExprFloat env expr@(App _ _)
 
        -- Now deal with the function
     case head of
 
        -- Now deal with the function
     case head of

-      Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' -> 
-                  returnUs (floats, app')
-
+      Var fn_id -> maybeSaturate fn_id app depth floats ty

       _other    -> returnUs (floats, app)
 
   where
       _other    -> returnUs (floats, app)
 
   where

@@ -396,7 +438,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

@@ -413,12 +455,14 @@ corePrepExprFloat env expr@(App _ _)
                                  splitFunTy_maybe fun_ty
          in
          corePrepArg env arg (mkDemTy ss1 arg_ty)      `thenUs` \ (fs, arg') ->
                                  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 ->
 
     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)
+         let 
+               v2 = lookupCorePrepEnv env v1
+         in
+         returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts)

        where
          stricts = case idNewStrictness v of
                        StrictSig (DmdType _ demands _)
        where
          stricts = case idNewStrictness v of
                        StrictSig (DmdType _ demands _)

@@ -437,23 +481,27 @@ corePrepExprFloat env expr@(App _ _)
          returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 
     collect_args (Note note fun) depth
          returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss)
 
     collect_args (Note note fun) depth

-       | ignore_note note 
+       | ignore_note note      -- Drop these notes altogether
+                               -- They aren't used by the code generator

         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
         = collect_args fun depth   `thenUs` \ (fun', hd, fun_ty, floats, ss) ->

-         returnUs (Note note fun', hd, fun_ty, floats, ss)
+         returnUs (fun', hd, fun_ty, floats, ss)

 
 

-       -- non-variable fun, better let-bind it
+       -- 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
        = corePrepExprFloat env fun                     `thenUs` \ (fun_floats, fun') ->
          newVar ty                                     `thenUs` \ fn_id ->
     collect_args fun depth
        = 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, [])
+          mkLocalNonRec fn_id onceDem fun_floats fun'  `thenUs` \ (floats, fn_id') ->
+         returnUs (Var fn_id', (Var fn_id', depth), ty, floats, [])

         where
          ty = exprType fun
 
         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

@@ -461,15 +509,58 @@ corePrepExprFloat env expr@(App _ _)
 
 -- maybeSaturate deals with saturating primops and constructors
 -- The type is the type of the entire application
 
 -- maybeSaturate deals with saturating primops and constructors
 -- The type is the type of the entire application

-maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
-maybeSaturate fn expr n_args ty
-  | hasNoBinding fn = saturate_it
-  | otherwise       = returnUs expr
+maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr)
+maybeSaturate fn expr n_args floats ty
+  | Just DataToTagOp <- isPrimOpId_maybe fn    -- DataToTag must have an evaluated arg
+                                               -- A gruesome special case
+  = saturate_it                `thenUs` \ sat_expr ->
+
+       -- OK, now ensure that the arg is evaluated.
+       -- But (sigh) take into account the lambdas we've now introduced
+    let 
+       (eta_bndrs, eta_body) = collectBinders sat_expr
+    in
+    eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') -> 
+    if null eta_bndrs then
+       returnUs (floats `appendFloats` eta_floats, eta_body')
+    else
+       mkBinds eta_floats eta_body'            `thenUs` \ eta_body'' ->
+       returnUs (floats, mkLams eta_bndrs eta_body'')
+
+  | hasNoBinding fn = saturate_it      `thenUs` \ sat_expr ->
+                     returnUs (floats, sat_expr)
+
+  | otherwise       = returnUs (floats, 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  = getUniquesUs                `thenUs` \ us ->
-                  returnUs (etaExpand excess_arity us expr ty)
+
+    saturate_it :: UniqSM CoreExpr
+    saturate_it | excess_arity == 0 = returnUs expr
+               | otherwise         = getUniquesUs              `thenUs` \ us ->
+                                     returnUs (etaExpand excess_arity us expr ty)
+
+       -- Ensure that the argument of DataToTagOp is evaluated
+    eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr)
+    eval_data2tag_arg app@(fun `App` arg)
+       | exprIsHNF arg         -- Includes nullary constructors
+       = returnUs (emptyFloats, app)   -- The arg is evaluated
+       | otherwise                     -- Arg not evaluated, so evaluate it
+       = newVar (exprType arg)         `thenUs` \ arg_id ->
+         let 
+            arg_id1 = setIdUnfolding arg_id evaldUnfolding
+         in
+         returnUs (unitFloat (FloatCase arg_id1 arg False ),
+                   fun `App` Var arg_id1)
+
+    eval_data2tag_arg (Note note app)  -- Scc notes can appear
+       = eval_data2tag_arg app         `thenUs` \ (floats, app') ->
+         returnUs (floats, Note note app')
+
+    eval_data2tag_arg other    -- Should not happen
+       = pprPanic "eval_data2tag" (ppr other)
+

 
 -- ---------------------------------------------------------------------------
 -- Precipitating the floating bindings
 
 -- ---------------------------------------------------------------------------
 -- Precipitating the floating bindings

@@ -477,30 +568,29 @@ maybeSaturate fn expr n_args ty
 
 floatRhs :: TopLevelFlag -> RecFlag
         -> Id
 
 floatRhs :: TopLevelFlag -> RecFlag
         -> Id

-        -> (OrdList FloatingBind, CoreExpr)    -- Rhs: let binds in body
-        -> UniqSM (OrdList FloatingBind,       -- Floats out of this bind
-                   CoreExpr)                   -- Final Rhs
+        -> (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)
 
 floatRhs top_lvl is_rec bndr (floats, rhs)

-  | isTopLevel top_lvl || exprIsValue rhs,     -- Float to expose value or 
+  | isTopLevel top_lvl || exprIsHNF 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
     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

-       --
-       -- Finally, eta-expand the RHS, for the benefit of the code gen

     returnUs (floats, rhs)
     
   | otherwise
        -- Don't float; the RHS isn't a value
   = mkBinds floats rhs         `thenUs` \ rhs' ->
     returnUs (floats, rhs)
     
   | otherwise
        -- Don't float; the RHS isn't a value
   = mkBinds floats rhs         `thenUs` \ rhs' ->

-    returnUs (nilOL, rhs')
+    returnUs (emptyFloats, rhs')

 
 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings
 
 -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings

-mkLocalNonRec :: Id  -> RhsDemand                      -- Lhs: id with demand
-             -> OrdList FloatingBind -> CoreExpr       -- Rhs: let binds in body
-             -> UniqSM (OrdList FloatingBind)
+mkLocalNonRec :: Id  -> RhsDemand      -- Lhs: id with demand
+             -> Floats -> CoreExpr     -- Rhs: let binds in body
+             -> UniqSM (Floats, Id)    -- The new Id may have an evaldUnfolding, 
+                                       -- to record that it's been evaluated

 
 mkLocalNonRec bndr dem floats rhs
   | isUnLiftedType (idType bndr)
 
 mkLocalNonRec bndr dem floats rhs
   | isUnLiftedType (idType bndr)

@@ -509,33 +599,36 @@ mkLocalNonRec bndr dem floats rhs
     let
        float = FloatCase bndr rhs (exprOkForSpeculation rhs)
     in
     let
        float = FloatCase bndr rhs (exprOkForSpeculation rhs)
     in

-    returnUs (floats `snocOL` float)
+    returnUs (addFloat floats float, evald_bndr)

 
   | 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 ...!
 
   | 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)
+       float | exprIsHNF rhs = FloatLet (NonRec bndr rhs)

              | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
     in
              | otherwise       = FloatCase bndr rhs (exprOkForSpeculation rhs)
     in

-    returnUs (floats `snocOL` float)
+    returnUs (addFloat floats float, evald_bndr)

 
   | otherwise
   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)       `thenUs` \ (floats', rhs') ->
 
   | otherwise
   = floatRhs NotTopLevel NonRecursive bndr (floats, rhs)       `thenUs` \ (floats', rhs') ->

-    returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs'))
+    returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')),
+             if exprIsHNF rhs' then evald_bndr else bndr)

 
   where
 
   where

-    bndr_ty     = idType bndr
-    bndr_rep_ty  = repType bndr_ty
+    evald_bndr = bndr `setIdUnfolding` evaldUnfolding
+       -- Record if the binder is evaluated

 
 

-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' ->

+                       -- Lambdas are not allowed as the body of a 'let'

                    returnUs (foldrOL mk_bind body' binds)
   where
                    returnUs (foldrOL mk_bind body' binds)
   where

-    mk_bind (FloatCase bndr rhs _) body = mkCase rhs bndr [(DEFAULT, [], body)]
+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]

     mk_bind (FloatLet bind)        body = Let bind body
 
 etaExpandRhs bndr rhs
     mk_bind (FloatLet bind)        body = Let bind body
 
 etaExpandRhs bndr rhs

@@ -582,22 +675,29 @@ etaExpandRhs bndr rhs
 -- We arrange that they only show up as the RHS of a let(rec)
 -- ---------------------------------------------------------------------------
 
 -- 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')
+    deLamFloat expr    `thenUs` \ (floats, expr') ->
+    returnUs (floats, Note n expr')

 
 

-deLam expr 
-  | null bndrs = returnUs expr
+deLamFloat expr 
+  | null bndrs = returnUs (emptyFloats, expr)

   | otherwise 
   = case tryEta bndrs body of
   | otherwise 
   = case tryEta bndrs body of

-      Just no_lam_result -> returnUs no_lam_result
+      Just no_lam_result -> returnUs (emptyFloats, no_lam_result)

       Nothing           -> newVar (exprType expr)      `thenUs` \ fn ->
       Nothing           -> newVar (exprType expr)      `thenUs` \ fn ->

-                           returnUs (Let (NonRec fn expr) (Var fn))
+                           returnUs (unitFloat (FloatLet (NonRec fn expr)), 
+                                     Var fn)

   where
     (bndrs,body) = collectBinders expr
 
   where
     (bndrs,body) = collectBinders expr
 

@@ -620,7 +720,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)

@@ -639,55 +739,6 @@ 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@(deflt_alt@(DEFAULT,_,rhs) : con_alts)
-                       -- DEFAULT alt is always first
-  = 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
-       -- 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
 -- -----------------------------------------------------------------------------
 
 -- Demands
 -- -----------------------------------------------------------------------------
 

@@ -708,8 +759,10 @@ bdrDem :: Id -> RhsDemand
 bdrDem id = mkDem (idNewDemandInfo id)
                  False {- For now -}
 
 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}
 

@@ -723,21 +776,59 @@ onceDem = RhsDemand False True   -- used at most once
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

+-- ---------------------------------------------------------------------------
+--                     The environment
+-- ---------------------------------------------------------------------------
+
+data CorePrepEnv = CPE (IdEnv Id)      -- Clone local Ids
+                      Bool             -- True <=> inside a GADT case; see Note [GADT]
+
+-- Note [GADT]
+--
+-- Be careful with cloning inside GADTs.  For example, 
+--     /\a. \f::a. \x::T a. case x of { T -> f True; ... }
+-- The case on x may refine the type of f to be a function type.
+-- Without this type refinement, exprType (f True) may simply fail,
+-- which is bad.  
+--
+-- Solution: remember when we are inside a potentially-type-refining case,
+--          and in that situation use the type from the old occurrence
+--          when looking up occurrences
+
+emptyCorePrepEnv :: CorePrepEnv
+emptyCorePrepEnv = CPE emptyVarEnv False
+
+extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
+extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt
+
+lookupCorePrepEnv :: CorePrepEnv -> Id -> Id
+-- See Note [GADT] above
+lookupCorePrepEnv (CPE env gadt) id
+  = case lookupVarEnv env id of
+       Nothing              -> id
+       Just id' | gadt      -> setIdType id' (idType id)
+                | otherwise -> id'
+
+setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv
+setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True
+setGadt env               other                                                = env
+
+

 ------------------------------------------------------------------------------
 -- Cloning binders
 -- ---------------------------------------------------------------------------
 
 ------------------------------------------------------------------------------
 -- Cloning binders
 -- ---------------------------------------------------------------------------
 

-cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
+cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var])

 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 
 cloneBndrs env bs = mapAccumLUs cloneBndr env bs
 

-cloneBndr  :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
+cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)

 cloneBndr env bndr
   | isLocalId bndr
   = getUniqueUs   `thenUs` \ uniq ->
     let
        bndr' = setVarUnique bndr uniq
     in
 cloneBndr env bndr
   | isLocalId bndr
   = getUniqueUs   `thenUs` \ uniq ->
     let
        bndr' = setVarUnique bndr uniq
     in

-    returnUs (extendVarEnv env bndr bndr', bndr')
+    returnUs (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

@@ -764,5 +855,5 @@ newVar :: Type -> UniqSM Id
 newVar ty
  = seqType ty                  `seq`
    getUniqueUs                 `thenUs` \ uniq ->
 newVar ty
  = seqType ty                  `seq`
    getUniqueUs                 `thenUs` \ uniq ->

-   returnUs (mkSysLocal SLIT("sat") uniq ty)
+   returnUs (mkSysLocal FSLIT("sat") uniq ty)

 \end{code}
 \end{code}