From: simonmar <unknown>
Date: Fri, 16 Mar 2001 18:15:14 +0000 (+0000)
Subject: [project @ 2001-03-16 18:15:14 by simonmar]
X-Git-Tag: Approximately_9120_patches~2384
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=9065458261dc927fec726e1758efb9c559a85980;p=ghc-hetmet.git

[project @ 2001-03-16 18:15:14 by simonmar]
Re-instate filtering of the CAF refs for recursive bindings.  This may
be the cause of GC being real slow on a bootstrapped compiler right now.
---

diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs
index 7029b6e..bd5636e 100644
--- a/ghc/compiler/simplStg/SRT.lhs
+++ b/ghc/compiler/simplStg/SRT.lhs
@@ -12,9 +12,10 @@ module SRT( computeSRTs ) where
 #include "HsVersions.h"
 
 import StgSyn
-import Id        ( Id )
-import VarSet	( varSetElems )
-import Util	( mapAccumL )
+import Id        	( Id )
+import VarSet
+import BasicTypes	( TopLevelFlag(..), isTopLevel )
+import Util		( mapAccumL )
 
 #ifdef DEBUG
 import Outputable
@@ -81,20 +82,29 @@ type SrtIds    = [Id]  -- An *reverse-ordered* list of the Ids needed in the SRT
 srtTopBind :: StgBinding -> (StgBinding, SrtIds)
 
 srtTopBind bind
-  = srtBind 0 bind	=: \ (bind', srt, off) ->
-    (bind', reverse srt)	-- The 'reverse' is because the SRT is 
-				-- built up reversed, for efficiency's sake
+  = srtBind TopLevel 0 bind	=: \ (bind', srt, off) ->
+    if isConBind bind'
+	then (bind', [])	   -- Don't need an SRT for a static constructor
+	else (bind', reverse srt)  -- The 'reverse' is because the SRT is 
+				   -- built up reversed, for efficiency's sake
 
-srtBind :: SrtOffset -> StgBinding -> (StgBinding, SrtIds, SrtOffset)
+isConBind (StgNonRec _ _ r) = isConRhs r
+isConBind (StgRec _ bs)     = all isConRhs (map snd bs)
 
-srtBind off (StgNonRec (SRTEntries rhs_cafs) binder rhs) 
+isConRhs (StgRhsCon _ _ _) = True
+isConRhs _		   = False
+
+srtBind :: TopLevelFlag -> SrtOffset -> StgBinding
+        -> (StgBinding, SrtIds, SrtOffset)
+
+srtBind top off (StgNonRec (SRTEntries rhs_cafs) binder rhs) 
   = (StgNonRec srt_info binder new_rhs, this_srt, body_off)
   where
     (new_rhs,  rhs_srt,  rhs_off)  = srtRhs off rhs
     (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off
     
 
-srtBind off (StgRec (SRTEntries rhss_cafs) pairs)
+srtBind top off (StgRec (SRTEntries rhss_cafs) pairs)
   = (StgRec srt_info new_pairs, this_srt, body_off)
   where
     ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs
@@ -103,8 +113,17 @@ srtBind off (StgRec (SRTEntries rhss_cafs) pairs)
 	= srtRhs off rhs		=: \(rhs', srt', off') ->
 	  ((off', srt'++srt), (bndr, rhs'))
 
+    non_caf_binders = [ b | (b, rhs) <- pairs, not (caf_rhs rhs) ]
+
+    filtered_rhss_cafs
+	| isTopLevel top = filterVarSet (`notElem` non_caf_binders) rhss_cafs
+	| otherwise      = rhss_cafs
+
     (srt_info, this_srt, body_off)
-	 = constructSRT rhss_cafs rhss_srt off rhss_off
+	 = constructSRT filtered_rhss_cafs rhss_srt off rhss_off
+
+caf_rhs (StgRhsClosure _ _ free_vars _ [] body) = True
+caf_rhs _ = False
 \end{code}
 
 -----------------------------------------------------------------------------
@@ -148,12 +167,12 @@ srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
     case_off)
 
 srtExpr off (StgLet bind body)
-  = srtBind off bind		=: \ (bind', bind_srt, body_off) ->
+  = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
     srtExpr body_off body	=: \ (body', expr_srt, let_off) ->
     (StgLet bind' body', expr_srt ++ bind_srt, let_off)
      
 srtExpr off (StgLetNoEscape live1 live2 bind body)
-  = srtBind off bind		=: \ (bind', bind_srt, body_off) ->
+  = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
     srtExpr body_off body	=: \ (body', expr_srt, let_off) ->
     (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off)