[project @ 1999-06-24 12:27:11 by simonmar]

The decision to not make a static closure should only be taken for
top-level bindings.

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index b7110f8..1a31975 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -38,7 +38,9 @@ import Type           ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
 import TysPrim         ( intPrimTy )
 import UniqSupply      -- all of it, really
 import Util            ( lengthExceeds )
-import BasicTypes      ( TopLevelFlag(..) )
+import BasicTypes      ( TopLevelFlag(..), isNotTopLevel )
+import CmdLineOpts     ( opt_D_verbose_stg2stg )
+import UniqSet         ( emptyUniqSet )
 import Maybes
 import Outputable
 \end{code}
@@ -157,12 +159,17 @@ No free/live variable information is pinned on in this pass; it's added
 later.  For this pass
 we use @bOGUS_LVs@ and @bOGUS_FVs@ as placeholders.
 
+When printing out the Stg we need non-bottom values in these
+locations.
+
 \begin{code}
 bOGUS_LVs :: StgLiveVars
-bOGUS_LVs = panic "bOGUS_LVs" -- emptyUniqSet (used when pprTracing)
+bOGUS_LVs | opt_D_verbose_stg2stg = emptyUniqSet
+         | otherwise =panic "bOGUS_LVs"
 
 bOGUS_FVs :: [Id]
-bOGUS_FVs = panic "bOGUS_FVs" -- [] (ditto)
+bOGUS_FVs | opt_D_verbose_stg2stg = [] 
+         | otherwise = panic "bOGUS_FVs"
 \end{code}
 
 \begin{code}
@@ -186,7 +193,8 @@ topCoreBindsToStg us core_binds
                            ppr b )             -- No top-level cases!
 
                   mkStgBinds floats rhs        `thenUs` \ new_rhs ->
-                  returnUs (StgNonRec bndr (exprToRhs dem new_rhs) : new_bs)
+                  returnUs (StgNonRec bndr (exprToRhs dem TopLevel new_rhs)
+                            : new_bs)
                                        -- Keep all the floats inside...
                                        -- Some might be cases etc
                                        -- We might want to revisit this decision
@@ -231,7 +239,7 @@ coreBindToStg top_lev env (Rec pairs)
     do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem     `thenUs` \ (floats, stg_expr) ->
                            mkStgBinds floats stg_expr          `thenUs` \ stg_expr' ->
                                -- NB: stg_expr' might still be a StgLam (and we want that)
-                           returnUs (exprToRhs dem stg_expr')
+                           returnUs (exprToRhs dem top_lev stg_expr')
                          where
                            dem = bdrDem bndr
 \end{code}
@@ -244,8 +252,8 @@ coreBindToStg top_lev env (Rec pairs)
 %************************************************************************
 
 \begin{code}
-exprToRhs :: RhsDemand -> StgExpr -> StgRhs
-exprToRhs dem (StgLam _ bndrs body)
+exprToRhs :: RhsDemand -> TopLevelFlag -> StgExpr -> StgRhs
+exprToRhs dem _ (StgLam _ bndrs body)
   = ASSERT( not (null bndrs) )
     StgRhsClosure noCCS
                  stgArgOcc
@@ -285,9 +293,10 @@ exprToRhs dem (StgLam _ bndrs body)
   constructors (ala C++ static class constructors) which will
   then be run at load time to fix up static closures.
 -}
-exprToRhs dem (StgCon (DataCon con) args _)
-  | not is_dynamic  &&
-    all  (not.is_lit_lit) args  = StgRhsCon noCCS con args
+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
 
@@ -297,7 +306,7 @@ exprToRhs dem (StgCon (DataCon con) args _)
        Literal l -> isLitLitLit l
        _         -> False
 
-exprToRhs dem expr
+exprToRhs dem _ expr
        = StgRhsClosure noCCS           -- No cost centre (ToDo?)
                        stgArgOcc       -- safe
                        noSRT           -- figure out later
@@ -813,7 +822,7 @@ mk_stg_let bndr rhs dem floats body
   = if is_strict then
        -- Strict let with WHNF rhs
        mkStgBinds floats $
-       StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
+       StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel rhs)) body
     else
        -- Lazy let with WHNF rhs; float until we find a strict binding
        let
@@ -821,7 +830,7 @@ mk_stg_let bndr rhs dem floats body
        in
        mkStgBinds floats_in rhs        `thenUs` \ new_rhs ->
        mkStgBinds floats_out $
-       StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body
+       StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body
 
   | otherwise  -- Not WHNF
   = if is_strict then
@@ -831,7 +840,7 @@ mk_stg_let bndr rhs dem floats body
     else
        -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
        mkStgBinds floats rhs           `thenUs` \ new_rhs ->
-       returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body)
+       returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
        
   where
     bndr_ty   = idType bndr