%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: AbsCSyn.lhs,v 1.36 2001/05/22 13:43:14 simonpj Exp $
+% $Id: AbsCSyn.lhs,v 1.37 2001/07/24 05:04:58 ken Exp $
%
\section[AbstractC]{Abstract C: the last stop before machine code}
| CSRT CLabel [CLabel] -- SRT declarations: basically an array of
-- pointers to static closures.
- | CBitmap CLabel LivenessMask -- A larger-than-32-bits bitmap.
+ | CBitmap CLabel LivenessMask -- A bitmap to be emitted if and only if
+ -- it is larger than a target machine word.
| CClosureInfoAndCode
ClosureInfo -- Explains placement and layout of closure
representation really is a bitmap). These are pinned onto case return
vectors to indicate the state of the stack for the garbage collector.
+In the compiled program, liveness bitmaps that fit inside a single
+word (StgWord) are stored as a single word, while larger bitmaps are
+stored as a pointer to an array of words. When we compile via C
+(especially when we bootstrap via HC files), we generate identical C
+code regardless of whether words are 32- or 64-bit on the target
+machine, by postponing the decision of how to store each liveness
+bitmap to C compilation time (or rather, C preprocessing time).
+
\begin{code}
type LivenessMask = [BitSet]
-data Liveness = LvSmall BitSet
- | LvLarge CLabel
+data Liveness = Liveness CLabel LivenessMask
\end{code}
%************************************************************************
addOneToUniqSet, UniqSet
)
import StgSyn ( SRT(..), StgOp(..) )
-import BitSet ( intBS )
+import BitSet ( BitSet, intBS )
import Outputable
import GlaExts
import Util ( nOfThem )
}
pprAbsC stmt@(CBitmap lbl mask) c
- = vcat [
- hcat [ ptext SLIT("BITMAP"), lparen,
- pprCLabel lbl, comma,
- int (length mask),
- rparen ],
- hcat (punctuate comma (map (int.intBS) mask)),
- ptext SLIT("}};")
- ]
+ = pp_bitmap_switch mask semi $
+ hcat [ ptext SLIT("BITMAP"), lparen,
+ pprCLabel lbl, comma,
+ int (length mask), comma,
+ pp_bitmap mask, rparen ]
pprAbsC (CSimultaneous abs_c) c
= hcat [ptext SLIT("{{"), pprAbsC abs_c c, ptext SLIT("}}")]
pprCLabel entry_lbl, comma,
pp_liveness liveness, comma, -- bitmap
pp_srt_info srt, -- SRT
- ptext type_str, comma, -- closure type
+ closure_type, comma, -- closure type
ppLocalness info_lbl, comma, -- info table storage class
ppLocalnessMacro True{-include dyn-} entry_lbl, comma, -- entry pt storage class
int 0, comma,
pp_code
]
where
- info_lbl = mkReturnInfoLabel uniq
- entry_lbl = mkReturnPtLabel uniq
+ info_lbl = mkReturnInfoLabel uniq
+ entry_lbl = mkReturnPtLabel uniq
- pp_code = let stuff = CCodeBlock entry_lbl code in
- pprAbsC stuff (costs stuff)
+ pp_code = let stuff = CCodeBlock entry_lbl code in
+ pprAbsC stuff (costs stuff)
- type_str = case liveness of
- LvSmall _ -> SLIT("RET_SMALL")
- LvLarge _ -> SLIT("RET_BIG")
+ closure_type = pp_liveness_switch liveness
+ (ptext SLIT("RET_SMALL"))
+ (ptext SLIT("RET_BIG"))
pprAbsC stmt@(CRetVector lbl amodes srt liveness) _
= case (pprTempAndExternDecls stmt) of { (_, pp_exts) ->
pprCLabel lbl, comma,
pp_liveness liveness, comma, -- bitmap liveness mask
pp_srt_info srt, -- SRT
- ptext type_str, comma,
+ closure_type, comma,
ppLocalness lbl, comma
],
nest 2 (sep (punctuate comma (map ppr_item amodes))),
ppr_item item = (<>) (text "(F_) ") (ppr_amode item)
size = length amodes
- type_str = case liveness of
- LvSmall _ -> SLIT("RET_VEC_SMALL")
- LvLarge _ -> SLIT("RET_VEC_BIG")
+ closure_type = pp_liveness_switch liveness
+ (ptext SLIT("RET_VEC_SMALL"))
+ (ptext SLIT("RET_VEC_BIG"))
pprAbsC stmt@(CModuleInitBlock lbl code) _
%************************************************************************
\begin{code}
+pp_bitmap_switch :: [BitSet] -> SDoc -> SDoc -> SDoc
+pp_bitmap_switch ([ ]) small large = small
+pp_bitmap_switch ([_ ]) small large = small
+pp_bitmap_switch ([_,_]) small large = hcat
+ [ptext SLIT("BITMAP_SWITCH64"), lparen, small, comma, large, rparen]
+pp_bitmap_switch (_ ) small large = large
+
+pp_liveness_switch :: Liveness -> SDoc -> SDoc -> SDoc
+pp_liveness_switch (Liveness lbl mask) = pp_bitmap_switch mask
+
+pp_bitset :: BitSet -> SDoc
+pp_bitset s
+ | i < -1 = int (i + 1) <> text "-1"
+ | otherwise = int i
+ where i = intBS s
+
+pp_bitmap :: [BitSet] -> SDoc
+pp_bitmap [] = int 0
+pp_bitmap ss = hcat (punctuate delayed_comma (bundle ss)) where
+ delayed_comma = hcat [space, ptext SLIT("COMMA"), space]
+ bundle [] = []
+ bundle [s] = [hcat bitmap32]
+ where bitmap32 = [ptext SLIT("BITMAP32"), lparen,
+ pp_bitset s, rparen]
+ bundle (s1:s2:ss) = hcat bitmap64 : bundle ss
+ where bitmap64 = [ptext SLIT("BITMAP64"), lparen,
+ pp_bitset s1, comma, pp_bitset s2, rparen]
+
pp_liveness :: Liveness -> SDoc
-pp_liveness lv =
- case lv of
- LvLarge lbl -> char '&' <> pprCLabel lbl
- LvSmall mask -- Avoid gcc bug when printing minInt
- | bitmap_int == minInt -> int (bitmap_int+1) <> text "-1"
- | otherwise -> int bitmap_int
- where
- bitmap_int = intBS mask
+pp_liveness (Liveness lbl mask)
+ = pp_bitmap_switch mask (pp_bitmap mask) (char '&' <> pprCLabel lbl)
\end{code}
%************************************************************************
%* *
%************************************************************************
-ToDo: remove the dependency on 32-bit words.
-
There are four kinds of things on the stack:
- pointer variables (bound in the environment)
where (this,rest) = span (<32) slots
livenessToAbsC :: Unique -> LivenessMask -> FCode Liveness
-livenessToAbsC uniq [] = returnFC (LvSmall emptyBS)
-livenessToAbsC uniq [one] = returnFC (LvSmall one)
-livenessToAbsC uniq many =
- absC (CBitmap lbl many) `thenC`
- returnFC (LvLarge lbl)
+livenessToAbsC uniq mask =
+ absC (CBitmap lbl mask) `thenC`
+ returnFC (Liveness lbl mask)
where lbl = mkBitmapLabel uniq
\end{code}
import StgSyn ( StgOp(..) )
import PrimOp ( primOpNeedsWrapper, PrimOp(..) )
import PrimRep ( isFloatingRep, PrimRep(..) )
-import StixInfo ( genCodeInfoTable, genBitmapInfoTable )
+import StixInfo ( genCodeInfoTable, genBitmapInfoTable,
+ livenessIsSmall, bitmapToIntegers )
import StixMacro ( macroCode, checkCode )
import StixPrim ( primCode, foreignCallCode, amodeToStix, amodeToStix' )
import Outputable ( pprPanic, ppr )
import Panic ( panic )
import TyCon ( tyConDataCons )
import DataCon ( dataConWrapId )
-import BitSet ( intBS )
import Name ( NamedThing(..) )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
where
lbl_info = mkReturnInfoLabel uniq
lbl_ret = mkReturnPtLabel uniq
- closure_type = case liveness of
- LvSmall _ -> rET_SMALL
- LvLarge _ -> rET_BIG
+ closure_type = if livenessIsSmall liveness then rET_SMALL else rET_BIG
gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _)
= StCLbl label
gentopcode stmt@(CBitmap lbl mask)
- = returnUs [ StSegment TextSegment
- , StLabel lbl
- , StData WordRep (StInt (toInteger (length mask)) :
- map (StInt . toInteger . intBS) mask)
- ]
+ = returnUs $ case bitmapToIntegers mask of
+ mask'@(_:_:_) ->
+ [ StSegment TextSegment
+ , StLabel lbl
+ , StData WordRep (map StInt (toInteger (length mask') : mask'))
+ ]
+ _ -> []
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
returnUs (\xs -> vectbl : itbl xs)
where
vectbl = StData PtrRep (reverse (map a2stix amodes))
- closure_type = case liveness of
- LvSmall _ -> rET_VEC_SMALL
- LvLarge _ -> rET_VEC_BIG
+ closure_type = if livenessIsSmall liveness then rET_VEC_SMALL else rET_VEC_BIG
\end{code}
%
\begin{code}
-module StixInfo ( genCodeInfoTable, genBitmapInfoTable ) where
+module StixInfo (
+
+ genCodeInfoTable, genBitmapInfoTable,
+
+ bitmapToIntegers, bitmapIsSmall, livenessIsSmall
+
+ ) where
#include "HsVersions.h"
#include "../includes/config.h"
+#include "NCG.h"
import AbsCSyn ( AbstractC(..), Liveness(..) )
import CLabel ( CLabel )
import SMRep ( getSMRepClosureTypeInt )
import Stix -- all of it
import UniqSupply ( returnUs, UniqSM )
-import BitSet ( intBS )
+import BitSet ( BitSet, intBS )
import Maybes ( maybeToBool )
import Bits
]
layout_info = case liveness of
- LvSmall mask -> StInt (toInteger (intBS mask))
- LvLarge lbl -> StCLbl lbl
+ Liveness lbl mask ->
+ case bitmapToIntegers mask of
+ [ ] -> StInt 0
+ [i] -> StInt i
+ _ -> StCLbl lbl
type_info :: Word32
#ifdef WORDS_BIGENDIAN
(lbl, SRT off len) ->
(StIndex DataPtrRep (StCLbl lbl)
(StInt (toInteger off)), len)
+
+bitmapToIntegers :: [BitSet] -> [Integer]
+bitmapToIntegers = bundle . map (toInteger . intBS)
+ where
+#if BYTES_PER_WORD == 4
+ bundle = id
+#else
+ bundle [] = []
+ bundle is = case splitAt (BYTES_PER_WORD/4) is of
+ (these, those) ->
+ ( foldr1 (\x y -> x + 4294967296 * y)
+ [x `mod` 4294967296 | x <- these]
+ : bundle those
+ )
+#endif
+
+bitmapIsSmall :: [BitSet] -> Bool
+bitmapIsSmall bitmap
+ = case bitmapToIntegers bitmap of
+ _:_:_ -> False
+ _ -> True
+
+livenessIsSmall :: Liveness -> Bool
+livenessIsSmall (Liveness _ mask) = bitmapIsSmall mask
\end{code}
/* ----------------------------------------------------------------------------
- * $Id: InfoMacros.h,v 1.15 2001/07/23 23:14:58 ken Exp $
+ * $Id: InfoMacros.h,v 1.16 2001/07/24 05:04:58 ken Exp $
*
* (c) The GHC Team, 1998-1999
*
#define SRT(lbl) \
static const StgSRT lbl = {
-#define BITMAP(lbl,size) \
- static const StgLargeBitmap lbl = { size, {
+#define BITMAP(lbl,size,contents) \
+ static const StgLargeBitmap lbl = { size, { contents } };
+
+#if SIZEOF_VOID_P == 8
+#define BITMAP_SWITCH64(small, large) small
+#define BITMAP64(first, second) \
+ (((StgWord32)(first)) | ((StgWord)(StgWord32)(second) << 32))
+#else
+#define BITMAP_SWITCH64(small, large) large
+#define BITMAP64(first, second) first, second
+#endif
+#define BITMAP32(x) ((StgWord32)(x))
+#define COMMA ,
/* DLL_SRT_ENTRY is used on the Win32 side when filling initialising
an entry in an SRT table with a reference to a closure that's
/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.104 2001/07/23 17:23:19 simonmar Exp $
+ * $Id: GC.c,v 1.105 2001/07/24 05:04:58 ken Exp $
*
* (c) The GHC Team 1998-1999
*
{
StgPtr q;
const StgInfoTable* info;
- StgWord32 bitmap;
+ StgWord bitmap;
//IF_DEBUG(sanity, belch(" scavenging stack between %p and %p", p, stack_end));
scavenge_srt(info);
continue;
- // large bitmap (> 32 entries)
+ // large bitmap (> 32 entries, or > 64 on a 64-bit machine)
case RET_BIG:
case RET_VEC_BIG:
{
for (i=0; i<large_bitmap->size; i++) {
bitmap = large_bitmap->bitmap[i];
- q = p + sizeof(W_) * 8;
+ q = p + BITS_IN(W_);
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
(StgClosure *)*p = evacuate((StgClosure *)*p);
/* -----------------------------------------------------------------------------
- * $Id: Sanity.c,v 1.28 2001/07/23 17:23:19 simonmar Exp $
+ * $Id: Sanity.c,v 1.29 2001/07/24 05:04:59 ken Exp $
*
* (c) The GHC Team, 1998-2001
*
static StgOffset checkStackClosure ( StgClosure* c );
static StgOffset checkStackObject ( StgPtr sp );
-static StgOffset checkSmallBitmap ( StgPtr payload, StgWord32 bitmap );
+static StgOffset checkSmallBitmap ( StgPtr payload, StgWord bitmap );
static StgOffset checkLargeBitmap ( StgPtr payload, StgLargeBitmap* );
static void checkClosureShallow ( StgClosure* p );
-------------------------------------------------------------------------- */
static StgOffset
-checkSmallBitmap( StgPtr payload, StgWord32 bitmap )
+checkSmallBitmap( StgPtr payload, StgWord bitmap )
{
StgOffset i;
static StgOffset
checkLargeBitmap( StgPtr payload, StgLargeBitmap* large_bitmap )
{
- StgWord32 bmp;
+ StgWord bmp;
StgOffset i;
i = 0;
for (bmp=0; bmp<large_bitmap->size; bmp++) {
- StgWord32 bitmap = large_bitmap->bitmap[bmp];
+ StgWord bitmap = large_bitmap->bitmap[bmp];
for(; bitmap != 0; ++i, bitmap >>= 1 ) {
if ((bitmap & 1) == 0) {
checkClosure((StgClosure *)payload[i]);
/*
Time-stamp: <Wed Mar 21 2001 16:32:47 Stardate: [-30]6363.44 hwloidl>
- $Id: Pack.c,v 1.7 2001/05/28 07:13:54 sof Exp $
+ $Id: Pack.c,v 1.8 2001/07/24 05:04:59 ken Exp $
Graph packing and unpacking code for sending it to another processor
and retrieving the original graph structure from the packet.
nat n, i, j, pack_start;
StgPtr p, q;
const StgInfoTable* info;
- StgWord32 bitmap;
+ StgWord bitmap;
/* debugging only */
StgPtr end;
nat size, ptrs, nonptrs, vhs;
for (j=0; j<large_bitmap->size; j++) {
bitmap = large_bitmap->bitmap[j];
- q = p + sizeof(W_) * 8;
+ q = p + BITS_IN(W_);
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
Pack((StgWord)(ARGTAG_MAX+1));
nat n, i, j, packed_size = 0;
StgPtr p, q, end, payload_start, p_FMs;
const StgInfoTable* info;
- StgWord32 bitmap;
+ StgWord bitmap;
StgWord **bufptr = *bufptrP;
#if defined(DEBUG)
nat FMs_in_PAP=0;
for (j=0; j<large_bitmap->size; j++) {
bitmap = large_bitmap->bitmap[j];
- q = p + sizeof(W_) * 8;
+ q = p + BITS_IN(W_);
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
*p++ = (StgWord)UnpackFetchMe(&bufptr, (StgClosure**)&p_FMs);
projects / ghc-hetmet.git / commitdiff