X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSRT.lhs;h=34e61ce16f1b23cc53606b95447b9301b6b5e843;hb=182b16bccea2eab1a8af93a6246db3d391e436c7;hp=7029b6e815038a3f01bf0163d1f7be5b8fc23896;hpb=10cbc75d37064b3ef76ca3ccd219d66e445ecb0f;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs
index 7029b6e..34e61ce 100644
--- a/ghc/compiler/simplStg/SRT.lhs
+++ b/ghc/compiler/simplStg/SRT.lhs
@@ -12,215 +12,154 @@ module SRT( computeSRTs ) where
 #include "HsVersions.h"
 
 import StgSyn
-import Id        ( Id )
-import VarSet	( varSetElems )
-import Util	( mapAccumL )
+import Id        	( Id )
+import VarSet
+import VarEnv
+import Util		( sortLt )
+import Maybes		( orElse )
+import Maybes		( expectJust )
+import Bitmap		( intsToBitmap )
 
 #ifdef DEBUG
 import Outputable
 #endif
+
+import List
+
+import Util
+import Outputable
 \end{code}
 
 \begin{code}
-computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
+computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
   -- The incoming bindingd are filled with SRTEntries in their SRT slots
   -- the outgoing ones have NoSRT/SRT values instead
 
-computeSRTs binds = map srtTopBind binds
-\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
+computeSRTs binds = srtTopBinds emptyVarEnv binds
 
-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 Bindings
 
-Top-Level recursive groups
+srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
 
-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.
+srtTopBinds env [] = []
+srtTopBinds env (StgNonRec b rhs : binds) = 
+  (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
+  where
+    (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
+	elems = varSetElems cafs
+        table = mkVarEnv (zip elems [0..])
 
-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?
+-- ---- Binds:
 
-	- 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.
+srtBind :: IdEnv Int -> StgBinding -> StgBinding
 
-	- if any of the bindings in the group refer to a CAF, this will
-	  appear in the SRT.
+srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
+srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
 
-Hmm, that probably makes no sense.
+-- ---- Right Hand Sides:
 
-\begin{code}
-type SrtOffset = Int
-type SrtIds    = [Id]  -- An *reverse-ordered* list of the Ids needed in the SRT
+srtRhs :: IdEnv Int -> StgRhs -> StgRhs
 
-srtTopBind :: StgBinding -> (StgBinding, SrtIds)
+srtRhs table e@(StgRhsCon cc con args) = e
+srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
+  = StgRhsClosure cc bi free_vars u (constructSRT table srt) args 
+	$! (srtExpr table body)
 
-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
+-- ---------------------------------------------------------------------------
+-- Expressions
 
-srtBind :: SrtOffset -> StgBinding -> (StgBinding, SrtIds, SrtOffset)
+srtExpr :: IdEnv Int -> StgExpr -> StgExpr
 
-srtBind 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
-    
+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
 
-srtBind 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
+srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
 
-    do_bind (off,srt) (bndr,rhs)
-	= srtRhs off rhs		=: \(rhs', srt', off') ->
-	  ((off', srt'++srt), (bndr, rhs'))
+srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
+ = StgCase expr' live1 live2 uniq srt' alt_type alts'
+ where
+   expr' = srtExpr table scrut
+   srt'  = constructSRT table srt
+   alts' = map (srtAlt table) alts
 
-    (srt_info, this_srt, body_off)
-	 = constructSRT rhss_cafs rhss_srt off rhss_off
-\end{code}
-
------------------------------------------------------------------------------
-Right Hand Sides
-
-\begin{code}
-srtRhs 	:: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset)
-
-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)
-
-srtRhs off e@(StgRhsCon cc con args) = (e, [], off)
-\end{code}
-
------------------------------------------------------------------------------
-Expressions
-
-\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@(StgPrimApp 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
-   in
-   srtExpr scrut_off scrut	=: \(scrut, scrut_srt, case_off) ->
-
-   (StgCase scrut live1 live2 uniq srt_info alts, 
-    scrut_srt ++ this_srt, 
-    case_off)
-
-srtExpr off (StgLet bind body)
-  = srtBind 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 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").
 
-\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
-
-	-- 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
-
-       srt_info | srt_length == 0 = NoSRT
-		| otherwise       = SRT initial_offset srt_length
-
-   in ASSERT( srt_length == length this_srt )
-      (srt_info, this_srt, new_offset)
-\end{code}
+srtAlt :: IdEnv Int -> StgAlt -> StgAlt
+srtAlt table (con,args,used,rhs)
+  = (,,,) con args used $! srtExpr table rhs
 
 -----------------------------------------------------------------------------
-Case Alternatives
+-- Construct an SRT bitmap.
 
-\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}
+constructSRT :: IdEnv Int -> SRT -> SRT
+constructSRT table (SRTEntries 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
+-- ---------------------------------------------------------------------------
+-- Misc stuff
 
-\begin{code}
 a =: k  = k a
+
 \end{code}