[project @ 2003-06-30 14:27:51 by simonpj]

-------------------
	Fix a subtle GC bug
	-------------------

In GHC 6.0, the top-level definition

	f = g

gets compiled as a *non-updatable* THUNK_STATIC closure.  Being non-updatable,
it gets only 1 payload field.  Alas, the static-link field for a THUNK_STATIC
goes in the 3rd payload field.  Disaster.

Solution: make such things updatable. This is probably good because it turns
f into an IND_STATIC, which gets shorted out.  (Even better would be to allocate
an IND_STATIC in the first place.)

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 7aa9b22..5c26e0d 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -1238,7 +1238,15 @@ is_static in_arg other_expr = go other_expr 0
   where
     go (Var f) n_val_args
        | not (isDllName (idName f))
   where
     go (Var f) n_val_args
        | not (isDllName (idName f))

-       = n_val_args == 0 || saturated_data_con f n_val_args
+       =  saturated_data_con f n_val_args
+       || (in_arg && n_val_args == 0)  
+               -- A naked un-applied variable is *not* deemed a static RHS
+               -- E.g.         f = g
+               -- Reason: better to update so that the indirection gets shorted
+               --         out, and the true value will be seen
+               -- NB: if you change this, you'll break the invariant that THUNK_STATICs
+               --     are always updatable.  If you do so, make sure that non-updatable
+               --     ones have enough space for their static link field!

 
     go (App f a) n_val_args
        | isTypeArg a                    = go f n_val_args
 
     go (App f a) n_val_args
        | isTypeArg a                    = go f n_val_args

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 6e1f012..15e9fc3 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -236,31 +236,31 @@ coreToTopStgRhs
 coreToTopStgRhs scope_fv_info (bndr, rhs)
   = coreToStgExpr rhs          `thenLne` \ (new_rhs, rhs_fvs, _) ->
     freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
 coreToTopStgRhs scope_fv_info (bndr, rhs)
   = coreToStgExpr rhs          `thenLne` \ (new_rhs, rhs_fvs, _) ->
     freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->

-    returnLne (mkTopStgRhs upd rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
+    returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)

   where
     bndr_info = lookupFVInfo scope_fv_info bndr
   where
     bndr_info = lookupFVInfo scope_fv_info bndr

+    is_static = rhsIsStatic rhs

 
 

-    upd  | rhsIsStatic rhs = SingleEntry
-        | otherwise       = Updatable
-
-mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
+mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr

        -> StgRhs
 
        -> StgRhs
 

-mkTopStgRhs upd rhs_fvs srt binder_info (StgLam _ bndrs body)
-  = StgRhsClosure noCCS binder_info
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body)
+  = ASSERT( is_static )
+    StgRhsClosure noCCS binder_info

                  (getFVs rhs_fvs)               
                  ReEntrant
                  srt
                  bndrs body
        
                  (getFVs rhs_fvs)               
                  ReEntrant
                  srt
                  bndrs body
        

-mkTopStgRhs upd rhs_fvs srt binder_info (StgConApp con args)
-  | not (isUpdatable upd) -- StgConApps can be updatable (see isCrossDllConApp)
+mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args)
+  | is_static   -- StgConApps can be updatable (see isCrossDllConApp)

   = StgRhsCon noCCS con args
 
   = StgRhsCon noCCS con args
 

-mkTopStgRhs upd rhs_fvs srt binder_info rhs
-  = StgRhsClosure noCCS binder_info
+mkTopStgRhs is_static rhs_fvs srt binder_info rhs
+  = ASSERT( not is_static )
+    StgRhsClosure noCCS binder_info

                  (getFVs rhs_fvs)               
                  (getFVs rhs_fvs)               

-                 upd
+                 Updatable

                  srt
                  [] rhs
 \end{code}
                  srt
                  [] rhs
 \end{code}