[project @ 2003-05-14 09:13:52 by simonmar]

Change the way SRTs are represented:

Previously, the SRT associated with a function or thunk would be a
sub-list of the enclosing top-level function's SRT.  But this approach
can lead to lots of duplication: if a CAF is referenced in several
different thunks, then it may appear several times in the SRT.
Let-no-escapes compound the problem, because the occurrence of a
let-no-escape-bound variable would expand to all the CAFs referred to
by the let-no-escape.

The new way is to describe the SRT associated with a function or thunk
as a (pointer+offset,bitmap) pair, where the pointer+offset points
into some SRT table (the enclosing function's SRT), and the bitmap
indicates which entries in this table are "live" for this closure.
The bitmap is stored in the 16 bits previously used for the length
field, but this rarely overflows.  When it does overflow, we store the
bitmap externally in a new "SRT descriptor".

Now the enclosing SRT can be a set, hence eliminating the duplicates.

Also, we now have one SRT per top-level function in a recursive group,
where previously we used to have one SRT for the whole group.  This
helps keep the size of SRTs down.

Bottom line: very little difference most of the time.  GHC itself got
slightly smaller.  One bad case of a module in GHC which had a huge
SRT has gone away.

While I was in the area:

  - Several parts of the back-end require bitmaps.  Functions for
    creating bitmaps are now centralised in the Bitmap module.

  - We were trying to be independent of word-size in a couple of
    places in the back end, but we've now abandoned that strategy so I
    simplified things a bit.

3 files changed, 126 insertions, 189 deletions

diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs
index 86fb305c7a..89ef8e43ef 100644
--- a/ghc/compiler/simplStg/SRT.lhs
+++ b/ghc/compiler/simplStg/SRT.lhs
@@ -14,233 +14,170 @@ module SRT( computeSRTs ) where
 import StgSyn
 import Id        	( Id )
 import VarSet
-import BasicTypes	( TopLevelFlag(..), isTopLevel )
-import Util		( mapAccumL )
+import VarEnv
+import Util		( sortLt )
+import Maybes		( orElse )
+import Maybes		( expectJust )
+import Bitmap		( intsToBitmap )
 
 #ifdef DEBUG
-import Util		( lengthIs )
 import Outputable
 #endif
-\end{code}
 
-\begin{code}
-computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
-  -- The incoming bindingd are filled with SRTEntries in their SRT slots
-  -- the outgoing ones have NoSRT/SRT values instead
+import List
 
-computeSRTs binds = map srtTopBind binds
+import Util
+import Outputable
 \end{code}
 
------------------------------------------------------------------------------
-Algorithm for figuring out SRT layout.
-
-Our functions have type
-
-srtExpr	:: SrtOffset		-- Next free offset within the SRT
-	-> StgExpr		-- Expression to analyse
-	-> (StgExpr,		-- (e) newly annotated expression
-	    SrtIds,		-- (s) SRT required for this expression (reversed)
-	    SrtOffset)		-- (o) new offset
-
-We build a single SRT for a recursive binding group, which is why the
-SRT building is done at the binding level rather than the
-StgRhsClosure level.
-
-The SRT is built up in reverse order, to avoid too many expensive
-appends.  We therefore reverse the SRT before returning it, so that
-the offsets will be from the beginning of the SRT.
-
------------------------------------------------------------------------------
-Top-level Bindings
-
-A function whose CafInfo is NoCafRefs will have an empty SRT, and its
-closure will not appear in the SRT of any other function (unless we're
-compiling without optimisation and the CafInfos haven't been emitted
-in the interface files).
-
-Top-Level recursive groups
-
-This gets a bit complicated, but the general idea is that we want a
-single SRT for the whole group, and we'd rather not have recursive
-references in it if at all possible.
-
-We collect all the global references for the group, and filter out
-those that are binders in the group and not CAFs themselves.  Why is
-it done this way?
-
-	- if all the bindings in the group just refer to each other,
-	  and none of them are CAFs, we'd like to get an empty SRT.
-
-	- if any of the bindings in the group refer to a CAF, this will
-	  appear in the SRT.
-
-Hmm, that probably makes no sense.
-
 \begin{code}
-type SrtOffset = Int
-type SrtIds    = [Id]  -- An *reverse-ordered* list of the Ids needed in the SRT
-
-srtTopBind :: StgBinding -> (StgBinding, SrtIds)
-
-srtTopBind bind
-  = 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
+computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
+  -- The incoming bindingd are filled with SRTEntries in their SRT slots
+  -- the outgoing ones have NoSRT/SRT values instead
 
-isConBind (StgNonRec _ _ r) = isConRhs r
-isConBind (StgRec _ bs)     = all isConRhs (map snd bs)
+computeSRTs binds = srtTopBinds emptyVarEnv binds
 
-isConRhs (StgRhsCon _ _ _) = True
-isConRhs _		   = False
+-- --------------------------------------------------------------------------
+-- Top-level Bindings
 
-srtBind :: TopLevelFlag -> SrtOffset -> StgBinding
-        -> (StgBinding, SrtIds, SrtOffset)
+srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
 
-srtBind top off (StgNonRec (SRTEntries rhs_cafs) binder rhs) 
-  = (StgNonRec srt_info binder new_rhs, this_srt, body_off)
+srtTopBinds env [] = []
+srtTopBinds env (StgNonRec b rhs : binds) = 
+  (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
   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 top off (StgRec (SRTEntries rhss_cafs) pairs)
-  = (StgRec srt_info new_pairs, this_srt, body_off)
+    (rhs', srt) = srtTopRhs b rhs
+    env' = maybeExtendEnv env b rhs
+    srt' = applyEnvList env srt
+srtTopBinds env (StgRec bs : binds) = 
+  (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
+  where
+    (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
+    bndrs = map fst bs
+    srts' = map (applyEnvList env) srts
+
+-- Shorting out indirections in SRTs:  if a binding has an SRT with a single
+-- element in it, we just inline it with that element everywhere it occurs
+-- in other SRTs.
+--
+-- This is in a way a generalisation of the CafInfo.  CafInfo says
+-- whether a top-level binding has *zero* CAF references, allowing us
+-- to omit it from SRTs.  Here, we pick up bindings with *one* CAF
+-- reference, and inline its SRT everywhere it occurs.  We could pass
+-- this information across module boundaries too, but we currently
+-- don't.
+
+maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
+  | [one] <- varSetElems cafs
+  = extendVarEnv env bndr (applyEnv env one)
+maybeExtendEnv env bndr _ = env
+
+applyEnvList :: IdEnv Id -> [Id] -> [Id]
+applyEnvList env = map (applyEnv env)
+
+applyEnv env id = lookupVarEnv env id `orElse` id
+
+-- ----  Top-level right hand sides:
+
+srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
+
+srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
+srtTopRhs binder rhs@(StgRhsClosure _ _ _ _  (SRTEntries cafs) _ _)
+  = (srtRhs table rhs, elems)
   where
-    ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs
+	elems = varSetElems cafs
+        table = mkVarEnv (zip elems [0..])
 
-    do_bind (off,srt) (bndr,rhs)
-	= srtRhs off rhs		=: \(rhs', srt', off') ->
-	  ((off', srt'++srt), (bndr, rhs'))
+-- ---- Binds:
 
-    non_caf_binders = [ b | (b, rhs) <- pairs, not (caf_rhs rhs) ]
+srtBind :: IdEnv Int -> StgBinding -> StgBinding
 
-    filtered_rhss_cafs
-	| isTopLevel top = filterVarSet (`notElem` non_caf_binders) rhss_cafs
-	| otherwise      = rhss_cafs
+srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
+srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
 
-    (srt_info, this_srt, body_off)
-	 = constructSRT filtered_rhss_cafs rhss_srt off rhss_off
+-- ---- Right Hand Sides:
 
-caf_rhs (StgRhsClosure _ _ free_vars _ [] body) = True
-caf_rhs _ = False
-\end{code}
+srtRhs :: IdEnv Int -> StgRhs -> StgRhs
 
------------------------------------------------------------------------------
-Right Hand Sides
+srtRhs table e@(StgRhsCon cc con args) = e
+srtRhs table (StgRhsClosure cc bi free_vars u (SRTEntries cafs) args body)
+  = StgRhsClosure cc bi free_vars u (constructSRT table cafs) args 
+	$! (srtExpr table body)
 
-\begin{code}
-srtRhs 	:: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset)
+-- ---------------------------------------------------------------------------
+-- Expressions
 
-srtRhs off (StgRhsClosure cc bi free_vars u args body)
-  = srtExpr off body			=: \(body, srt, off) ->
-    (StgRhsClosure cc bi free_vars u args body, srt, off)
+srtExpr :: IdEnv Int -> StgExpr -> StgExpr
 
-srtRhs off e@(StgRhsCon cc con args) = (e, [], off)
-\end{code}
+srtExpr table e@(StgApp f args) 	= e
+srtExpr table e@(StgLit l)      	= e
+srtExpr table e@(StgConApp con args)    = e
+srtExpr table e@(StgOpApp op args ty)   = e
 
------------------------------------------------------------------------------
-Expressions
+srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
 
-\begin{code}
-srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset)
-
-srtExpr off e@(StgApp f args) 	    = (e, [], off)
-srtExpr off e@(StgLit l)      	    = (e, [], off)
-srtExpr off e@(StgConApp con args)  = (e, [], off)
-srtExpr off e@(StgOpApp op args ty) = (e, [], off)
-
-srtExpr off (StgSCC cc expr) =
-   srtExpr off expr	=: \(expr, srt, off) ->
-   (StgSCC cc expr, srt, off)
-
-srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
- = srtCaseAlts off alts 	=: \(alts, alts_srt, alts_off) ->
-   let
-	(srt_info, this_srt, scrut_off) 
-		= constructSRT cafs_in_alts alts_srt off alts_off
+srtExpr table (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
+ = let 
+	expr' = srtExpr table scrut
+	srt_info = constructSRT table cafs_in_alts
+	alts' = srtCaseAlts table alts
    in
-   srtExpr scrut_off scrut	=: \(scrut, scrut_srt, case_off) ->
+       StgCase expr' live1 live2 uniq srt_info alts'
 
-   (StgCase scrut live1 live2 uniq srt_info alts, 
-    scrut_srt ++ this_srt, 
-    case_off)
-
-srtExpr off (StgLet bind body)
-  = 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 table (StgLet bind body)
+  = srtBind table bind =: \ bind' ->
+    srtExpr table body		   =: \ body' ->
+    StgLet bind' body'
      
-srtExpr off (StgLetNoEscape live1 live2 bind body)
-  = 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)
+srtExpr table (StgLetNoEscape live1 live2 bind body)
+  = srtBind table bind =: \ bind' ->
+    srtExpr table body		   =: \ body' ->
+    StgLetNoEscape live1 live2 bind' body'
 
 #ifdef DEBUG
-srtExpr off expr = pprPanic "srtExpr" (ppr expr)
+srtExpr table expr = pprPanic "srtExpr" (ppr expr)
 #endif
-\end{code}
 
------------------------------------------------------------------------------
-Construct an SRT.
 
-Construct the SRT at this point from its sub-SRTs and any new global
-references which aren't already contained in one of the sub-SRTs (and
-which are "live").
+-- Case Alternatives
 
-\begin{code}
-constructSRT caf_refs sub_srt initial_offset current_offset
-   = let
-       extra_refs = filter (`notElem` sub_srt) (varSetElems caf_refs)
-       this_srt   = extra_refs ++ sub_srt
+srtCaseAlts :: IdEnv Int -> StgCaseAlts -> StgCaseAlts
 
-	-- Add the length of the new entries to the	
-        -- current offset to get the next free offset in the global SRT.
-       new_offset = current_offset + length extra_refs
-       srt_length = new_offset - initial_offset
+srtCaseAlts table (StgAlgAlts t alts dflt)
+  = (StgAlgAlts t $! map (srtAlgAlt table) alts) $! srtDefault table dflt
 
-       srt_info | srt_length == 0 = NoSRT
-		| otherwise       = SRT initial_offset srt_length
+srtCaseAlts table (StgPrimAlts t alts dflt)
+  = (StgPrimAlts t $! map (srtPrimAlt table) alts) $! srtDefault table dflt
 
-   in ASSERT( this_srt `lengthIs` srt_length )
-      (srt_info, this_srt, new_offset)
-\end{code}
+srtAlgAlt table (con,args,used,rhs)
+  = (,,,) con args used $! srtExpr table rhs
 
------------------------------------------------------------------------------
-Case Alternatives
+srtPrimAlt table (lit,rhs)
+  = (,) lit $! srtExpr table rhs
 
-\begin{code}
-srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset)
-
-srtCaseAlts off (StgAlgAlts t alts dflt)
-  = srtDefault off dflt	 				=: \ ((dflt_off, dflt_srt), dflt') ->
-    mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts	=: \ ((alts_off, alts_srt), alts') ->
-    (StgAlgAlts t alts' dflt', alts_srt, alts_off)
-
-srtCaseAlts off (StgPrimAlts t alts dflt)
-  = srtDefault off dflt	 				=: \ ((dflt_off, dflt_srt), dflt') ->
-    mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts	=: \ ((alts_off, alts_srt), alts') ->
-    (StgPrimAlts t alts' dflt', alts_srt, alts_off)
-
-srtAlgAlt (off,srt) (con,args,used,rhs)
-  = srtExpr off rhs	=: \(rhs', rhs_srt, rhs_off) ->
-    ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs'))
-
-srtPrimAlt (off,srt) (lit,rhs)
-  = srtExpr off rhs	=: \(rhs', rhs_srt, rhs_off) ->
-    ((rhs_off, rhs_srt ++ srt), (lit, rhs'))
-
-srtDefault off StgNoDefault
-  = ((off,[]), StgNoDefault)
-srtDefault off (StgBindDefault rhs)
-  = srtExpr off rhs	=: \(rhs', srt, off) ->
-    ((off,srt), StgBindDefault rhs')
-\end{code}
+srtDefault table StgNoDefault  = StgNoDefault
+srtDefault table (StgBindDefault rhs)
+  = StgBindDefault $! srtExpr table rhs
 
 -----------------------------------------------------------------------------
-Misc stuff
+-- Construct an SRT bitmap.
+
+constructSRT :: IdEnv Int -> IdSet -> SRT
+constructSRT table entries
+ | isEmptyVarSet entries = NoSRT
+ | otherwise  = SRT offset len bitmap
+  where
+    ints = map (expectJust "constructSRT" . lookupVarEnv table) 
+		(varSetElems entries)
+    sorted_ints = sortLt (<) ints
+    offset = head sorted_ints
+    bitmap_entries = map (subtract offset) sorted_ints
+    len = last bitmap_entries + 1
+    bitmap = intsToBitmap len bitmap_entries
+
+-- ---------------------------------------------------------------------------
+-- Misc stuff
 
-\begin{code}
 a =: k  = k a
+
 \end{code}
diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs
index cc918b7a6f..dc945f52be 100644
--- a/ghc/compiler/simplStg/SimplStg.lhs
+++ b/ghc/compiler/simplStg/SimplStg.lhs
@@ -30,7 +30,7 @@ import Outputable
 stg2stg :: DynFlags		     -- includes spec of what stg-to-stg passes to do
 	-> Module		     -- module name (profiling only)
 	-> [StgBinding]		     -- input...
-	-> IO ( [(StgBinding,[Id])]  -- output program...
+	-> IO ( [(StgBinding,[(Id,[Id])])]  -- output program...
 	      , CollectedCCs)        -- cost centre information (declared and used)
 
 stg2stg dflags module_name binds
diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs
index 824c112a1c..0e5a75b320 100644
--- a/ghc/compiler/simplStg/StgStats.lhs
+++ b/ghc/compiler/simplStg/StgStats.lhs
@@ -117,10 +117,10 @@ statBinding :: Bool -- True <=> top-level; False <=> nested
 	    -> StgBinding
 	    -> StatEnv
 
-statBinding top (StgNonRec _srt b rhs)
+statBinding top (StgNonRec b rhs)
   = statRhs top (b, rhs)
 
-statBinding top (StgRec _srt pairs)
+statBinding top (StgRec pairs)
   = combineSEs (map (statRhs top) pairs)
 
 statRhs :: Bool -> (Id, StgRhs) -> StatEnv
@@ -128,7 +128,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv
 statRhs top (b, StgRhsCon cc con args)
   = countOne (ConstructorBinds top)
 
-statRhs top (b, StgRhsClosure cc bi fv u args body)
+statRhs top (b, StgRhsClosure cc bi fv u _srt args body)
   = statExpr body			`combineSE`
     countN FreeVariables (length fv)	`combineSE`
     countOne (