[project @ 1996-05-17 16:02:43 by partain]

[ghc-hetmet.git] / ghc / compiler / simplCore / Simplify.lhs

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 7c21e22..27424dd 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -1,5 +1,5 @@
 %
 %

-% (c) The AQUA Project, Glasgow University, 1993-1995
+% (c) The AQUA Project, Glasgow University, 1993-1996

 %
 \section[Simplify]{The main module of the simplifier}
 
 %
 \section[Simplify]{The main module of the simplifier}
 

@@ -8,36 +8,39 @@
 
 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
 
 
 module Simplify ( simplTopBinds, simplExpr, simplBind ) where
 

-import Pretty          -- these are for debugging only
-import Outputable
+import Ubiq{-uitous-}
+import SmplLoop                -- paranoia checking

 
 

-import SimplMonad
-import SimplEnv
-import TaggedCore
-import PlainCore
-
-import AbsPrel         ( getPrimOpResultInfo, PrimOpResultInfo(..),
-                         primOpOkForSpeculation, PrimOp(..), PrimKind,
-                         realWorldStateTy
-                         IF_ATTACK_PRAGMAS(COMMA realWorldTy)
-                         IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
-                         IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
-                       )
-import AbsUniType      ( getUniDataTyCon_maybe, mkTyVarTy, applyTy,
-                         splitTyArgs, splitTypeWithDictsAsArgs,
-                         maybeUnpackFunTy, isPrimType
-                       )
-import BasicLit                ( isNoRepLit, BasicLit(..) )

 import BinderInfo
 import CmdLineOpts     ( SimplifierSwitch(..) )
 import ConFold         ( completePrim )
 import BinderInfo
 import CmdLineOpts     ( SimplifierSwitch(..) )
 import ConFold         ( completePrim )

-import Id
-import IdInfo
-import Maybes          ( Maybe(..), catMaybes, maybeToBool )
-import SimplCase
-import SimplUtils
+import CoreSyn
+import CoreUtils       ( coreExprType, nonErrorRHSs, maybeErrorApp,
+                         unTagBinders, squashableDictishCcExpr,
+                         manifestlyWHNF
+                       )
+import Id              ( idType, idWantsToBeINLINEd,
+                         getIdDemandInfo, addIdDemandInfo,
+                         GenId{-instance NamedThing-}
+                       )
+import IdInfo          ( willBeDemanded, DemandInfo )
+import Literal         ( isNoRepLit )
+import Maybes          ( maybeToBool )
+import Name            ( isLocallyDefined )
+import PprStyle                ( PprStyle(..) )
+import PprType         ( GenType{-instance Outputable-} )
+import Pretty          ( ppAbove )
+import PrimOp          ( primOpOkForSpeculation, PrimOp(..) )
+import SimplCase       ( simplCase, bindLargeRhs )
+import SimplEnv
+import SimplMonad

 import SimplVar                ( completeVar )
 import SimplVar                ( completeVar )

-import Util
+import SimplUtils
+import Type            ( mkTyVarTy, mkTyVarTys, mkAppTy,
+                         splitFunTy, getFunTy_maybe, eqTy
+                       )
+import TysWiredIn      ( realWorldStateTy )
+import Util            ( isSingleton, zipEqual, panic, pprPanic, assertPanic )

 \end{code}
 
 The controlling flags, and what they do
 \end{code}
 
 The controlling flags, and what they do

@@ -48,7 +51,7 @@ passes:
 -fsimplify             = run the simplifier
 -ffloat-inwards                = runs the float lets inwards pass
 -ffloat                        = runs the full laziness pass
 -fsimplify             = run the simplifier
 -ffloat-inwards                = runs the float lets inwards pass
 -ffloat                        = runs the full laziness pass

-                          (ToDo: rename to -ffull-laziness)
+                         (ToDo: rename to -ffull-laziness)

 -fupdate-analysis      = runs update analyser
 -fstrictness           = runs strictness analyser
 -fsaturate-apps                = saturates applications (eta expansion)
 -fupdate-analysis      = runs update analyser
 -fstrictness           = runs strictness analyser
 -fsaturate-apps                = saturates applications (eta expansion)

@@ -56,20 +59,20 @@ passes:
 options:
 -------
 -ffloat-past-lambda    = OK to do full laziness.
 options:
 -------
 -ffloat-past-lambda    = OK to do full laziness.

-                          (ToDo: remove, as the full laziness pass is
-                                 useless without this flag, therefore
-                                 it is unnecessary. Just -ffull-laziness
-                                 should be kept.)
+                         (ToDo: remove, as the full laziness pass is
+                                useless without this flag, therefore
+                                it is unnecessary. Just -ffull-laziness
+                                should be kept.)

 
 -ffloat-lets-ok                = OK to float lets out of lets if the enclosing
 
 -ffloat-lets-ok                = OK to float lets out of lets if the enclosing

-                          let is strict or if the floating will expose
-                          a WHNF [simplifier].
+                         let is strict or if the floating will expose
+                         a WHNF [simplifier].

 
 

--ffloat-primops-ok     = OK to float out of lets cases whose scrutinee 
-                          is a primop that cannot fail [simplifier].
+-ffloat-primops-ok     = OK to float out of lets cases whose scrutinee
+                         is a primop that cannot fail [simplifier].

 
 -fcode-duplication-ok  = allows the previous option to work on cases with
 
 -fcode-duplication-ok  = allows the previous option to work on cases with

-                          multiple branches [simplifier].
+                         multiple branches [simplifier].

 
 -flet-to-case          = does let-to-case transformation [simplifier].
 
 
 -flet-to-case          = does let-to-case transformation [simplifier].
 

@@ -113,7 +116,7 @@ you decide not to use it.
 Head normal forms
 ~~~~~~~~~~~~~~~~~
 We *never* put a non-HNF unfolding in the UnfoldEnv except in the
 Head normal forms
 ~~~~~~~~~~~~~~~~~
 We *never* put a non-HNF unfolding in the UnfoldEnv except in the

-INLINE-pragma case.  
+INLINE-pragma case.

 
 At one time I thought it would be OK to put non-HNF unfoldings in for
 variables which occur only once [if they got inlined at that
 
 At one time I thought it would be OK to put non-HNF unfoldings in for
 variables which occur only once [if they got inlined at that

@@ -124,12 +127,12 @@ would occur].   But consider:
            f = \y -> ...y...y...y...
        in f x
 @
            f = \y -> ...y...y...y...
        in f x
 @

-Now, it seems that @x@ appears only once, but even so it is NOT safe to put @x@
-in the UnfoldEnv, because @f@ will be inlined, and will duplicate the references to
-@x@.  
+Now, it seems that @x@ appears only once, but even so it is NOT safe
+to put @x@ in the UnfoldEnv, because @f@ will be inlined, and will
+duplicate the references to @x@.

 
 

-Becuase of this, the "unconditional-inline" mechanism above is the only way
-in which non-HNFs can get inlined.
+Because of this, the "unconditional-inline" mechanism above is the
+only way in which non-HNFs can get inlined.

 
 INLINE pragmas
 ~~~~~~~~~~~~~~
 
 INLINE pragmas
 ~~~~~~~~~~~~~~

@@ -151,7 +154,7 @@ because then we'd duplicate BIG when we inline'd y.  (Exception:
 things in the UnfoldEnv with UnfoldAlways flags, which originated in
 other INLINE pragmas.)
 
 things in the UnfoldEnv with UnfoldAlways flags, which originated in
 other INLINE pragmas.)
 

-So, we clean out the UnfoldEnv of all GeneralForm inlinings before
+So, we clean out the UnfoldEnv of all GenForm inlinings before

 going into such an RHS.
 
 What about imports?  They don't really matter much because we only
 going into such an RHS.
 
 What about imports?  They don't really matter much because we only

@@ -185,50 +188,42 @@ simplTopBinds env [] = returnSmpl []
 
 -- Dead code is now discarded by the occurrence analyser,
 
 
 -- Dead code is now discarded by the occurrence analyser,
 

-simplTopBinds env (CoNonRec binder@(in_id, occ_info) rhs : binds)
+simplTopBinds env (NonRec binder@(in_id, occ_info) rhs : binds)

   | inlineUnconditionally ok_to_dup_code occ_info
   | inlineUnconditionally ok_to_dup_code occ_info

-  = --pprTrace "simplTopBinds (inline):" (ppr PprDebug in_id) (
-    let
+  = let

        new_env = extendIdEnvWithInlining env env binder rhs
     in
     simplTopBinds new_env binds
        new_env = extendIdEnvWithInlining env env binder rhs
     in
     simplTopBinds new_env binds

-    --)

   where
     ok_to_dup_code = switchIsSet env SimplOkToDupCode
 
   where
     ok_to_dup_code = switchIsSet env SimplOkToDupCode
 

-simplTopBinds env (CoNonRec binder@(in_id,occ_info) rhs : binds)
+simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)

   =    -- No cloning necessary at top level
        -- Process the binding
     simplRhsExpr env binder rhs                `thenSmpl` \ rhs' ->
     let
        new_env = case rhs' of
   =    -- No cloning necessary at top level
        -- Process the binding
     simplRhsExpr env binder rhs                `thenSmpl` \ rhs' ->
     let
        new_env = case rhs' of

-        CoVar var                        -> extendIdEnvWithAtom env binder (CoVarAtom var)
-         CoLit lit | not (isNoRepLit lit) -> extendIdEnvWithAtom env binder (CoLitAtom lit)
-         other                           -> extendUnfoldEnvGivenRhs env binder in_id rhs'
+        Var v                      -> extendIdEnvWithAtom env binder (VarArg v)
+        Lit i | not (isNoRepLit i) -> extendIdEnvWithAtom env binder (LitArg i)
+        other                      -> extendUnfoldEnvGivenRhs env binder in_id rhs'

     in
     in

-    --pprTrace "simplTopBinds (nonrec):" (ppCat [ppr PprDebug in_id, ppr PprDebug rhs']) (
-

        -- Process the other bindings
     simplTopBinds new_env binds        `thenSmpl` \ binds' ->
 
        -- Glue together and return ...
        -- Process the other bindings
     simplTopBinds new_env binds        `thenSmpl` \ binds' ->
 
        -- Glue together and return ...

-       -- We leave it to susequent occurrence analysis to throw away 
+       -- We leave it to susequent occurrence analysis to throw away

        -- an unused atom binding. This localises the decision about
        -- discarding top-level bindings.
        -- an unused atom binding. This localises the decision about
        -- discarding top-level bindings.

-    returnSmpl (CoNonRec in_id rhs' : binds')
-    --)
+    returnSmpl (NonRec in_id rhs' : binds')

 
 

-simplTopBinds env (CoRec pairs : binds)
+simplTopBinds env (Rec pairs : binds)

   = simplRecursiveGroup env triples    `thenSmpl` \ (bind', new_env) ->
 
   = simplRecursiveGroup env triples    `thenSmpl` \ (bind', new_env) ->
 

-    --pprTrace "simplTopBinds (rec):" (ppCat [ppr PprDebug bind']) (
-

        -- Process the other bindings
     simplTopBinds new_env binds                `thenSmpl` \ binds' ->
 
        -- Glue together and return
     returnSmpl (bind' : binds')
        -- Process the other bindings
     simplTopBinds new_env binds                `thenSmpl` \ binds' ->
 
        -- Glue together and return
     returnSmpl (bind' : binds')

-    --)

   where
     triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
                -- No cloning necessary at top level
   where
     triples = [(id, (binder, rhs)) | (binder@(id,_), rhs) <- pairs]
                -- No cloning necessary at top level

@@ -240,11 +235,11 @@ simplTopBinds env (CoRec pairs : binds)
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-       
-\begin{code} 
+
+\begin{code}

 simplExpr :: SimplEnv
          -> InExpr -> [OutArg]
 simplExpr :: SimplEnv
          -> InExpr -> [OutArg]

-         -> SmplM OutExpr 
+         -> SmplM OutExpr

 \end{code}
 
 The expression returned has the same meaning as the input expression
 \end{code}
 
 The expression returned has the same meaning as the input expression

@@ -253,63 +248,62 @@ applied to the specified arguments.
 
 Variables
 ~~~~~~~~~
 
 Variables
 ~~~~~~~~~

-Check if there's a macro-expansion, and if so rattle on.  Otherwise
-do the more sophisticated stuff.
+Check if there's a macro-expansion, and if so rattle on.  Otherwise do
+the more sophisticated stuff.

 
 \begin{code}
 
 \begin{code}

-simplExpr env (CoVar v) args
-  = --pprTrace "simplExpr:Var:" (ppr PprDebug v) (
-    case lookupId env v of
+simplExpr env (Var v) args
+  = case (lookupId env v) of

       Nothing -> let
       Nothing -> let

-                       new_v = simplTyInId env v
+                   new_v = simplTyInId env v

                 in
                 completeVar env new_v args
 
       Just info ->
        case info of
                 in
                 completeVar env new_v args
 
       Just info ->
        case info of

-         ItsAnAtom (CoLitAtom lit)     -- A boring old literal
+         ItsAnAtom (LitArg lit)        -- A boring old literal

                        -- Paranoia check for args empty
            ->  case args of
                        -- Paranoia check for args empty
            ->  case args of

-                 []    -> returnSmpl (CoLit lit)
+                 []    -> returnSmpl (Lit lit)

                  other -> panic "simplExpr:coVar"
 
                  other -> panic "simplExpr:coVar"
 

-         ItsAnAtom (CoVarAtom var)     -- More interesting!  An id!
+         ItsAnAtom (VarArg var)        -- More interesting!  An id!

                                        -- No need to substitute the type env here,
                                        -- because we already have!
                                        -- No need to substitute the type env here,
                                        -- because we already have!

-           -> completeVar env var args 
-               
+           -> completeVar env var args
+

          InlineIt id_env ty_env in_expr        -- A macro-expansion
            -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args
          InlineIt id_env ty_env in_expr        -- A macro-expansion
            -> simplExpr (replaceInEnvs env (ty_env, id_env)) in_expr args

-    --)

 \end{code}
 
 Literals
 \end{code}
 
 Literals

-~~~~~~~~~
+~~~~~~~~

 
 \begin{code}
 
 \begin{code}

-simplExpr env (CoLit l) [] = returnSmpl (CoLit l)
-simplExpr env (CoLit l) _  = panic "simplExpr:CoLit with argument"
+simplExpr env (Lit l) [] = returnSmpl (Lit l)
+#ifdef DEBUG
+simplExpr env (Lit l) _  = panic "simplExpr:Lit with argument"
+#endif

 \end{code}
 
 \end{code}
 

-Primitive applications are simple.  
+Primitive applications are simple.

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 

-NB: CoPrim expects an empty argument list! (Because it should be
+NB: Prim expects an empty argument list! (Because it should be

 saturated and not higher-order. ADR)
 
 saturated and not higher-order. ADR)
 

-\begin{code} 
-simplExpr env (CoPrim op tys prim_args) args
+\begin{code}
+simplExpr env (Prim op prim_args) args

   = ASSERT (null args)
     let
   = ASSERT (null args)
     let

-       tys'       = [simplTy   env ty       | ty       <- tys]
-       prim_args' = [simplAtom env prim_arg | prim_arg <- prim_args]
+       prim_args' = [simplArg env prim_arg | prim_arg <- prim_args]

        op'        = simpl_op op
     in
        op'        = simpl_op op
     in

-    completePrim env op' tys' prim_args'
+    completePrim env op' prim_args'

   where
     -- PrimOps just need any types in them renamed.
 
   where
     -- PrimOps just need any types in them renamed.
 

-    simpl_op (CCallOp label is_asm may_gc arg_tys result_ty) 
+    simpl_op (CCallOp label is_asm may_gc arg_tys result_ty)

       = let
            arg_tys'    = map (simplTy env) arg_tys
            result_ty'  = simplTy env result_ty
       = let
            arg_tys'    = map (simplTy env) arg_tys
            result_ty'  = simplTy env result_ty

@@ -319,31 +313,25 @@ simplExpr env (CoPrim op tys prim_args) args
     simpl_op other_op = other_op
 \end{code}
 
     simpl_op other_op = other_op
 \end{code}
 

-Constructor applications 
-~~~~~~~~~~~~~~~~~~~~~~~~ 
+Constructor applications
+~~~~~~~~~~~~~~~~~~~~~~~~

 Nothing to try here.  We only reuse constructors when they appear as the
 rhs of a let binding (see completeLetBinding).
 
 \begin{code}
 Nothing to try here.  We only reuse constructors when they appear as the
 rhs of a let binding (see completeLetBinding).
 
 \begin{code}

-simplExpr env (CoCon con tys con_args) args
+simplExpr env (Con con con_args) args

   = ASSERT( null args )
   = ASSERT( null args )

-    returnSmpl (CoCon con tys' con_args')
-  where
-    con_args' = [simplAtom env con_arg | con_arg <- con_args]
-    tys'      = [simplTy   env ty      | ty <- tys]
+    returnSmpl (Con con [simplArg env con_arg | con_arg <- con_args])

 \end{code}
 
 
 \end{code}
 
 

-Applications are easy too: 
-~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+Applications are easy too:
+~~~~~~~~~~~~~~~~~~~~~~~~~~

 Just stuff 'em in the arg stack
 
 Just stuff 'em in the arg stack
 

-\begin{code} 
-simplExpr env (CoApp fun arg) args
-  = simplExpr env fun (ValArg (simplAtom env arg) : args)
-
-simplExpr env (CoTyApp fun ty) args
-  = simplExpr env fun (TypeArg (simplTy env ty) : args)
+\begin{code}
+simplExpr env (App fun arg) args
+  = simplExpr env fun (simplArg env arg : args)

 \end{code}
 
 Type lambdas
 \end{code}
 
 Type lambdas

@@ -351,21 +339,21 @@ Type lambdas
 
 We only eta-reduce a type lambda if all type arguments in the body can
 be eta-reduced. This requires us to collect up all tyvar parameters so
 
 We only eta-reduce a type lambda if all type arguments in the body can
 be eta-reduced. This requires us to collect up all tyvar parameters so

-we can pass them all to @mkCoTyLamTryingEta@.
+we can pass them all to @mkTyLamTryingEta@.

 
 

-\begin{code} 
-simplExpr env (CoTyLam tyvar body) (TypeArg ty : args)
-  = ASSERT(not (isPrimType ty))
+\begin{code}
+simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args)
+  = -- ASSERT(not (isPrimType ty))

     let
        new_env = extendTyEnv env tyvar ty
     in
     tick TyBetaReduction       `thenSmpl_`
     simplExpr new_env body args
 
     let
        new_env = extendTyEnv env tyvar ty
     in
     tick TyBetaReduction       `thenSmpl_`
     simplExpr new_env body args
 

-simplExpr env tylam@(CoTyLam tyvar body) []
-  = do_tylambdas env [] tylam 
+simplExpr env tylam@(Lam (TyBinder tyvar) body) []
+  = do_tylambdas env [] tylam

   where
   where

-    do_tylambdas env tyvars' (CoTyLam tyvar body)
+    do_tylambdas env tyvars' (Lam (TyBinder tyvar) body)

       =          -- Clone the type variable
        cloneTyVarSmpl tyvar            `thenSmpl` \ tyvar' ->
        let
       =          -- Clone the type variable
        cloneTyVarSmpl tyvar            `thenSmpl` \ tyvar' ->
        let

@@ -377,12 +365,14 @@ simplExpr env tylam@(CoTyLam tyvar body) []
       =        simplExpr env body []           `thenSmpl` \ body' ->
        returnSmpl (
           (if switchIsSet env SimplDoEtaReduction
       =        simplExpr env body []           `thenSmpl` \ body' ->
        returnSmpl (
           (if switchIsSet env SimplDoEtaReduction

-          then mkCoTyLamTryingEta
-          else mkCoTyLam) (reverse tyvars')  body'
+          then mkTyLamTryingEta
+          else mkTyLam) (reverse tyvars')  body'

        )
 
        )
 

-simplExpr env (CoTyLam tyvar body) (ValArg _ : _)
-  = panic "simplExpr:CoTyLam ValArg" 
+#ifdef DEBUG
+simplExpr env (Lam (TyBinder _) _) (_ : _)
+  = panic "simplExpr:TyLam with non-TyArg"
+#endif

 \end{code}
 
 
 \end{code}
 
 

@@ -390,7 +380,7 @@ Ordinary lambdas
 ~~~~~~~~~~~~~~~~
 
 \begin{code}
 ~~~~~~~~~~~~~~~~
 
 \begin{code}

-simplExpr env (CoLam binders body) args
+simplExpr env (Lam (ValBinder binder) body) args

   | null leftover_binders
   =    -- The lambda is saturated (or over-saturated)
     tick BetaReduction `thenSmpl_`
   | null leftover_binders
   =    -- The lambda is saturated (or over-saturated)
     tick BetaReduction `thenSmpl_`

@@ -405,11 +395,11 @@ simplExpr env (CoLam binders body) args
      else returnSmpl (panic "BetaReduction")
     ) `thenSmpl_`
 
      else returnSmpl (panic "BetaReduction")
     ) `thenSmpl_`
 

-    simplLam env_for_too_few_args leftover_binders body 
+    simplLam env_for_too_few_args leftover_binders body

             0 {- Guaranteed applied to at least 0 args! -}
 
   where
             0 {- Guaranteed applied to at least 0 args! -}
 
   where

-    (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binders args
+    (binder_args_pairs, leftover_binders, leftover_args) = collect_val_args binder args

 
     env_for_enough_args  = extendIdEnvWithAtomList env binder_args_pairs
 
 
     env_for_enough_args  = extendIdEnvWithAtomList env binder_args_pairs
 

@@ -426,49 +416,70 @@ simplExpr env (CoLam binders body) args
        --              (\ x y z -> e) p q r
        --          ==> e[p/x, q/y, r/z]
        --
        --              (\ x y z -> e) p q r
        --          ==> e[p/x, q/y, r/z]
        --

-    zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg) 
+    zapped_binder_args_pairs = [ ((id, markDangerousToDup occ_info), arg)

                               | ((id, occ_info), arg) <- binder_args_pairs ]
 
                               | ((id, occ_info), arg) <- binder_args_pairs ]
 

-    collect_val_args :: [InBinder]     -- Binders
-                    -> [OutArg]        -- Arguments
-                    -> ([(InBinder,OutAtom)],  -- Binder,arg pairs
-                         [InBinder],           -- Leftover binders
-                         [OutArg])             -- Leftover args
-       
+    collect_val_args :: InBinder               -- Binder
+                    -> [OutArg]                -- Arguments
+                    -> ([(InBinder,OutArg)],   -- Binder,arg pairs (ToDo: a maybe?)
+                        [InBinder],            -- Leftover binders (ToDo: a maybe)
+                        [OutArg])              -- Leftover args
+

        -- collect_val_args strips off the leading ValArgs from
        -- the current arg list, returning them along with the
        -- depleted list
        -- collect_val_args strips off the leading ValArgs from
        -- the current arg list, returning them along with the
        -- depleted list

-    collect_val_args []      args = ([], [], args)
-    collect_val_args binders []   = ([], binders, [])
-    collect_val_args (binder:binders) (ValArg val_arg : args)
-       = ((binder,val_arg):rest_pairs, leftover_binders, leftover_args)
-       where
-         (rest_pairs, leftover_binders, leftover_args) = collect_val_args binders args
-
-    collect_val_args (binder:binders) (other_val_arg : args) = panic "collect_val_args"
-               -- TypeArg should never meet a CoLam
+    collect_val_args binder []   = ([], [binder], [])
+    collect_val_args binder (arg : args) | isValArg arg
+       = ([(binder,arg)], [], args)
+
+#ifdef DEBUG
+    collect_val_args _ (other_val_arg : _) = panic "collect_val_args"
+               -- TyArg should never meet a Lam
+#endif

 \end{code}
 
 
 \end{code}
 
 

-Let expressions 
+Let expressions

 ~~~~~~~~~~~~~~~
 
 ~~~~~~~~~~~~~~~
 

-\begin{code}   
-simplExpr env (CoLet bind body) args
-  = simplBind env bind (\env -> simplExpr env body args) (computeResultType env body args)
+\begin{code}
+simplExpr env (Let bind body) args
+
+{- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
+   and it doesn't seem worth retaining the ability to not float applications
+   into let/case 
+
+  | switchIsSet env SimplNoLetFromApp
+  = simplBind env bind (\env -> simplExpr env body [])
+                      (computeResultType env body [])  `thenSmpl` \ let_expr' ->
+    returnSmpl (mkGenApp let_expr' args)
+
+  | otherwise          -- No float from application
+-}
+
+  = simplBind env bind (\env -> simplExpr env body args)
+                      (computeResultType env body args)

 \end{code}
 
 \end{code}
 

-Case expressions 
+Case expressions

 ~~~~~~~~~~~~~~~~
 
 \begin{code}
 ~~~~~~~~~~~~~~~~
 
 \begin{code}

-simplExpr env expr@(CoCase scrut alts) args
+simplExpr env expr@(Case scrut alts) args

   = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
                             (computeResultType env expr args)
 \end{code}
 
 
   = simplCase env scrut alts (\env rhs -> simplExpr env rhs args)
                             (computeResultType env expr args)
 \end{code}
 
 

-Set-cost-centre 
+Coercions
+~~~~~~~~~
+\begin{code}
+simplExpr env (Coerce coercion ty body) args
+  = simplCoerce env coercion ty body args 
+\end{code}
+
+
+Set-cost-centre

 ~~~~~~~~~~~~~~~
 
 A special case we do:
 ~~~~~~~~~~~~~~~
 
 A special case we do:

@@ -479,20 +490,17 @@ Simon thinks it's OK, at least for lexical scoping; and it makes
 interfaces change less (arities).
 
 \begin{code}
 interfaces change less (arities).
 
 \begin{code}

-simplExpr env (CoSCC cc (CoLam binders body)) args
-  = simplExpr env (CoLam binders (CoSCC cc body)) args
-
-simplExpr env (CoSCC cc (CoTyLam tyvar body)) args
-  = simplExpr env (CoTyLam tyvar (CoSCC cc body)) args
+simplExpr env (SCC cc (Lam binder body)) args
+  = simplExpr env (Lam binder (SCC cc body)) args

 \end{code}
 
 Some other slightly turgid SCC tidying-up cases:
 \begin{code}
 \end{code}
 
 Some other slightly turgid SCC tidying-up cases:
 \begin{code}

-simplExpr env (CoSCC cc1 expr@(CoSCC _ _)) args
+simplExpr env (SCC cc1 expr@(SCC _ _)) args

   = simplExpr env expr args
   = simplExpr env expr args

-    -- the outer _scc_ serves no purpose 
+    -- the outer _scc_ serves no purpose

 
 

-simplExpr env (CoSCC cc expr) args
+simplExpr env (SCC cc expr) args

   | squashableDictishCcExpr cc expr
   = simplExpr env expr args
     -- the DICT-ish CC is no longer serving any purpose
   | squashableDictishCcExpr cc expr
   = simplExpr env expr args
     -- the DICT-ish CC is no longer serving any purpose

@@ -502,12 +510,12 @@ NB: for other set-cost-centre we move arguments inside the body.
 ToDo: check with Patrick that this is ok.
 
 \begin{code}
 ToDo: check with Patrick that this is ok.
 
 \begin{code}

-simplExpr env (CoSCC cost_centre body) args
+simplExpr env (SCC cost_centre body) args

   = let
        new_env = setEnclosingCC env (EnclosingCC cost_centre)
     in
     simplExpr new_env body args                `thenSmpl` \ body' ->
   = let
        new_env = setEnclosingCC env (EnclosingCC cost_centre)
     in
     simplExpr new_env body args                `thenSmpl` \ body' ->

-    returnSmpl (CoSCC cost_centre body') 
+    returnSmpl (SCC cost_centre body')

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -529,13 +537,13 @@ it transforms the rhs to
 This is a Very Good Thing!
 
 \begin{code}
 This is a Very Good Thing!
 
 \begin{code}

-simplRhsExpr 
+simplRhsExpr

        :: SimplEnv
        -> InBinder
        -> InExpr
        :: SimplEnv
        -> InBinder
        -> InExpr

-       -> SmplM OutExpr 
+       -> SmplM OutExpr

 
 

-simplRhsExpr env binder@(id,occ_info) rhs 
+simplRhsExpr env binder@(id,occ_info) rhs

   | dont_eta_expand rhs
   = simplExpr rhs_env rhs []
 
   | dont_eta_expand rhs
   = simplExpr rhs_env rhs []
 

@@ -543,7 +551,7 @@ simplRhsExpr env binder@(id,occ_info) rhs
   =    -- Deal with the big lambda part
     mapSmpl cloneTyVarSmpl tyvars                      `thenSmpl` \ tyvars' ->
     let
   =    -- Deal with the big lambda part
     mapSmpl cloneTyVarSmpl tyvars                      `thenSmpl` \ tyvars' ->
     let

-       lam_env  = extendTyEnvList rhs_env (tyvars `zip` (map mkTyVarTy tyvars'))
+       lam_env  = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars (mkTyVarTys tyvars'))

     in
        -- Deal with the little lambda part
        -- Note that we call simplLam even if there are no binders, in case
     in
        -- Deal with the little lambda part
        -- Note that we call simplLam even if there are no binders, in case

@@ -553,8 +561,8 @@ simplRhsExpr env binder@(id,occ_info) rhs
        -- Put it back together
     returnSmpl (
        (if switchIsSet env SimplDoEtaReduction
        -- Put it back together
     returnSmpl (
        (if switchIsSet env SimplDoEtaReduction

-       then mkCoTyLamTryingEta
-       else mkCoTyLam) tyvars' lambda'
+       then mkTyLamTryingEta
+       else mkTyLam) tyvars' lambda'

     )
   where
        -- Note from ANDY:
     )
   where
        -- Note from ANDY:

@@ -563,8 +571,8 @@ simplRhsExpr env binder@(id,occ_info) rhs
        -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
     rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
            | otherwise                      = env
        -- we might want a {-# INLINE UNSIMPLIFIED #-} option.
     rhs_env | simplIdWantsToBeINLINEd id env = filterUnfoldEnvForInlines env
            | otherwise                      = env

-       
-    (tyvars, binders, body) = digForLambdas rhs
+
+    (uvars, tyvars, binders, body) = collectBinders rhs

 
     min_no_of_args | not (null binders)                        &&      -- It's not a thunk
                     switchIsSet env SimplDoArityExpand         -- Arity expansion on
 
     min_no_of_args | not (null binders)                        &&      -- It's not a thunk
                     switchIsSet env SimplDoArityExpand         -- Arity expansion on

@@ -580,18 +588,20 @@ simplRhsExpr env binder@(id,occ_info) rhs
        -- get eta-reduced back to y.  Furthermore, if this was a top level defn,
        -- and x was exported, then the defn won't be eliminated, so this
        -- silly expand/reduce cycle will happen every time, which makes the
        -- get eta-reduced back to y.  Furthermore, if this was a top level defn,
        -- and x was exported, then the defn won't be eliminated, so this
        -- silly expand/reduce cycle will happen every time, which makes the

-       -- simplifier loop!. 
+       -- simplifier loop!.

        -- The solution is to not even try eta expansion unless the rhs looks
        -- The solution is to not even try eta expansion unless the rhs looks

-       -- non-trivial.  
-    dont_eta_expand (CoLit _)     = True
-    dont_eta_expand (CoVar _)     = True
-    dont_eta_expand (CoTyApp f _) = dont_eta_expand f
-    dont_eta_expand (CoTyLam _ b) = dont_eta_expand b
-    dont_eta_expand (CoCon _ _ _) = True
-    dont_eta_expand _            = False
+       -- non-trivial.
+    dont_eta_expand (Lit _)     = True
+    dont_eta_expand (Var _)     = True
+    dont_eta_expand (Con _ _)   = True
+    dont_eta_expand (App f a)
+      | notValArg    a         = dont_eta_expand f
+    dont_eta_expand (Lam x b)
+      | notValBinder x         = dont_eta_expand b
+    dont_eta_expand _          = False

 \end{code}
 
 \end{code}
 

-               
+

 %************************************************************************
 %*                                                                     *
 \subsection{Simplify a lambda abstraction}
 %************************************************************************
 %*                                                                     *
 \subsection{Simplify a lambda abstraction}

@@ -613,8 +623,8 @@ simplLam env binders body min_no_of_args
     simplExpr new_env body []          `thenSmpl` \ body' ->
     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction
     simplExpr new_env body []          `thenSmpl` \ body' ->
     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction

-       then mkCoLamTryingEta
-       else mkCoLam) binders' body'
+       then mkValLamTryingEta
+       else mkValLam) binders' body'

     )
 
   | otherwise                          -- Eta expansion possible
     )
 
   | otherwise                          -- Eta expansion possible

@@ -623,17 +633,17 @@ simplLam env binders body min_no_of_args
     let
        new_env = extendIdEnvWithClones env binders binders'
     in
     let
        new_env = extendIdEnvWithClones env binders binders'
     in

-    newIds extra_binder_tys                                            `thenSmpl` \ extra_binders' ->
-    simplExpr new_env body (map (ValArg.CoVarAtom) extra_binders')     `thenSmpl` \ body' ->
+    newIds extra_binder_tys                            `thenSmpl` \ extra_binders' ->
+    simplExpr new_env body (map VarArg extra_binders') `thenSmpl` \ body' ->

     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction
     returnSmpl (
       (if switchIsSet new_env SimplDoEtaReduction

-       then mkCoLamTryingEta
-       else mkCoLam) (binders' ++ extra_binders') body'
+       then mkValLamTryingEta
+       else mkValLam) (binders' ++ extra_binders') body'

     )
 
   where
     )
 
   where

-    (potential_extra_binder_tys, res_ty) 
-       = splitTyArgs (simplTy env (typeOfCoreExpr (unTagBinders body)))
+    (potential_extra_binder_tys, res_ty)
+       = splitFunTy (simplTy env (coreExprType (unTagBinders body)))

        -- Note: it's possible that simplLam will be applied to something
        -- with a forall type.  Eg when being applied to the rhs of
        --              let x = wurble
        -- Note: it's possible that simplLam will be applied to something
        -- with a forall type.  Eg when being applied to the rhs of
        --              let x = wurble

@@ -656,9 +666,41 @@ simplLam env binders body min_no_of_args
                                -- but usually doesn't
                           `max`
                           case potential_extra_binder_tys of
                                -- but usually doesn't
                           `max`
                           case potential_extra_binder_tys of

-                               [ty] | ty == realWorldStateTy -> 1
-                               other                         -> 0
+                               [ty] | ty `eqTy` realWorldStateTy -> 1
+                               other                             -> 0
+
+\end{code}
+

 
 

+
+%************************************************************************
+%*                                                                     *
+\subsection[Simplify-coerce]{Coerce expressions}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+-- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
+simplCoerce env coercion ty expr@(Case scrut alts) args
+  = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
+                            (computeResultType env expr args)
+
+-- (coerce (let defns in b)) args  ==> let defns' in (coerce b) args
+simplCoerce env coercion ty (Let bind body) args
+  = simplBind env bind (\env -> simplCoerce env coercion ty body args)
+                      (computeResultType env body args)
+
+-- Default case
+simplCoerce env coercion ty expr args
+  = simplExpr env expr []      `thenSmpl` \ expr' ->
+    returnSmpl (mkGenApp (mkCoerce coercion (simplTy env ty) expr') args)
+  where
+
+       -- Try cancellation; we do this "on the way up" because
+       -- I think that's where it'll bite best
+    mkCoerce (CoerceIn  con1) ty1 (Coerce (CoerceOut con2) ty2 body) | con1 == con2 = body
+    mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn  con2) ty2 body) | con1 == con2 = body
+    mkCoerce coercion ty  body = Coerce coercion ty body

 \end{code}
 
 
 \end{code}
 
 

@@ -672,7 +714,7 @@ simplLam env binders body min_no_of_args
 simplBind :: SimplEnv
          -> InBinding
          -> (SimplEnv -> SmplM OutExpr)
 simplBind :: SimplEnv
          -> InBinding
          -> (SimplEnv -> SmplM OutExpr)

-         -> OutUniType
+         -> OutType

          -> SmplM OutExpr
 \end{code}
 
          -> SmplM OutExpr
 \end{code}
 

@@ -703,11 +745,11 @@ becomes:
 
 ==>
       let join_body x' = foldr c n x'
 
 ==>
       let join_body x' = foldr c n x'

-        in case y of
-        p1 -> let x* = build e1
-                in join_body x*
-        p2 -> let x* = build e2
-                in join_body x*
+       in case y of
+       p1 -> let x* = build e1
+               in join_body x*
+       p2 -> let x* = build e2
+               in join_body x*

 
 note that join_body is a let-no-escape.
 In this particular example join_body will later be inlined,
 
 note that join_body is a let-no-escape.
 In this particular example join_body will later be inlined,

@@ -719,7 +761,7 @@ ToDo: check this is OK with andy
 \begin{code}
 -- Dead code is now discarded by the occurrence analyser,
 
 \begin{code}
 -- Dead code is now discarded by the occurrence analyser,
 

-simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
+simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty

   |  inlineUnconditionally ok_to_dup occ_info
   = body_c (extendIdEnvWithInlining env env binder rhs)
 
   |  inlineUnconditionally ok_to_dup occ_info
   = body_c (extendIdEnvWithInlining env env binder rhs)
 

@@ -733,7 +775,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 -- If we do case-floating first we get this:
 --
 --     let k = \a* -> b
 -- If we do case-floating first we get this:
 --
 --     let k = \a* -> b

---     in case v of 
+--     in case v of

 --             p1-> let a*=e1 in k a
 --             p2-> let a*=e2 in k a
 --
 --             p1-> let a*=e1 in k a
 --             p2-> let a*=e2 in k a
 --

@@ -750,7 +792,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 -- The latter is clearly better.  (Remember the reboxing let-decl
 -- for a is likely to go away, because after all b is strict in a.)
 
 -- The latter is clearly better.  (Remember the reboxing let-decl
 -- for a is likely to go away, because after all b is strict in a.)
 

-  | will_be_demanded && 
+  | will_be_demanded &&

     try_let_to_case &&
     type_ok_for_let_to_case rhs_ty &&
     not (manifestlyWHNF rhs)
     try_let_to_case &&
     type_ok_for_let_to_case rhs_ty &&
     not (manifestlyWHNF rhs)

@@ -779,8 +821,8 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
          its body (obviously).
        -}
 
          its body (obviously).
        -}
 

-  | will_be_demanded ||
-    always_float_let_from_let || 
+  | (will_be_demanded && not no_float) ||
+    always_float_let_from_let ||

     floatExposesHNF float_lets float_primops ok_to_dup rhs
   = try_float env rhs body_c
 
     floatExposesHNF float_lets float_primops ok_to_dup rhs
   = try_float env rhs body_c
 

@@ -789,42 +831,43 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
 
   where
     will_be_demanded = willBeDemanded (getIdDemandInfo id)
 
   where
     will_be_demanded = willBeDemanded (getIdDemandInfo id)

-    rhs_ty          = getIdUniType id
+    rhs_ty          = idType id

 
     float_lets               = switchIsSet env SimplFloatLetsExposingWHNF
     float_primops            = switchIsSet env SimplOkToFloatPrimOps
     ok_to_dup                = switchIsSet env SimplOkToDupCode
     always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
     try_let_to_case           = switchIsSet env SimplLetToCase
 
     float_lets               = switchIsSet env SimplFloatLetsExposingWHNF
     float_primops            = switchIsSet env SimplOkToFloatPrimOps
     ok_to_dup                = switchIsSet env SimplOkToDupCode
     always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
     try_let_to_case           = switchIsSet env SimplLetToCase

+    no_float                 = switchIsSet env SimplNoLetFromStrictLet

 
     -------------------------------------------
     done_float env rhs body_c
        = simplRhsExpr env binder rhs   `thenSmpl` \ rhs' ->
 
     -------------------------------------------
     done_float env rhs body_c
        = simplRhsExpr env binder rhs   `thenSmpl` \ rhs' ->

-         completeLet env binder rhs rhs' body_c body_ty
+         completeLet env binder rhs' body_c body_ty

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

-    try_float env (CoLet bind rhs) body_c
+    try_float env (Let bind rhs) body_c

       = tick LetFloatFromLet                    `thenSmpl_`
       = tick LetFloatFromLet                    `thenSmpl_`

-        simplBind env (fix_up_demandedness will_be_demanded bind) 
+       simplBind env (fix_up_demandedness will_be_demanded bind)

                      (\env -> try_float env rhs body_c) body_ty
 
                      (\env -> try_float env rhs body_c) body_ty
 

-    try_float env (CoCase scrut alts) body_c
+    try_float env (Case scrut alts) body_c

       | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
       = tick CaseFloatFromLet                          `thenSmpl_`
 
        -- First, bind large let-body if necessary
        if no_need_to_bind_large_body then
            simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty
       | will_be_demanded || (float_primops && is_cheap_prim_app scrut)
       = tick CaseFloatFromLet                          `thenSmpl_`
 
        -- First, bind large let-body if necessary
        if no_need_to_bind_large_body then
            simplCase env scrut alts (\env rhs -> try_float env rhs body_c) body_ty

-       else            
+       else

            bindLargeRhs env [binder] body_ty body_c    `thenSmpl` \ (extra_binding, new_body) ->
            let
                body_c' = \env -> simplExpr env new_body []
            in
            bindLargeRhs env [binder] body_ty body_c    `thenSmpl` \ (extra_binding, new_body) ->
            let
                body_c' = \env -> simplExpr env new_body []
            in

-           simplCase env scrut alts 
+           simplCase env scrut alts

                      (\env rhs -> try_float env rhs body_c')
                      body_ty                           `thenSmpl` \ case_expr ->
 
                      (\env rhs -> try_float env rhs body_c')
                      body_ty                           `thenSmpl` \ case_expr ->
 

-           returnSmpl (CoLet extra_binding case_expr)
+           returnSmpl (Let extra_binding case_expr)

       where
        no_need_to_bind_large_body
          = ok_to_dup || isSingleton (nonErrorRHSs alts)
       where
        no_need_to_bind_large_body
          = ok_to_dup || isSingleton (nonErrorRHSs alts)

@@ -832,7 +875,7 @@ simplBind env (CoNonRec binder@(id,occ_info) rhs) body_c body_ty
     try_float env other_rhs body_c = done_float env other_rhs body_c
 \end{code}
 
     try_float env other_rhs body_c = done_float env other_rhs body_c
 \end{code}
 

-Letrec expressions 
+Letrec expressions

 ~~~~~~~~~~~~~~~~~~
 
 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is
 ~~~~~~~~~~~~~~~~~~
 
 Simplify each RHS, float any let(recs) from the RHSs (if let-floating is

@@ -845,7 +888,7 @@ macro-expansion is:
        letrec
                f = ....g...
                g = ....f...
        letrec
                f = ....g...
                g = ....f...

-       in 
+       in

        ....f...
 
 Here we would like the single call to g to be inlined.
        ....f...
 
 Here we would like the single call to g to be inlined.

@@ -901,12 +944,12 @@ group that are bound to constructors.  For example:
        /= a b    = unpack tuple a, unpack tuple b, call f
     in d.Eq
 
        /= a b    = unpack tuple a, unpack tuple b, call f
     in d.Eq
 

-here, by knowing about d.Eq in f's rhs, one could get rid of 
+here, by knowing about d.Eq in f's rhs, one could get rid of

 the case (and break out the recursion completely).
 the case (and break out the recursion completely).

-[This occurred with more aggressive inlining threshold (4), 
+[This occurred with more aggressive inlining threshold (4),

 nofib/spectral/knights]
 
 nofib/spectral/knights]
 

-How to do it?  
+How to do it?

        1: we simplify constructor rhss first.
        2: we record the "known constructors" in the environment
        3: we simplify the other rhss, with the knowledge about the constructors
        1: we simplify constructor rhss first.
        2: we record the "known constructors" in the environment
        3: we simplify the other rhss, with the knowledge about the constructors

@@ -914,10 +957,10 @@ How to do it?
 
 
 \begin{code}
 
 
 \begin{code}

-simplBind env (CoRec pairs) body_c body_ty
+simplBind env (Rec pairs) body_c body_ty

   =    -- Do floating, if necessary
     (if float_lets || always_float_let_from_let
   =    -- Do floating, if necessary
     (if float_lets || always_float_let_from_let

-     then 
+     then

        mapSmpl float pairs     `thenSmpl` \ floated_pairs_s ->
        returnSmpl (concat floated_pairs_s)
      else
        mapSmpl float pairs     `thenSmpl` \ floated_pairs_s ->
        returnSmpl (concat floated_pairs_s)
      else

@@ -929,14 +972,14 @@ simplBind env (CoRec pairs) body_c body_ty
     cloneIds env binders               `thenSmpl` \ ids' ->
     let
        env_w_clones = extendIdEnvWithClones env binders ids'
     cloneIds env binders               `thenSmpl` \ ids' ->
     let
        env_w_clones = extendIdEnvWithClones env binders ids'

-       triples      = ids' `zip` floated_pairs
+       triples      = zipEqual "simplBind" ids' floated_pairs

     in
 
     simplRecursiveGroup env_w_clones triples   `thenSmpl` \ (binding, new_env) ->
 
     body_c new_env                             `thenSmpl` \ body' ->
 
     in
 
     simplRecursiveGroup env_w_clones triples   `thenSmpl` \ (binding, new_env) ->
 
     body_c new_env                             `thenSmpl` \ body' ->
 

-    returnSmpl (CoLet binding body')
+    returnSmpl (Let binding body')

 
   where
     ------------ Floating stuff -------------------
 
   where
     ------------ Floating stuff -------------------

@@ -973,21 +1016,21 @@ simplBind env (CoRec pairs) body_c body_ty
     float_pair (binder, rhs)
        | always_float_let_from_let ||
          floatExposesHNF True False False rhs
     float_pair (binder, rhs)
        | always_float_let_from_let ||
          floatExposesHNF True False False rhs

-        = (binder,rhs') : pairs'
+       = (binder,rhs') : pairs'

 
        | otherwise
        = [(binder,rhs)]
 
        | otherwise
        = [(binder,rhs)]

-       where 
+       where

          (pairs', rhs') = do_float rhs
 
        -- Float just pulls out any top-level let(rec) bindings
     do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)
          (pairs', rhs') = do_float rhs
 
        -- Float just pulls out any top-level let(rec) bindings
     do_float :: InExpr -> ([(InBinder,InExpr)], InExpr)

-    do_float (CoLet (CoRec pairs) body)     = (float_pairs pairs    ++ pairs', body')
-                                           where
-                                             (pairs', body') = do_float body
-    do_float (CoLet (CoNonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
-                                           where
-                                             (pairs', body') = do_float body
+    do_float (Let (Rec pairs) body)     = (float_pairs pairs    ++ pairs', body')
+                                           where
+                                             (pairs', body') = do_float body
+    do_float (Let (NonRec id rhs) body) = (float_pair (id,rhs) ++ pairs', body')
+                                           where
+                                             (pairs', body') = do_float body

     do_float other                         = ([], other)
 
 simplRecursiveGroup env triples
     do_float other                         = ([], other)
 
 simplRecursiveGroup env triples

@@ -1022,8 +1065,8 @@ simplRecursiveGroup env triples
        (early_triples, late_triples)
          = partition is_early_triple ordinary_triples
 
        (early_triples, late_triples)
          = partition is_early_triple ordinary_triples
 

-       is_early_triple (_, (_, CoCon _ _ _)) = True
-       is_early_triple (i, _               ) = idWantsToBeINLINEd i
+       is_early_triple (_, (_, Con _ _)) = True
+       is_early_triple (i, _           ) = idWantsToBeINLINEd i

     in
        -- Process the early bindings first
     mapSmpl (do_one_binding env_w_inlinings) early_triples     `thenSmpl` \ early_triples' ->
     in
        -- Process the early bindings first
     mapSmpl (do_one_binding env_w_inlinings) early_triples     `thenSmpl` \ early_triples' ->

@@ -1031,20 +1074,20 @@ simplRecursiveGroup env triples
        -- Now further extend the environment to record our knowledge
        -- about the form of the binders bound in the constructor bindings
     let
        -- Now further extend the environment to record our knowledge
        -- about the form of the binders bound in the constructor bindings
     let

-        env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
-        add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'
+       env_w_early_info = foldr add_early_info env_w_inlinings early_triples'
+       add_early_info (binder, (id', rhs')) env = extendUnfoldEnvGivenRhs env binder id' rhs'

     in
        -- Now process the non-constructor bindings
     mapSmpl (do_one_binding env_w_early_info) late_triples     `thenSmpl` \ late_triples' ->
 
        -- Phew! We're done
     let
     in
        -- Now process the non-constructor bindings
     mapSmpl (do_one_binding env_w_early_info) late_triples     `thenSmpl` \ late_triples' ->
 
        -- Phew! We're done
     let

-       binding = CoRec (map snd early_triples' ++ map snd late_triples')
+       binding = Rec (map snd early_triples' ++ map snd late_triples')

     in
     returnSmpl (binding, env_w_early_info)
   where
 
     in
     returnSmpl (binding, env_w_early_info)
   where
 

-    do_one_binding env (id', (binder,rhs)) 
+    do_one_binding env (id', (binder,rhs))

       = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
        returnSmpl (binder, (id', rhs'))
 \end{code}
       = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
        returnSmpl (binder, (id', rhs'))
 \end{code}

@@ -1053,7 +1096,7 @@ simplRecursiveGroup env triples
 @completeLet@ looks at the simplified post-floating RHS of the
 let-expression, and decides what to do.  There's one interesting
 aspect to this, namely constructor reuse.  Consider
 @completeLet@ looks at the simplified post-floating RHS of the
 let-expression, and decides what to do.  There's one interesting
 aspect to this, namely constructor reuse.  Consider

-@      
+@

        f = \x -> case x of
                    (y:ys) -> y:ys
                    []     -> ...
        f = \x -> case x of
                    (y:ys) -> y:ys
                    []     -> ...

@@ -1068,7 +1111,7 @@ const.Int.max.wrk{-s2516-} =
          a.s3299 :: Int
          _N_ {-# U(P) #-}
          a.s3299 = I#! upk.s3297#
          a.s3299 :: Int
          _N_ {-# U(P) #-}
          a.s3299 = I#! upk.s3297#

-       } in 
+       } in

          case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
            _LT -> I#! upk.s3298#
            _EQ -> a.s3299
          case (const.Int._tagCmp.wrk{-s2513-} upk.s3297# upk.s3298#) of {
            _LT -> I#! upk.s3298#
            _EQ -> a.s3299

@@ -1083,8 +1126,8 @@ only do the reverse (turn a constructor application back into a
 variable) when we find a let-expression:
 @
        let x = C a1 .. an
 variable) when we find a let-expression:
 @
        let x = C a1 .. an

-       in 
-       ... (let y = C a1 .. an in ...) ... 
+       in
+       ... (let y = C a1 .. an in ...) ...

 @
 where it is always good to ditch the binding for y, and replace y by
 x.  That's just what completeLetBinding does.
 @
 where it is always good to ditch the binding for y, and replace y by
 x.  That's just what completeLetBinding does.

@@ -1093,14 +1136,12 @@ x.  That's just what completeLetBinding does.
 completeLet
        :: SimplEnv
        -> InBinder
 completeLet
        :: SimplEnv
        -> InBinder

-       -> InExpr               -- Original RHS

        -> OutExpr              -- The simplified RHS
        -> (SimplEnv -> SmplM OutExpr)          -- Body handler
        -> OutExpr              -- The simplified RHS
        -> (SimplEnv -> SmplM OutExpr)          -- Body handler

-       -> OutUniType           -- Type of body
+       -> OutType              -- Type of body

        -> SmplM OutExpr
 
        -> SmplM OutExpr
 

-completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
-
+completeLet env binder new_rhs body_c body_ty

   -- See if RHS is an atom, or a reusable constructor
   | maybeToBool maybe_atomic_rhs
   = let
   -- See if RHS is an atom, or a reusable constructor
   | maybeToBool maybe_atomic_rhs
   = let

@@ -1108,56 +1149,57 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
     in
     tick atom_tick_type                        `thenSmpl_`
     body_c new_env
     in
     tick atom_tick_type                        `thenSmpl_`
     body_c new_env

+  where
+    maybe_atomic_rhs :: Maybe (OutArg, TickType)
+    maybe_atomic_rhs = exprToAtom env new_rhs
+       -- If the RHS is atomic, we return Just (atom, tick type)
+       -- otherwise Nothing
+    Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs

 
 

+completeLet env binder@(id,_) new_rhs body_c body_ty

   -- Maybe the rhs is an application of error, and sure to be demanded
   -- Maybe the rhs is an application of error, and sure to be demanded

-  | will_be_demanded && 
+  | will_be_demanded &&

     maybeToBool maybe_error_app
   = tick CaseOfError                   `thenSmpl_`
     returnSmpl retyped_error_app
     maybeToBool maybe_error_app
   = tick CaseOfError                   `thenSmpl_`
     returnSmpl retyped_error_app

+  where
+    will_be_demanded      = willBeDemanded (getIdDemandInfo id)
+    maybe_error_app        = maybeErrorApp new_rhs (Just body_ty)
+    Just retyped_error_app = maybe_error_app

 
 

+{-
+completeLet env binder (Coerce coercion ty rhs) body_c body_ty
+   -- Rhs is a coercion
+   | maybeToBool maybe_atomic_coerce_rhs
+   = tick tick_type            `thenSmpl_`
+     complete_coerce env rhs_atom rhs
+   where
+     maybe_atomic_coerce_rhs    = exprToAtom env rhs
+     Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
+
+         returnSmpl (CoerceForm coercion rhs_atom, env)
+       Nothing
+         newId (coreExprType rhs)      `thenSmpl` \ inner_id ->
+         
+     complete_coerce env atom rhs
+       = cloneId env binder                    `thenSmpl` \ id' ->
+        let
+           env1    = extendIdEnvWithClone env binder id'
+           new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
+        in
+        body_c new_env                 `thenSmpl` \ body' ->
+        returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
+-}   
+
+completeLet env binder new_rhs body_c body_ty

   -- The general case
   -- The general case

-  | otherwise

   = cloneId env binder                 `thenSmpl` \ id' ->
     let
        env1    = extendIdEnvWithClone env binder id'
   = cloneId env binder                 `thenSmpl` \ id' ->
     let
        env1    = extendIdEnvWithClone env binder id'

-       new_env = _scc_ "euegR2" (extendUnfoldEnvGivenRhs env1 binder id' new_rhs)
+       new_env = extendUnfoldEnvGivenRhs env1 binder id' new_rhs

     in
     body_c new_env                     `thenSmpl` \ body' ->
     in
     body_c new_env                     `thenSmpl` \ body' ->

-    returnSmpl (CoLet (CoNonRec id' new_rhs) body')
-
-  where
-    will_be_demanded = willBeDemanded (getIdDemandInfo id)
-    try_to_reuse_constr   = switchIsSet env SimplReuseCon
-
-    Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-
-    maybe_atomic_rhs :: Maybe (OutAtom, TickType)
-       -- If the RHS is atomic, we return Just (atom, tick type)
-       -- otherwise Nothing
-
-    maybe_atomic_rhs
-      = case new_rhs of
-         CoVar var -> Just (CoVarAtom var, AtomicRhs)
-
-         CoLit lit | not (isNoRepLit lit) 
-           -> Just (CoLitAtom lit, AtomicRhs)
-
-         CoCon con tys con_args
-           | try_to_reuse_constr 
-                  -- Look out for
-                  --   let v = C args
-                  --   in 
-                  --- ...(let w = C same-args in ...)...
-                  -- Then use v instead of w.   This may save
-                  -- re-constructing an existing constructor.
-            -> case lookForConstructor env con tys con_args of
-                 Nothing  -> Nothing
-                 Just var -> Just (CoVarAtom var, ConReused)
-
-         other -> Nothing
-
-    maybe_error_app        = maybeErrorApp new_rhs (Just body_ty)
-    Just retyped_error_app = maybe_error_app
+    returnSmpl (Let (NonRec id' new_rhs) body')

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -1167,23 +1209,48 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-simplAtom :: SimplEnv -> InAtom -> OutAtom
+simplArg :: SimplEnv -> InArg -> OutArg

 
 

-simplAtom env (CoLitAtom lit) = CoLitAtom lit
+simplArg env (LitArg lit) = LitArg lit
+simplArg env (TyArg  ty)  = TyArg  (simplTy env ty)

 
 

-simplAtom env (CoVarAtom id)
+simplArg env (VarArg id)

   | isLocallyDefined id
   = case lookupId env id of
        Just (ItsAnAtom atom) -> atom
   | isLocallyDefined id
   = case lookupId env id of
        Just (ItsAnAtom atom) -> atom

-       Just (InlineIt _ _ _) -> pprPanic "simplAtom InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
-       Nothing               -> CoVarAtom id   -- Must be an uncloned thing
+       Just (InlineIt _ _ _) -> pprPanic "simplArg InLineIt:" (ppAbove (ppr PprDebug id) (pprSimplEnv env))
+       Nothing               -> VarArg id      -- Must be an uncloned thing

 
   | otherwise
   =    -- Not locally defined, so no change
 
   | otherwise
   =    -- Not locally defined, so no change

-    CoVarAtom id
+    VarArg id

 \end{code}
 
 
 \end{code}
 
 

+\begin{code}
+exprToAtom env (Var var) 
+  = Just (VarArg var, AtomicRhs)
+
+exprToAtom env (Lit lit) 
+  | not (isNoRepLit lit)
+  = Just (LitArg lit, AtomicRhs)
+
+exprToAtom env (Con con con_args)
+  | switchIsSet env SimplReuseCon
+  -- Look out for
+  --   let v = C args
+  --   in
+  --- ...(let w = C same-args in ...)...
+  -- Then use v instead of w.   This may save
+  -- re-constructing an existing constructor.
+  = case (lookForConstructor env con con_args) of
+                 Nothing  -> Nothing
+                 Just var -> Just (VarArg var, ConReused)
+
+exprToAtom env other
+  = Nothing
+\end{code}
+

 %************************************************************************
 %*                                                                     *
 \subsection[Simplify-quickies]{Some local help functions}
 %************************************************************************
 %*                                                                     *
 \subsection[Simplify-quickies]{Some local help functions}

@@ -1194,29 +1261,29 @@ simplAtom env (CoVarAtom id)
 \begin{code}
 -- fix_up_demandedness switches off the willBeDemanded Info field
 -- for bindings floated out of a non-demanded let
 \begin{code}
 -- fix_up_demandedness switches off the willBeDemanded Info field
 -- for bindings floated out of a non-demanded let

-fix_up_demandedness True {- Will be demanded -} bind 
+fix_up_demandedness True {- Will be demanded -} bind

    = bind      -- Simple; no change to demand info needed
    = bind      -- Simple; no change to demand info needed

-fix_up_demandedness False {- May not be demanded -} (CoNonRec binder rhs)
-   = CoNonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (CoRec pairs)
-   = CoRec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
+fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
+   = NonRec (un_demandify binder) rhs
+fix_up_demandedness False {- May not be demanded -} (Rec pairs)
+   = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]

 
 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
 
 
 un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
 

-is_cheap_prim_app (CoPrim op tys args) = primOpOkForSpeculation op
-is_cheap_prim_app other                       = False
+is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
+is_cheap_prim_app other              = False

 
 

-computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutUniType
+computeResultType :: SimplEnv -> InExpr -> [OutArg] -> OutType

 computeResultType env expr args
 computeResultType env expr args

-  = do expr_ty' args
+  = go expr_ty' args

   where
   where

-    expr_ty  = typeOfCoreExpr (unTagBinders expr)
+    expr_ty  = coreExprType (unTagBinders expr)

     expr_ty' = simplTy env expr_ty
 
     expr_ty' = simplTy env expr_ty
 

-    do ty [] = ty
-    do ty (TypeArg ty_arg : args) = do (applyTy ty ty_arg) args
-    do ty (ValArg a       : args) = case maybeUnpackFunTy ty of
-                                     Just (_, res_ty) -> do res_ty args
-                                     Nothing          -> panic "computeResultType"
+    go ty [] = ty
+    go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
+    go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
+                                   Just (_, res_ty) -> go res_ty args
+                                   Nothing          -> panic "computeResultType"

 \end{code}
 
 \end{code}