[project @ 2000-11-21 16:42:58 by simonmar]

[ghc-hetmet.git] / ghc / compiler / stgSyn / CoreToStg.lhs

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 5e8bfa7..dca4edb 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -10,37 +10,37 @@
 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
 
 \begin{code}
 Convert a @CoreSyntax@ program to a @StgSyntax@ program.
 
 \begin{code}

-module CoreToStg ( topCoreBindsToStg ) where
+module CoreToStg ( topCoreBindsToStg, coreToStgExpr ) where

 
 #include "HsVersions.h"
 
 import CoreSyn         -- input
 import StgSyn          -- output
 
 
 #include "HsVersions.h"
 
 import CoreSyn         -- input
 import StgSyn          -- output
 

-import CoreUtils       ( coreExprType )
+import CoreUtils       ( exprType )

 import SimplUtils      ( findDefault )
 import CostCentre      ( noCCS )
 import SimplUtils      ( findDefault )
 import CostCentre      ( noCCS )

-import Id              ( Id, mkSysLocal, idType, getIdStrictness, idUnique, isExportedId, mkVanillaId,
-                         externallyVisibleId, setIdUnique, idName, getIdDemandInfo, setIdType
+import Id              ( Id, mkSysLocal, idType, idStrictness, isExportedId, 
+                         mkVanillaId, idName, idDemandInfo, idArity, setIdType,
+                         idFlavour

                        )
                        )

-import Var             ( Var, varType, modifyIdInfo )
-import IdInfo          ( setDemandInfo, StrictnessInfo(..), zapIdInfoForStg )
-import UsageSPUtils     ( primOpUsgTys )
-import DataCon         ( DataCon, dataConName, dataConId )
-import Demand          ( Demand, isStrict, wwStrict, wwLazy )
-import Name            ( Name, nameModule, isLocallyDefinedName, setNameUnique )
-import Module          ( isDynamicModule )
-import Const           ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFCon )
+import IdInfo          ( StrictnessInfo(..), IdFlavour(..) )
+import DataCon         ( dataConWrapId, dataConTyCon )
+import TyCon           ( isAlgTyCon )
+import Demand          ( Demand, isStrict, wwLazy )
+import Name            ( setNameUnique )

 import VarEnv
 import VarEnv

-import PrimOp          ( PrimOp(..), primOpUsg, primOpSig )
+import PrimOp          ( PrimOp(..), setCCallUnique )

 import Type            ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
 import Type            ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,

-                          UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType, seqType )
-import TysPrim         ( intPrimTy )
+                          applyTy, repType, seqType, splitTyConApp_maybe, splitTyConApp,
+                         splitRepFunTys, mkFunTys,
+                          uaUTy, usOnce, usMany, isTyVarTy
+                       )

 import UniqSupply      -- all of it, really
 import UniqSupply      -- all of it, really

-import Util            ( lengthExceeds )

 import BasicTypes      ( TopLevelFlag(..), isNotTopLevel )
 import BasicTypes      ( TopLevelFlag(..), isNotTopLevel )

-import CmdLineOpts     ( opt_D_verbose_stg2stg, opt_UsageSPOn )

 import UniqSet         ( emptyUniqSet )
 import UniqSet         ( emptyUniqSet )

+import ErrUtils                ( showPass, dumpIfSet_dyn )
+import CmdLineOpts     ( DynFlags, DynFlag(..) )

 import Maybes
 import Outputable
 \end{code}
 import Maybes
 import Outputable
 \end{code}

@@ -148,13 +148,15 @@ isOnceTy ty
 #ifdef USMANY
     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 #endif
 #ifdef USMANY
     opt_UsageSPOn &&  -- can't expect annotations if -fusagesp is off
 #endif

-    case tyUsg ty of
-      UsOnce   -> True
-      UsMany   -> False
-      UsVar uv -> pprPanic "CoreToStg: unexpected uvar annot:" (ppr uv)
+    once
+  where
+    u = uaUTy ty
+    once | u == usOnce  = True
+         | u == usMany  = False
+         | isTyVarTy u  = False  -- if unknown at compile-time, is Top ie usMany

 
 bdrDem :: Id -> RhsDemand
 
 bdrDem :: Id -> RhsDemand

-bdrDem id = mkDem (getIdDemandInfo id) (isOnceTy (idType id))
+bdrDem id = mkDem (idDemandInfo id) (isOnceTy (idType id))

 
 safeDem, onceDem :: RhsDemand
 safeDem = RhsDemand False False  -- always safe to use this
 
 safeDem, onceDem :: RhsDemand
 safeDem = RhsDemand False False  -- always safe to use this

@@ -170,21 +172,18 @@ locations.
 
 \begin{code}
 bOGUS_LVs :: StgLiveVars
 
 \begin{code}
 bOGUS_LVs :: StgLiveVars

-bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
-         | otherwise =panic "bOGUS_LVs"
+bOGUS_LVs = emptyUniqSet

 
 bOGUS_FVs :: [Id]
 
 bOGUS_FVs :: [Id]

-bOGUS_FVs | opt_D_verbose_stg2stg = [] 
-         | otherwise = panic "bOGUS_FVs"
+bOGUS_FVs = [] 

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-topCoreBindsToStg :: UniqSupply        -- name supply
-                 -> [CoreBind] -- input
-                 -> [StgBinding]       -- output
-
-topCoreBindsToStg us core_binds
-  = initUs_ us (coreBindsToStg emptyVarEnv core_binds)
+topCoreBindsToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
+topCoreBindsToStg dflags core_binds
+  = do showPass dflags "Core2Stg"
+       us <- mkSplitUniqSupply 'c'
+       return (initUs_ us (coreBindsToStg emptyVarEnv core_binds))

   where
     coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
 
   where
     coreBindsToStg :: StgEnv -> [CoreBind] -> UniqSM [StgBinding]
 

@@ -210,6 +209,21 @@ topCoreBindsToStg us core_binds
                      returnUs new_bs
 \end{code}
 
                      returnUs new_bs
 \end{code}
 

+%************************************************************************
+%*                                                                     *
+\subsection[coreToStgExpr]{Converting an expression (for the interpreter)}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+coreToStgExpr :: DynFlags -> CoreExpr -> IO StgExpr
+coreToStgExpr dflags core_expr
+  = do showPass dflags "Core2Stg"
+       us <- mkSplitUniqSupply 'c'
+       let stg_expr = initUs_ us (coreExprToStg emptyVarEnv core_expr)
+       dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" (ppr stg_expr)
+       return stg_expr
+\end{code}

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

@@ -221,7 +235,7 @@ topCoreBindsToStg us core_binds
 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
 
 coreBindToStg top_lev env (NonRec binder rhs)
 coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
 
 coreBindToStg top_lev env (NonRec binder rhs)

-  = coreExprToStgFloat env rhs dem                     `thenUs` \ (floats, stg_rhs) ->
+  = coreExprToStgFloat env rhs                 `thenUs` \ (floats, stg_rhs) ->

     case (floats, stg_rhs) of
        ([], StgApp var []) | not (isExportedId binder)
                     -> returnUs (NoBindF, extendVarEnv env binder var)
     case (floats, stg_rhs) of
        ([], StgApp var []) | not (isExportedId binder)
                     -> returnUs (NoBindF, extendVarEnv env binder var)

@@ -236,18 +250,17 @@ coreBindToStg top_lev env (NonRec binder rhs)
   where
     dem = bdrDem binder
 
   where
     dem = bdrDem binder
 

+

 coreBindToStg top_lev env (Rec pairs)
   = newLocalIds top_lev env binders    `thenUs` \ (env', binders') ->
     mapUs (do_rhs env') pairs          `thenUs` \ stg_rhss ->
     returnUs (RecF (binders' `zip` stg_rhss), env')
   where
     binders = map fst pairs
 coreBindToStg top_lev env (Rec pairs)
   = newLocalIds top_lev env binders    `thenUs` \ (env', binders') ->
     mapUs (do_rhs env') pairs          `thenUs` \ stg_rhss ->
     returnUs (RecF (binders' `zip` stg_rhss), env')
   where
     binders = map fst pairs

-    do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem     `thenUs` \ (floats, stg_expr) ->
+    do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs         `thenUs` \ (floats, stg_expr) ->

                            mkStgBinds floats stg_expr          `thenUs` \ stg_expr' ->
                                -- NB: stg_expr' might still be a StgLam (and we want that)
                            mkStgBinds floats stg_expr          `thenUs` \ stg_expr' ->
                                -- NB: stg_expr' might still be a StgLam (and we want that)

-                           returnUs (exprToRhs dem top_lev stg_expr')
-                         where
-                           dem = bdrDem bndr
+                           returnUs (exprToRhs (bdrDem bndr) top_lev stg_expr')

 \end{code}
 
 
 \end{code}
 
 

@@ -273,8 +286,8 @@ exprToRhs dem _ (StgLam _ bndrs body)
   We reject the following candidates for 'static constructor'dom:
   
     - any dcon that takes a lit-lit as an arg.
   We reject the following candidates for 'static constructor'dom:
   
     - any dcon that takes a lit-lit as an arg.

-    - [Win32 DLLs only]: any dcon that is (or takes as arg)
-      that's living in a DLL.
+    - [Win32 DLLs only]: any dcon that resides in a DLL
+      (or takes as arg something that is.)

 
   These constraints are necessary to ensure that the code
   generated in the end for the static constructors, which
 
   These constraints are necessary to ensure that the code
   generated in the end for the static constructors, which

@@ -299,20 +312,12 @@ exprToRhs dem _ (StgLam _ bndrs body)
   constructors (ala C++ static class constructors) which will
   then be run at load time to fix up static closures.
 -}
   constructors (ala C++ static class constructors) which will
   then be run at load time to fix up static closures.
 -}

-exprToRhs dem toplev (StgCon (DataCon con) args _)
-  | isNotTopLevel toplev ||
-    (not is_dynamic  &&
-     all  (not.is_lit_lit) args)  = StgRhsCon noCCS con args
- where
-  is_dynamic = isDynCon con || any (isDynArg) args
-
-  is_lit_lit (StgVarArg _) = False
-  is_lit_lit (StgConArg x) =
-     case x of
-       Literal l -> isLitLitLit l
-       _         -> False
-
-exprToRhs dem _ expr
+exprToRhs dem toplev (StgConApp con args)
+  | isNotTopLevel toplev || not (isDllConApp con args)
+       -- isDllConApp checks for LitLit args too
+  = StgRhsCon noCCS con args
+
+exprToRhs dem toplev expr

   = upd `seq` 
     StgRhsClosure      noCCS           -- No cost centre (ToDo?)
                        stgArgOcc       -- safe
   = upd `seq` 
     StgRhsClosure      noCCS           -- No cost centre (ToDo?)
                        stgArgOcc       -- safe

@@ -322,24 +327,22 @@ exprToRhs dem _ expr
                        []
                        expr
   where
                        []
                        expr
   where

-    upd = if isOnceDem dem then SingleEntry else Updatable
-                               -- HA!  Paydirt for "dem"
-
-isDynCon :: DataCon -> Bool
-isDynCon con = isDynName (dataConName con)
-
-isDynArg :: StgArg -> Bool
-isDynArg (StgVarArg v)   = isDynName (idName v)
-isDynArg (StgConArg con) =
-  case con of
-    DataCon dc -> isDynCon dc
-    Literal l  -> isLitLitLit l
-    _          -> False
-
-isDynName :: Name -> Bool
-isDynName nm = 
-      not (isLocallyDefinedName nm) && 
-      isDynamicModule (nameModule nm)
+    upd = if isOnceDem dem
+          then (if isNotTopLevel toplev 
+                then SingleEntry              -- HA!  Paydirt for "dem"
+                else 
+#ifdef DEBUG
+                     trace "WARNING: SE CAFs unsupported, forcing UPD instead" $
+#endif
+                     Updatable)
+          else Updatable
+        -- For now we forbid SingleEntry CAFs; they tickle the
+        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+        -- and I don't understand why.  There's only one SE_CAF (well,
+        -- only one that tickled a great gaping bug in an earlier attempt
+        -- at ClosureInfo.getEntryConvention) in the whole of nofib, 
+        -- specifically Main.lvl6 in spectral/cryptarithm2.
+        -- So no great loss.  KSW 2000-07.

 \end{code}
 
 
 \end{code}
 
 

@@ -366,14 +369,19 @@ coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg)
 -- This is where we arrange that a non-trivial argument is let-bound
 
 coreArgToStg env (arg,dem)
 -- This is where we arrange that a non-trivial argument is let-bound
 
 coreArgToStg env (arg,dem)

-  = coreExprToStgFloat env arg dem             `thenUs` \ (floats, arg') ->
+  = coreExprToStgFloat env arg         `thenUs` \ (floats, arg') ->

     case arg' of
     case arg' of

-       StgCon con [] _ -> returnUs (floats, StgConArg con)
-       StgApp v []     -> returnUs (floats, StgVarArg v)
-       other           -> newStgVar arg_ty     `thenUs` \ v ->
-                          returnUs ([NonRecF v arg' dem floats], StgVarArg v)
+       StgApp v []      -> returnUs (floats, StgVarArg v)
+       StgLit lit       -> returnUs (floats, StgLitArg lit)
+
+       StgConApp con [] -> returnUs (floats, StgVarArg (dataConWrapId con))
+               -- A nullary constructor can be replaced with
+               -- a ``call'' to its wrapper
+
+       other            -> newStgVar arg_ty    `thenUs` \ v ->
+                           returnUs ([NonRecF v arg' dem floats], StgVarArg v)

   where
   where

-    arg_ty = coreExprType arg
+    arg_ty = exprType arg

 \end{code}
 
 
 \end{code}
 
 

@@ -384,9 +392,9 @@ coreArgToStg env (arg,dem)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
-coreExprToStg env expr dem
-  = coreExprToStgFloat env expr dem    `thenUs` \ (binds,stg_expr) ->
+coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
+coreExprToStg env expr
+  = coreExprToStgFloat env expr        `thenUs` \ (binds,stg_expr) ->

     mkStgBinds binds stg_expr          `thenUs` \ stg_expr' ->
     deStgLam stg_expr'
 \end{code}
     mkStgBinds binds stg_expr          `thenUs` \ stg_expr' ->
     deStgLam stg_expr'
 \end{code}

@@ -399,41 +407,40 @@ coreExprToStg env expr dem
 
 \begin{code}
 coreExprToStgFloat :: StgEnv -> CoreExpr 
 
 \begin{code}
 coreExprToStgFloat :: StgEnv -> CoreExpr 

-                  -> RhsDemand

                   -> UniqSM ([StgFloatBind], StgExpr)
                   -> UniqSM ([StgFloatBind], StgExpr)

--- Transform an expression to STG. The demand on the expression is
--- given by RhsDemand, and is solely used ot figure out the usage
--- of constructor args: if the constructor is used once, then so are
--- its arguments.  The strictness info in RhsDemand isn't used.
-
--- The StgExpr returned *can* be an StgLam
+-- Transform an expression to STG.  The 'floats' are
+-- any bindings we had to create for function arguments.

 \end{code}
 
 Simple cases first
 
 \begin{code}
 \end{code}
 
 Simple cases first
 
 \begin{code}

-coreExprToStgFloat env (Var var) dem
-  = returnUs ([], mkStgApp (stgLookup env var) [])
+coreExprToStgFloat env (Var var)
+  = mkStgApp env var [] (idType var)   `thenUs` \ app -> 
+    returnUs ([], app)
+
+coreExprToStgFloat env (Lit lit)
+  = returnUs ([], StgLit lit)

 
 

-coreExprToStgFloat env (Let bind body) dem
+coreExprToStgFloat env (Let bind body)

   = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->
   = coreBindToStg NotTopLevel env bind `thenUs` \ (new_bind, new_env) ->

-    coreExprToStgFloat new_env body dem        `thenUs` \ (floats, stg_body) ->
+    coreExprToStgFloat new_env body    `thenUs` \ (floats, stg_body) ->

     returnUs (new_bind:floats, stg_body)
 \end{code}
 
 Convert core @scc@ expression directly to STG @scc@ expression.
 
 \begin{code}
     returnUs (new_bind:floats, stg_body)
 \end{code}
 
 Convert core @scc@ expression directly to STG @scc@ expression.
 
 \begin{code}

-coreExprToStgFloat env (Note (SCC cc) expr) dem
-  = coreExprToStg env expr dem  `thenUs` \ stg_expr ->
+coreExprToStgFloat env (Note (SCC cc) expr)
+  = coreExprToStg env expr     `thenUs` \ stg_expr ->

     returnUs ([], StgSCC cc stg_expr)
 
     returnUs ([], StgSCC cc stg_expr)
 

-coreExprToStgFloat env (Note other_note expr) dem
-  = coreExprToStgFloat env expr dem
+coreExprToStgFloat env (Note other_note expr)
+  = coreExprToStgFloat env expr

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-coreExprToStgFloat env expr@(Type _) dem
+coreExprToStgFloat env expr@(Type _)

   = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
 \end{code}
 
   = pprPanic "coreExprToStgFloat: tyarg unexpected:" $ ppr expr
 \end{code}
 

@@ -445,20 +452,18 @@ coreExprToStgFloat env expr@(Type _) dem
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-coreExprToStgFloat env expr@(Lam _ _) dem
+coreExprToStgFloat env expr@(Lam _ _)

   = let
   = let

-       expr_ty         = coreExprType expr
+       expr_ty         = exprType expr

        (binders, body) = collectBinders expr
        id_binders      = filter isId binders
        (binders, body) = collectBinders expr
        id_binders      = filter isId binders

-        body_dem        = trace "coreExprToStg: approximating body_dem in Lam"
-                          safeDem

     in
     in

-    if null id_binders then    -- It was all type/usage binders; tossed
-       coreExprToStgFloat env body dem
+    if null id_binders then    -- It was all type binders; tossed
+       coreExprToStgFloat env body

     else
        -- At least some value binders
     newLocalIds NotTopLevel env id_binders     `thenUs` \ (env', binders') ->
     else
        -- At least some value binders
     newLocalIds NotTopLevel env id_binders     `thenUs` \ (env', binders') ->

-    coreExprToStgFloat env' body body_dem      `thenUs` \ (floats, stg_body) ->
+    coreExprToStgFloat env' body               `thenUs` \ (floats, stg_body) ->

     mkStgBinds floats stg_body                 `thenUs` \ stg_body' ->
 
     case stg_body' of
     mkStgBinds floats stg_body                 `thenUs` \ stg_body' ->
 
     case stg_body' of

@@ -479,9 +484,9 @@ coreExprToStgFloat env expr@(Lam _ _) dem
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-coreExprToStgFloat env expr@(App _ _) dem
+coreExprToStgFloat env expr@(App _ _)

   = let
   = let

-        (fun,rads,_,ss)       = collect_args expr
+        (fun,rads,ty,ss)      = collect_args expr

         ads                   = reverse rads
        final_ads | null ss   = ads
                  | otherwise = zap ads -- Too few args to satisfy strictness info
         ads                   = reverse rads
        final_ads | null ss   = ads
                  | otherwise = zap ads -- Too few args to satisfy strictness info

@@ -494,20 +499,21 @@ coreExprToStgFloat env expr@(App _ _) dem
 
        -- Now deal with the function
     case (fun, stg_args) of
 
        -- Now deal with the function
     case (fun, stg_args) of

-      (Var fun_id, _) ->       -- A function Id, so do an StgApp; it's ok if
+      (Var fn_id, _) ->        -- A function Id, so do an StgApp; it's ok if

                                -- there are no arguments.
                                -- there are no arguments.

-                           returnUs (arg_floats, 
-                                     mkStgApp (stgLookup env fun_id) stg_args)
+                           mkStgApp env fn_id stg_args ty      `thenUs` \ app -> 
+                           returnUs (arg_floats, app)

 
       (non_var_fun, []) ->     -- No value args, so recurse into the function
                            ASSERT( null arg_floats )
 
       (non_var_fun, []) ->     -- No value args, so recurse into the function
                            ASSERT( null arg_floats )

-                           coreExprToStgFloat env non_var_fun dem
+                           coreExprToStgFloat env non_var_fun

 
       other -> -- A non-variable applied to things; better let-bind it.
 
       other -> -- A non-variable applied to things; better let-bind it.

-               newStgVar (coreExprType fun)            `thenUs` \ fun_id ->
-                coreExprToStgFloat env fun onceDem     `thenUs` \ (fun_floats, stg_fun) ->
-               returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
-                         mkStgApp fun_id stg_args)
+               newStgVar (exprType fun)                `thenUs` \ fn_id ->
+                coreExprToStgFloat env fun             `thenUs` \ (fun_floats, stg_fun) ->
+               mkStgApp env fn_id stg_args ty          `thenUs` \ app -> 
+               returnUs (NonRecF fn_id stg_fun onceDem fun_floats : arg_floats,
+                         app)

 
   where
        -- Collect arguments and demands (*in reverse order*)
 
   where
        -- Collect arguments and demands (*in reverse order*)

@@ -523,7 +529,6 @@ coreExprToStgFloat env expr@(App _ _) dem
     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
                                           in  (the_fun,ads,ty,ss)
     collect_args (Note InlineCall    e) = collect_args e
     collect_args (Note (Coerce ty _) e) = let (the_fun,ads,_,ss) = collect_args e
                                           in  (the_fun,ads,ty,ss)
     collect_args (Note InlineCall    e) = collect_args e

-    collect_args (Note (TermUsg _)   e) = collect_args e

 
     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
                                           in  (the_fun,ads,applyTy fun_ty tyarg,ss)
 
     collect_args (App fun (Type tyarg)) = let (the_fun,ads,fun_ty,ss) = collect_args fun
                                           in  (the_fun,ads,applyTy fun_ty tyarg,ss)

@@ -540,65 +545,16 @@ coreExprToStgFloat env expr@(App _ _) dem
     collect_args (Var v)
        = (Var v, [], idType v, stricts)
        where
     collect_args (Var v)
        = (Var v, [], idType v, stricts)
        where

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

                        StrictnessInfo demands _ -> demands
                        other                    -> repeat wwLazy
 
                        StrictnessInfo demands _ -> demands
                        other                    -> repeat wwLazy
 

-    collect_args fun = (fun, [], coreExprType fun, repeat wwLazy)
+    collect_args fun = (fun, [], exprType fun, repeat wwLazy)

 
     -- "zap" nukes the strictness info for a partial application 
     zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
 \end{code}
 
 
     -- "zap" nukes the strictness info for a partial application 
     zap ads = [(arg, RhsDemand False once) | (arg, RhsDemand _ once) <- ads]
 \end{code}
 

-%************************************************************************
-%*                                                                     *
-\subsubsection[coreToStg-con]{Constructors and primops}
-%*                                                                     *
-%************************************************************************
-
-For data constructors, the demand on an argument is the demand on the
-constructor as a whole (see module UsageSPInf).  For primops, the
-demand is derived from the type of the primop.
-
-If usage inference is off, we simply make all bindings updatable for
-speed.
-
-\begin{code}
-coreExprToStgFloat env expr@(Con con args) dem
-  = let 
-       expr_ty     = coreExprType expr
-        (stricts,_) = conStrictness con
-        onces = case con of
-                    DEFAULT   -> panic "coreExprToStgFloat: DEFAULT"
-                
-                    Literal _ -> ASSERT( null args' {-'cpp-} ) []
-                
-                    DataCon c -> repeat (isOnceDem dem)
-                                       -- HA!  This is the sole reason we propagate
-                                       -- dem all the way down 
-                
-                    PrimOp  p -> let tyargs      = map (\ (Type ty) -> ty) $
-                                                       takeWhile isTypeArg args
-                                     (arg_tys,_) = primOpUsgTys p tyargs
-                                 in  ASSERT( length arg_tys == length args' {-'cpp-} )
-                                     -- primops always fully applied, so == not >=
-                                     map isOnceTy arg_tys
-
-       dems' = zipWith mkDem stricts onces
-        args' = filter isValArg args
-    in
-    coreArgsToStg env (zip args' dems')                  `thenUs` \ (arg_floats, stg_atoms) ->
-
-       -- YUK YUK: must unique if present
-    (case con of
-       PrimOp (CCallOp (Right _) a b c) -> getUniqueUs   `thenUs` \ u ->
-                                           returnUs (PrimOp (CCallOp (Right u) a b c))
-       _                                -> returnUs con
-    )                                                     `thenUs` \ con' ->
-
-    returnUs (arg_floats, mkStgCon con' stg_atoms expr_ty)
-\end{code}
-

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

@@ -606,78 +562,13 @@ coreExprToStgFloat env expr@(Con con args) dem
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-First, two special cases.  We mangle cases involving 
-               par# and seq#
-inthe scrutinee.
-
-Up to this point, seq# will appear like this:
-
-         case seq# e of
-               0# -> seqError#
-               _  -> <stuff>
-
-This code comes from an unfolding for 'seq' in Prelude.hs.
-The 0# branch is purely to bamboozle the strictness analyser.
-For example, if <stuff> is strict in x, and there was no seqError#
-branch, the strictness analyser would conclude that the whole expression
-was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
-
-Now that the evaluation order is safe, we translate this into
-
-         case e of
-               _ -> ...
-
-This used to be done in the post-simplification phase, but we need
-unfoldings involving seq# to appear unmangled in the interface file,
-hence we do this mangling here.
-
-Similarly, par# has an unfolding in PrelConc.lhs that makes it show
-up like this:
-
-       case par# e of
-         0# -> rhs
-         _  -> parError#
-
-
-    ==>
-       case par# e of
-         _ -> rhs
-
-fork# isn't handled like this - it's an explicit IO operation now.
-The reason is that fork# returns a ThreadId#, which gets in the
-way of the above scheme.  And anyway, IO is the only guaranteed
-way to enforce ordering  --SDM.
-
-
-\begin{code}
-coreExprToStgFloat env 
-       (Case scrut@(Con (PrimOp SeqOp) [Type ty, e]) bndr alts) dem
-  = coreExprToStgFloat env (Case e new_bndr [(DEFAULT,[],default_rhs)]) dem
-  where 
-    new_bndr                   = setIdType bndr ty
-    (other_alts, maybe_default) = findDefault alts
-    Just default_rhs           = maybe_default
-
-coreExprToStgFloat env 
-       (Case scrut@(Con (PrimOp ParOp) args) bndr alts) dem
-  | maybeToBool maybe_default
-  = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
-    newEvaldLocalId env bndr                   `thenUs` \ (env', bndr') ->
-    coreExprToStg env' default_rhs dem                 `thenUs` \ default_rhs' ->
-    returnUs (binds, mkStgCase scrut' bndr' (StgPrimAlts (idType bndr') [] (StgBindDefault default_rhs')))
-  where
-    (other_alts, maybe_default) = findDefault alts
-    Just default_rhs           = maybe_default
-\end{code}
-
-Now for normal case expressions...
-

 \begin{code}
 \begin{code}

-coreExprToStgFloat env (Case scrut bndr alts) dem
-  = coreExprToStgFloat env scrut (bdrDem bndr) `thenUs` \ (binds, scrut') ->
-    newEvaldLocalId env bndr                   `thenUs` \ (env', bndr') ->
+coreExprToStgFloat env (Case scrut bndr alts)
+  = coreExprToStgFloat env scrut               `thenUs` \ (binds, scrut') ->
+    newLocalId NotTopLevel env bndr            `thenUs` \ (env', bndr') ->

     alts_to_stg env' (findDefault alts)                `thenUs` \ alts' ->
     alts_to_stg env' (findDefault alts)                `thenUs` \ alts' ->

-    returnUs (binds, mkStgCase scrut' bndr' alts')
+    mkStgCase scrut' bndr' alts'               `thenUs` \ expr' ->
+    returnUs (binds, expr')

   where
     scrut_ty  = idType bndr
     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)
   where
     scrut_ty  = idType bndr
     prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty)

@@ -693,26 +584,24 @@ coreExprToStgFloat env (Case scrut bndr alts) dem
        mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
        returnUs (mkStgAlgAlts scrut_ty alts' deflt')
 
        mapUs (alg_alt_to_stg env) alts         `thenUs` \ alts' ->
        returnUs (mkStgAlgAlts scrut_ty alts' deflt')
 

-    alg_alt_to_stg env (DataCon con, bs, rhs)
+    alg_alt_to_stg env (DataAlt con, bs, rhs)

          = newLocalIds NotTopLevel env (filter isId bs)        `thenUs` \ (env', stg_bs) -> 
          = newLocalIds NotTopLevel env (filter isId bs)        `thenUs` \ (env', stg_bs) -> 

-           coreExprToStg env' rhs dem                          `thenUs` \ stg_rhs ->
+           coreExprToStg env' rhs                              `thenUs` \ stg_rhs ->

            returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
                -- NB the filter isId.  Some of the binders may be
                -- existential type variables, which STG doesn't care about
 
            returnUs (con, stg_bs, [ True | b <- stg_bs ]{-bogus use mask-}, stg_rhs)
                -- NB the filter isId.  Some of the binders may be
                -- existential type variables, which STG doesn't care about
 

-    prim_alt_to_stg env (Literal lit, args, rhs)
+    prim_alt_to_stg env (LitAlt lit, args, rhs)

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

-           coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
+           coreExprToStg env rhs       `thenUs` \ stg_rhs ->

            returnUs (lit, stg_rhs)
 
     default_to_stg env Nothing
       = returnUs StgNoDefault
 
     default_to_stg env (Just rhs)
            returnUs (lit, stg_rhs)
 
     default_to_stg env Nothing
       = returnUs StgNoDefault
 
     default_to_stg env (Just rhs)

-      = coreExprToStg env rhs dem   `thenUs` \ stg_rhs ->
+      = coreExprToStg env rhs  `thenUs` \ stg_rhs ->

        returnUs (StgBindDefault stg_rhs)
        returnUs (StgBindDefault stg_rhs)

-               -- The binder is used for prim cases and not otherwise
-               -- (hack for old code gen)

 \end{code}
 
 
 \end{code}
 
 

@@ -725,13 +614,6 @@ coreExprToStgFloat env (Case scrut bndr alts) dem
 There's not anything interesting we can ASSERT about \tr{var} if it
 isn't in the StgEnv. (WDP 94/06)
 
 There's not anything interesting we can ASSERT about \tr{var} if it
 isn't in the StgEnv. (WDP 94/06)
 

-\begin{code}
-stgLookup :: StgEnv -> Id -> Id
-stgLookup env var = case (lookupVarEnv env var) of
-                     Nothing  -> var
-                     Just var -> var
-\end{code}
-

 Invent a fresh @Id@:
 \begin{code}
 newStgVar :: Type -> UniqSM Id
 Invent a fresh @Id@:
 \begin{code}
 newStgVar :: Type -> UniqSM Id

@@ -742,22 +624,6 @@ newStgVar ty
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-{-     Now redundant, I believe
--- we overload the demandInfo field of an Id to indicate whether the Id is definitely
--- evaluated or not (i.e. whether it is a case binder).  This can be used to eliminate
--- some redundant cases (c.f. dataToTag# above).
-
-newEvaldLocalId env id
-  = getUniqueUs                        `thenUs` \ uniq ->
-    let
-      id'     = modifyIdInfo (`setDemandInfo` wwStrict) (setIdUnique id uniq)
-      new_env = extendVarEnv env id id'
-    in
-    returnUs (new_env, id')
--}
-
-newEvaldLocalId env id = newLocalId NotTopLevel env id
-

 newLocalId TopLevel env id
   -- Don't clone top-level binders.  MkIface relies on their
   -- uniques staying the same, so it can snaffle IdInfo off the
 newLocalId TopLevel env id
   -- Don't clone top-level binders.  MkIface relies on their
   -- uniques staying the same, so it can snaffle IdInfo off the

@@ -801,25 +667,87 @@ newLocalIds top_lev env (b:bs)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-mkStgAlgAlts  ty alts deflt = seqType ty `seq` StgAlgAlts  ty alts deflt
-mkStgPrimAlts ty alts deflt = seqType ty `seq` StgPrimAlts ty alts deflt
-mkStgCon con args ty       = seqType ty `seq` StgCon con args ty
-mkStgLam ty bndrs body     = seqType ty `seq` StgLam ty bndrs body
-
-mkStgApp :: Id -> [StgArg] -> StgExpr
-mkStgApp fn args = fn `seq` StgApp fn args
-       -- Force the lookup
+-- There are two things going on in mkStgAlgAlts
+-- a)  We pull out the type constructor for the case, from the data
+--     constructor, if there is one.  See notes with the StgAlgAlts data type
+-- b)  We force the type constructor to avoid space leaks
+
+mkStgAlgAlts ty alts deflt 
+  = case alts of
+               -- Get the tycon from the data con
+       (dc, _, _, _):_ -> StgAlgAlts (Just (dataConTyCon dc)) alts deflt
+
+               -- Otherwise just do your best
+       [] -> case splitTyConApp_maybe (repType ty) of
+               Just (tc,_) | isAlgTyCon tc -> StgAlgAlts (Just tc) alts deflt
+               other                       -> StgAlgAlts Nothing alts deflt
+
+mkStgPrimAlts ty alts deflt 
+  = case splitTyConApp ty of
+       (tc,_) -> StgPrimAlts tc alts deflt
+
+mkStgLam ty bndrs body = seqType ty `seq` StgLam ty bndrs body
+
+mkStgApp :: StgEnv -> Id -> [StgArg] -> Type -> UniqSM StgExpr
+       -- The type is the type of the entire application
+mkStgApp env fn args ty
+ = case idFlavour fn_alias of
+      DataConId dc 
+       -> saturate fn_alias args ty    $ \ args' ty' ->
+          returnUs (StgConApp dc args')
+
+      PrimOpId (CCallOp ccall)
+               -- Sigh...make a guaranteed unique name for a dynamic ccall
+               -- Done here, not earlier, because it's a code-gen thing
+       -> saturate fn_alias args ty    $ \ args' ty' ->
+          getUniqueUs                  `thenUs` \ uniq ->
+           let ccall' = setCCallUnique ccall uniq in
+          returnUs (StgPrimApp (CCallOp ccall') args' ty')
+          
+
+      PrimOpId op 
+       -> saturate fn_alias args ty    $ \ args' ty' ->
+          returnUs (StgPrimApp op args' ty')
+
+      other -> returnUs (StgApp fn_alias args)
+                       -- Force the lookup
+  where
+    fn_alias = case (lookupVarEnv env fn) of   -- In case it's been cloned
+                     Nothing  -> fn
+                     Just fn' -> fn'
+
+saturate :: Id -> [StgArg] -> Type -> ([StgArg] -> Type -> UniqSM StgExpr) -> UniqSM StgExpr
+       -- The type should be the type of (id args)
+saturate fn args ty thing_inside
+  | excess_arity == 0  -- Saturated, so nothing to do
+  = thing_inside args ty
+
+  | otherwise  -- An unsaturated constructor or primop; eta expand it
+  = ASSERT2( excess_arity > 0 && excess_arity <= length arg_tys, 
+            ppr fn <+> ppr args <+> ppr excess_arity <+> parens (ppr ty) <+> ppr arg_tys )
+    mapUs newStgVar extra_arg_tys                              `thenUs` \ arg_vars ->
+    thing_inside (args ++ map StgVarArg arg_vars) final_res_ty  `thenUs` \ body ->
+    returnUs (StgLam ty arg_vars body)
+  where
+    fn_arity           = idArity fn
+    excess_arity       = fn_arity - length args
+    (arg_tys, res_ty)  = splitRepFunTys ty
+    extra_arg_tys      = take excess_arity arg_tys
+    final_res_ty       = mkFunTys (drop excess_arity arg_tys) res_ty

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

--- Stg doesn't have a lambda *expression*, 
-deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
-deStgLam expr                  = returnUs expr
-
-mkStgLamExpr ty bndrs body
+-- Stg doesn't have a lambda *expression*
+deStgLam (StgLam ty bndrs body) 
+       -- Try for eta reduction

   = ASSERT( not (null bndrs) )
   = ASSERT( not (null bndrs) )

-    newStgVar ty               `thenUs` \ fn ->
-    returnUs (StgLet (StgNonRec fn lam_closure) (mkStgApp fn []))
+    case eta body of
+       Just e  ->      -- Eta succeeded
+                   returnUs e          
+
+       Nothing ->      -- Eta failed, so let-bind the lambda
+                   newStgVar ty                `thenUs` \ fn ->
+                   returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))

   where
     lam_closure = StgRhsClosure noCCS
                                stgArgOcc
   where
     lam_closure = StgRhsClosure noCCS
                                stgArgOcc

@@ -829,6 +757,52 @@ mkStgLamExpr ty bndrs body
                                bndrs
                                body
 
                                bndrs
                                body
 

+    eta (StgApp f args)
+       | n_remaining >= 0 &&
+         and (zipWith ok bndrs last_args) &&
+         notInExpr bndrs remaining_expr
+       = Just remaining_expr
+       where
+         remaining_expr = StgApp f remaining_args
+         (remaining_args, last_args) = splitAt n_remaining args
+         n_remaining = length args - length bndrs
+
+    eta (StgLet bind@(StgNonRec b r) body)
+       | notInRhs bndrs r = case eta body of
+                               Just e -> Just (StgLet bind e)
+                               Nothing -> Nothing
+
+    eta _ = Nothing
+
+    ok bndr (StgVarArg arg) = bndr == arg
+    ok bndr other          = False
+
+deStgLam expr = returnUs expr
+
+
+--------------------------------------------------
+notInExpr :: [Id] -> StgExpr -> Bool
+notInExpr vs (StgApp f args)              = notInId vs f && notInArgs vs args
+notInExpr vs (StgLet (StgNonRec b r) body) = notInRhs vs r && notInExpr vs body
+notInExpr vs other                        = False      -- Safe
+
+notInRhs :: [Id] -> StgRhs -> Bool
+notInRhs vs (StgRhsCon _ _ args)            = notInArgs vs args
+notInRhs vs (StgRhsClosure _ _ _ _ _ _ body) = notInExpr vs body
+       -- Conservative: we could delete the binders from vs, but
+       -- cloning means this will never help
+
+notInArgs :: [Id] -> [StgArg] -> Bool
+notInArgs vs args = all ok args
+                 where
+                   ok (StgVarArg v) = notInId vs v
+                   ok (StgLitArg l) = True
+
+notInId :: [Id] -> Id -> Bool
+notInId vs v = not (v `elem` vs)
+
+
+

 mkStgBinds :: [StgFloatBind] 
           -> StgExpr           -- *Can* be a StgLam 
           -> UniqSM StgExpr    -- *Can* be a StgLam 
 mkStgBinds :: [StgFloatBind] 
           -> StgExpr           -- *Can* be a StgLam 
           -> UniqSM StgExpr    -- *Can* be a StgLam 

@@ -858,8 +832,8 @@ mk_stg_let bndr rhs dem floats body
 #endif
   | isUnLiftedType bndr_rep_ty                 -- Use a case/PrimAlts
   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
 #endif
   | isUnLiftedType bndr_rep_ty                 -- Use a case/PrimAlts
   = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )

-    mkStgBinds floats $
-    mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
+    mkStgCase rhs bndr (mkStgPrimAlts bndr_rep_ty [] (StgBindDefault body))    `thenUs` \ expr' ->
+    mkStgBinds floats expr'

 
   | is_whnf
   = if is_strict then
 
   | is_whnf
   = if is_strict then

@@ -878,8 +852,8 @@ mk_stg_let bndr rhs dem floats body
   | otherwise  -- Not WHNF
   = if is_strict then
        -- Strict let with non-WHNF rhs
   | otherwise  -- Not WHNF
   = if is_strict then
        -- Strict let with non-WHNF rhs

-       mkStgBinds floats $
-       mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
+       mkStgCase rhs bndr (mkStgAlgAlts bndr_rep_ty [] (StgBindDefault body))  `thenUs` \ expr' ->
+       mkStgBinds floats expr'

     else
        -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
        mkStgBinds floats rhs           `thenUs` \ new_rhs ->
     else
        -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
        mkStgBinds floats rhs           `thenUs` \ new_rhs ->

@@ -889,9 +863,9 @@ mk_stg_let bndr rhs dem floats body
     bndr_rep_ty = repType (idType bndr)
     is_strict   = isStrictDem dem
     is_whnf     = case rhs of
     bndr_rep_ty = repType (idType bndr)
     is_strict   = isStrictDem dem
     is_whnf     = case rhs of

-                   StgCon _ _ _ -> True
-                   StgLam _ _ _ -> True
-                   other        -> False
+                   StgConApp _ _ -> True
+                   StgLam _ _ _  -> True
+                   other         -> False

 
 -- Split at the first strict binding
 splitFloats fs@(NonRecF _ _ dem _ : _) 
 
 -- Split at the first strict binding
 splitFloats fs@(NonRecF _ _ dem _ : _) 

@@ -901,12 +875,91 @@ splitFloats (f : fs) = case splitFloats fs of
                             (fs_out, fs_in) -> (f : fs_out, fs_in)
 
 splitFloats [] = ([], [])
                             (fs_out, fs_in) -> (f : fs_out, fs_in)
 
 splitFloats [] = ([], [])

+\end{code}

 
 
 
 

+Making an STG case
+~~~~~~~~~~~~~~~~~~
+
+First, two special cases.  We mangle cases involving 
+               par# and seq#
+inthe scrutinee.
+
+Up to this point, seq# will appear like this:
+
+         case seq# e of
+               0# -> seqError#
+               _  -> <stuff>
+
+This code comes from an unfolding for 'seq' in Prelude.hs.
+The 0# branch is purely to bamboozle the strictness analyser.
+For example, if <stuff> is strict in x, and there was no seqError#
+branch, the strictness analyser would conclude that the whole expression
+was strict in x, and perhaps evaluate x first -- but that would be a DISASTER.
+
+Now that the evaluation order is safe, we translate this into
+
+         case e of
+               _ -> ...
+
+This used to be done in the post-simplification phase, but we need
+unfoldings involving seq# to appear unmangled in the interface file,
+hence we do this mangling here.
+
+Similarly, par# has an unfolding in PrelConc.lhs that makes it show
+up like this:
+
+       case par# e of
+         0# -> rhs
+         _  -> parError#
+
+
+    ==>
+       case par# e of
+         _ -> rhs
+
+fork# isn't handled like this - it's an explicit IO operation now.
+The reason is that fork# returns a ThreadId#, which gets in the
+way of the above scheme.  And anyway, IO is the only guaranteed
+way to enforce ordering  --SDM.
+
+
+\begin{code}
+-- Discard alernatives in case (par# ..) of 
+mkStgCase scrut@(StgPrimApp ParOp _ _) bndr
+         (StgPrimAlts tycon _ deflt@(StgBindDefault _))
+  = returnUs (StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT (StgPrimAlts tycon [] deflt))
+
+mkStgCase (StgPrimApp SeqOp [scrut] _) bndr 
+         (StgPrimAlts _ _ deflt@(StgBindDefault rhs))
+  = mkStgCase scrut_expr new_bndr new_alts
+  where
+    new_alts | isUnLiftedType scrut_ty = WARN( True, text "mkStgCase" ) mkStgPrimAlts scrut_ty [] deflt
+            | otherwise               = mkStgAlgAlts scrut_ty [] deflt
+    scrut_ty = stgArgType scrut
+    new_bndr = setIdType bndr scrut_ty
+       -- 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.
+
+    scrut_expr = case scrut of
+                  StgVarArg v -> StgApp v []
+                  -- Others should not happen because 
+                  -- seq of a value should have disappeared
+                  StgLitArg l -> WARN( True, text "seq on" <+> ppr l ) StgLit l
+

 mkStgCase scrut bndr alts
 mkStgCase scrut bndr alts

-  = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
-       -- We should never find 
-       --      case (\x->e) of { ... }
-       -- The simplifier eliminates such things
-    StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
+  = deStgLam scrut     `thenUs` \ scrut' ->
+       -- It is (just) possible to get a lambda as a srutinee here
+       -- Namely: fromDyn (toDyn ((+1)::Int->Int)) False)
+       -- gives:       case ...Bool == Int->Int... of
+       --                 True -> case coerce Bool (\x -> + 1 x) of
+       --                              True -> ...
+       --                              False -> ...
+       --                 False -> ...
+       -- The True branch of the outer case will never happen, of course.
+
+    returnUs (StgCase scrut' bOGUS_LVs bOGUS_LVs bndr noSRT alts)

 \end{code}
 \end{code}