From 52c078343e70a170441fed71480ba8569475c4cd Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 8 Aug 2001 10:50:37 +0000 Subject: [PATCH] [project @ 2001-08-08 10:50:36 by simonmar] Had a brainwave on the way to work this morning, and realised that the garbage collector can handle "pinned objects" as long as they don't contain any pointers. This is absolutely ideal for doing temporary allocation in the FFI, because what we really want to do is allocate a pinned ByteArray and let the GC clean it up later. So this set of changes adds the required framework. There are two new primops: newPinnedByteArray# :: Int# -> State# s -> (# State# s, MutByteArr# s #) byteArrayContents# :: ByteArr# -> Addr# obviously byteArrayContents# is highly unsafe. Allocating a pinned ByteArr# isn't the default, because a pinned ByteArr# will hold an entire block (currently 4k) live until it is garbage collected (that doesn't mean each pinned ByteArr# requires 4k of storage, just that if a block contains a single live pinned ByteArray, the whole block must be retained). --- ghc/compiler/prelude/primops.txt.pp | 8 ++++- ghc/includes/PrimOps.h | 7 +++- ghc/lib/std/PrelGHC.hi-boot.pp | 4 +-- ghc/rts/GC.c | 5 ++- ghc/rts/PrimOps.hc | 20 ++++++++++- ghc/rts/Storage.c | 67 +++++++++++++++++++++++++++++++++-- ghc/rts/Storage.h | 27 ++++++++++---- ghc/rts/StoragePriv.h | 3 +- 8 files changed, 125 insertions(+), 16 deletions(-) diff --git a/ghc/compiler/prelude/primops.txt.pp b/ghc/compiler/prelude/primops.txt.pp index 4440d75..0eecfc6 100644 --- a/ghc/compiler/prelude/primops.txt.pp +++ b/ghc/compiler/prelude/primops.txt.pp @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt.pp,v 1.1 2001/08/04 06:19:54 ken Exp $ +-- $Id: primops.txt.pp,v 1.2 2001/08/08 10:50:36 simonmar Exp $ -- -- Primitive Operations -- @@ -534,6 +534,12 @@ primop NewByteArrayOp_Char "newByteArray#" GenPrimOp Int# -> State# s -> (# State# s, MutByteArr# s #) with out_of_line = True +primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp + Int# -> State# s -> (# State# s, MutByteArr# s #) + with out_of_line = True + +primop ByteArrayContents_Char "byteArrayContents#" GenPrimOp + ByteArr# -> Addr# primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp ByteArr# -> Int# -> Char# diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index a163ade..a33db9c 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.79 2001/07/24 06:31:35 ken Exp $ + * $Id: PrimOps.h,v 1.80 2001/08/08 10:50:37 simonmar Exp $ * * (c) The GHC Team, 1998-2000 * @@ -664,8 +664,13 @@ EXTFUN_RTS(unsafeThawArrayzh_fast); /* and the out-of-line ones... */ EXTFUN_RTS(newByteArrayzh_fast); +EXTFUN_RTS(newPinnedByteArrayzh_fast); EXTFUN_RTS(newArrayzh_fast); +// Highly unsafe, for use with a pinned ByteArray +// being kept alive with touch# +#define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) + /* encoding and decoding of floats/doubles. */ /* We only support IEEE floating point format */ diff --git a/ghc/lib/std/PrelGHC.hi-boot.pp b/ghc/lib/std/PrelGHC.hi-boot.pp index c577efd..3dbacc3 100644 --- a/ghc/lib/std/PrelGHC.hi-boot.pp +++ b/ghc/lib/std/PrelGHC.hi-boot.pp @@ -228,12 +228,12 @@ __export PrelGHC ByteArrayzh MutableArrayzh MutableByteArrayzh - sameMutableArrayzh sameMutableByteArrayzh - newArrayzh newByteArrayzh + newPinnedByteArrayzh + byteArrayContentszh indexArrayzh indexCharArrayzh diff --git a/ghc/rts/GC.c b/ghc/rts/GC.c index c6f5853..98c982f 100644 --- a/ghc/rts/GC.c +++ b/ghc/rts/GC.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: GC.c,v 1.115 2001/08/07 10:49:49 simonmar Exp $ + * $Id: GC.c,v 1.116 2001/08/08 10:50:37 simonmar Exp $ * * (c) The GHC Team 1998-1999 * @@ -794,6 +794,9 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) alloc_HpLim = NULL; alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize; + // Start a new pinned_object_block + pinned_object_block = NULL; + /* Free the mark stack. */ if (mark_stack_bdescr != NULL) { diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 6894b26..364e20a 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.82 2001/07/26 03:08:39 ken Exp $ + * $Id: PrimOps.hc,v 1.83 2001/08/08 10:50:37 simonmar Exp $ * * (c) The GHC Team, 1998-2000 * @@ -263,6 +263,24 @@ FN_(newByteArrayzh_fast) \ FE_ \ } +FN_(newPinnedByteArrayzh_fast) \ + { \ + W_ size, stuff_size, n; \ + StgArrWords* p; \ + FB_ \ + MAYBE_GC(NO_PTRS,newPinnedByteArrayzh_fast); \ + n = R1.w; \ + stuff_size = BYTES_TO_STGWORDS(n); \ + size = sizeofW(StgArrWords)+ stuff_size; \ + p = (StgArrWords *)RET_STGCALL1(P_,allocatePinned,size); \ + TICK_ALLOC_PRIM(sizeofW(StgArrWords),stuff_size,0); \ + SET_HDR(p, &stg_ARR_WORDS_info, CCCS); \ + p->words = stuff_size; \ + TICK_RET_UNBOXED_TUP(1) \ + RET_P(p); \ + FE_ \ + } + FN_(newArrayzh_fast) { W_ size, n, init; diff --git a/ghc/rts/Storage.c b/ghc/rts/Storage.c index b8de7d3..0c5a815 100644 --- a/ghc/rts/Storage.c +++ b/ghc/rts/Storage.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Storage.c,v 1.43 2001/08/07 09:20:52 simonmar Exp $ + * $Id: Storage.c,v 1.44 2001/08/08 10:50:37 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -29,6 +29,7 @@ StgClosure *caf_list = NULL; bdescr *small_alloc_list; /* allocate()d small objects */ bdescr *large_alloc_list; /* allocate()d large objects */ +bdescr *pinned_object_block; /* allocate pinned objects into this block */ nat alloc_blocks; /* number of allocate()d blocks since GC */ nat alloc_blocks_lim; /* approximate limit on alloc_blocks */ @@ -408,7 +409,7 @@ resizeNursery ( nat blocks ) -------------------------------------------------------------------------- */ StgPtr -allocate(nat n) +allocate( nat n ) { bdescr *bd; StgPtr p; @@ -459,11 +460,71 @@ allocate(nat n) return p; } -lnat allocated_bytes(void) +lnat +allocated_bytes( void ) { return (alloc_blocks * BLOCK_SIZE_W - (alloc_HpLim - alloc_Hp)); } +/* --------------------------------------------------------------------------- + Allocate a fixed/pinned object. + + We allocate small pinned objects into a single block, allocating a + new block when the current one overflows. The block is chained + onto the large_object_list of generation 0 step 0. + + NOTE: The GC can't in general handle pinned objects. This + interface is only safe to use for ByteArrays, which have no + pointers and don't require scavenging. It works because the + block's descriptor has the BF_LARGE flag set, so the block is + treated as a large object and chained onto various lists, rather + than the individual objects being copied. However, when it comes + to scavenge the block, the GC will only scavenge the first object. + The reason is that the GC can't linearly scan a block of pinned + objects at the moment (doing so would require using the + mostly-copying techniques). But since we're restricting ourselves + to pinned ByteArrays, not scavenging is ok. + + This function is called by newPinnedByteArray# which immediately + fills the allocated memory with a MutableByteArray#. + ------------------------------------------------------------------------- */ + +StgPtr +allocatePinned( nat n ) +{ + StgPtr p; + bdescr *bd = pinned_object_block; + + ACQUIRE_LOCK(&sm_mutex); + + TICK_ALLOC_HEAP_NOCTR(n); + CCS_ALLOC(CCCS,n); + + // If the request is for a large object, then allocate() + // will give us a pinned object anyway. + if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) { + RELEASE_LOCK(&sm_mutex); + return allocate(n); + } + + // If we don't have a block of pinned objects yet, or the current + // one isn't large enough to hold the new object, allocate a new one. + if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) { + pinned_object_block = bd = allocBlock(); + dbl_link_onto(bd, &g0s0->large_objects); + bd->gen_no = 0; + bd->step = g0s0; + bd->flags = BF_LARGE; + bd->free = bd->start; + alloc_blocks++; + } + + p = bd->free; + bd->free += n; + RELEASE_LOCK(&sm_mutex); + return p; +} + /* ----------------------------------------------------------------------------- Allocation functions for GMP. diff --git a/ghc/rts/Storage.h b/ghc/rts/Storage.h index d4eaaac..1156dd4 100644 --- a/ghc/rts/Storage.h +++ b/ghc/rts/Storage.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Storage.h,v 1.35 2001/07/24 06:31:36 ken Exp $ + * $Id: Storage.h,v 1.36 2001/08/08 10:50:37 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -24,12 +24,24 @@ extern void exitStorage(void); /* ----------------------------------------------------------------------------- Generic allocation - StgPtr allocate(int n) Allocates a chunk of contiguous store + StgPtr allocate(nat n) Allocates a chunk of contiguous store n words long, returning a pointer to the first word. Always succeeds. + StgPtr allocatePinned(nat n) Allocates a chunk of contiguous store + n words long, which is at a fixed + address (won't be moved by GC). + Returns a pointer to the first word. + Always succeeds. + + NOTE: the GC can't in general handle + pinned objects, so allocatePinned() + can only be used for ByteArrays at the + moment. + Don't forget to TICK_ALLOC_XXX(...) - after calling allocate, for the + after calling allocate or + allocatePinned, for the benefit of the ticky-ticky profiler. rtsBool doYouWantToGC(void) Returns True if the storage manager is @@ -43,12 +55,15 @@ extern void exitStorage(void); surrounded by a mutex. -------------------------------------------------------------------------- */ -extern StgPtr allocate(nat n); -static inline rtsBool doYouWantToGC(void) +extern StgPtr allocate ( nat n ); +extern StgPtr allocatePinned ( nat n ); +extern lnat allocated_bytes ( void ); + +static inline rtsBool +doYouWantToGC( void ) { return (alloc_blocks >= alloc_blocks_lim); } -extern lnat allocated_bytes(void); /* ----------------------------------------------------------------------------- ExtendNursery(hp,hplim) When hplim is reached, try to grab diff --git a/ghc/rts/StoragePriv.h b/ghc/rts/StoragePriv.h index 40b606b..add78a4 100644 --- a/ghc/rts/StoragePriv.h +++ b/ghc/rts/StoragePriv.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StoragePriv.h,v 1.16 2001/08/02 15:33:35 ken Exp $ + * $Id: StoragePriv.h,v 1.17 2001/08/08 10:50:37 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -33,6 +33,7 @@ extern StgClosure *caf_list; extern bdescr *small_alloc_list; extern bdescr *large_alloc_list; +extern bdescr *pinned_object_block; extern StgPtr alloc_Hp; extern StgPtr alloc_HpLim; -- 1.7.10.4