suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add phantom byte strings

Browse Source 
A phantom byte string is a small object that the memory
manager treats as an arbitrary-sized object, where the
size is specified when the phantom byte string is created
or or when size is changed via `set-phantom-bytes!'.
This commit is contained in:
Matthew Flatt 2012-12-19 18:30:51 -07:00
parent 67af968a73
commit aa08a68424
14 changed files with 1376 additions and 1127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
collects/scribblings/reference/memory.scrbl
View File

@ -252,3 +252,50 @@ information in a dump. The information that is available depends on
your Racket build; check the end of a dump from a particular build to
see if it offers additional information; otherwise, all @racket[v]s are
ignored.}
@;------------------------------------------------------------------------
@section[#:tag "phantom-bytes"]{Phantom Byte Strings}
A @deftech{phantom byte string} is a small Racket value that is
treated by the Racket memory manager as having an arbitrary size,
which is specified when the @tech{phantom byte string} is created or
when it is changed via @racket[set-phantom-bytes!].
A @tech{phantom byte string} acts as a hint to Racket's memory
manager that memory is allocated within the process but through a
separate allocator, such as through a foreign library that is accessed
via @racketmodname[ffi/unsafe]. This hint is used to trigger
@tech{garbage collections} or to compute the result of
@racket[current-memory-use]. Currently, the hint is used only in
Racket 3m (the main variant of Racket).
@defproc[(phantom-bytes? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{phantom byte string},
@racket[#f] otherwise.}
@defproc[(make-phantom-bytes [k exact-nonnegative-integer?])
phantom-bytes?]{
Creates a @tech{phantom byte string} that is treated by the Racket
memory manager as being @racket[k] bytes in size. For a large enough
@racket[k], the @exnraise[exn:fail:out-of-memory]---either because the
size is implausibly large, or because a memory limit has been
installed with @racket[custodian-limit-memory].}
@defproc[(set-phantom-bytes! [phantom-bstr phantom-bytes?]
[k exact-nonnegative-integer?])
phantom-bytes?]{
Adjusts the size of a @tech{phantom byte string} as it is treated by
the Racket memory manager.
For example, if the memory that @racket[phantom-bstr] represents is
released through a foreign library, then @racket[(set-phantom-bytes!
phantom-bstr 0)] can reflect the change in memory use.
When @racket[k] is larger than the current size of
@racket[phantom-bstr], then this function can raise
@racket[exn:fail:out-of-memory], like @racket[make-phantom-bytes].}

33
collects/tests/racket/will.rktl
View File

@ -185,6 +185,39 @@
(num-or (ephemeron-value (cdr p) 0) 1))))
(test #t < n 50))
;; ----------------------------------------
;; Phantom bytes:
(when (eq? '3m (system-type 'gc))
(define s (make-semaphore))
(define c (make-custodian))
(define t (parameterize ([current-custodian c])
(thread (lambda ()
(semaphore-wait s)
(define b (make-phantom-bytes (expt 2 29)))
(test #t phantom-bytes? b)
(test #f phantom-bytes? 0)
(semaphore-wait s)
(set-phantom-bytes! b 0)
(semaphore-wait s)))))
(sync (system-idle-evt))
(collect-garbage)
(define m (current-memory-use))
(define mc (current-memory-use c))
(semaphore-post s)
(sync (system-idle-evt))
(test #t > (current-memory-use) (+ m (expt 2 28)))
(collect-garbage)
(test #t > (current-memory-use) (+ m (expt 2 28)))
(test #t > (current-memory-use c) (+ mc (expt 2 28)))
(semaphore-post s)
(sync (system-idle-evt))
(test #t < (current-memory-use) (+ m (expt 2 28)))
(collect-garbage)
(test #t < (current-memory-use) (+ m (expt 2 28)))
(test #t < (current-memory-use c) (+ mc (expt 2 28)))
(semaphore-post s))
;; ----------------------------------------
(report-errs)

3
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 5.3.1.10
Added phantom byte strings
Version 5.3.1.9
Changed case to use equal? instead of eqv?
r5rs, r6rs: fixed case and cond to disallow internal definitions

8
src/racket/gc2/gc2.h
View File

@ -91,7 +91,8 @@ GC2_EXTERN void GC_add_roots(void *start, void *end);
`start' (inclusive) and `end' (exclusive) contains pointers. */
GC2_EXTERN void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox,
int ephemeron, int weakarray, int custbox);
int ephemeron, int weakarray, int custbox,
int phantom);
/*
Called by Racket to indicate the number of different type tags it
uses, starting from 0. `count' is always less than 256. The weakbox
@ -276,6 +277,11 @@ GC2_EXTERN int GC_is_on_allocated_page(void *p);
the GC allocates objects (although p may or may not
be a valid pointer to the start of an alloctaed object). */
GC2_EXTERN int GC_allocate_phantom_bytes(intptr_t);
/*
Returns 0 if allocation should fail due to a memory limit,
1 otherwise. */
/***************************************************************************/
/* Memory tracing */
/***************************************************************************/

10
src/racket/gc2/mem_account.c
View File

@ -447,6 +447,9 @@ static void BTC_do_accounting(NewGC *gc)
last = cur;
while(cur) {
int owner = custodian_to_owner_set(gc, cur);
uintptr_t save_count = gc->phantom_count;
gc->phantom_count = 0;
gc->current_mark_owner = owner;
GCDEBUG((DEBUGOUTF,"MARKING THREADS OF OWNER %i (CUST %p)\n", owner, cur));
@ -458,6 +461,10 @@ static void BTC_do_accounting(NewGC *gc)
last = cur;
box = cur->global_next; cur = box ? SCHEME_PTR1_VAL(box) : NULL;
owner_table[owner]->memory_use = add_no_overflow(owner_table[owner]->memory_use,
gcBYTES_TO_WORDS(gc->phantom_count));
gc->phantom_count = save_count;
}
/* walk backward folding totals int parent */
@ -470,7 +477,8 @@ static void BTC_do_accounting(NewGC *gc)
int powner = custodian_to_owner_set(gc, parent);
owner_table = gc->owner_table;
owner_table[powner]->memory_use += owner_table[owner]->memory_use;
owner_table[powner]->memory_use = add_no_overflow(owner_table[powner]->memory_use,
owner_table[owner]->memory_use);
owner_table[powner]->master_memory_use += owner_table[owner]->master_memory_use;
}

103
src/racket/gc2/newgc.c
View File

@ -1492,6 +1492,44 @@ intptr_t GC_alloc_alignment()
intptr_t GC_malloc_stays_put_threshold() { return MAX_OBJECT_SIZE; }
uintptr_t add_no_overflow(uintptr_t a, uintptr_t b)
{
uintptr_t c = a + b;
if (c < a)
c = (uintptr_t)-1;
return c;
}
int GC_allocate_phantom_bytes(intptr_t request_size_bytes)
{
#ifdef NEWGC_BTC_ACCOUNT
NewGC *gc = GC_get_GC();
if (premaster_or_place_gc(gc)) {
if (BTC_single_allocation_limit(gc, request_size_bytes))
return 0;
}
#endif
if ((request_size_bytes > 0)
&& ((gc->phantom_count + request_size_bytes) < gc->phantom_count))
/* overflow */
return 1;
gc->phantom_count += request_size_bytes;
/* adjust `gc->memory_in_use', but protect against {over,under}flow: */
if (request_size_bytes < 0) {
request_size_bytes = -request_size_bytes;
if (gc->memory_in_use > request_size_bytes)
gc->memory_in_use -= request_size_bytes;
} else
gc->memory_in_use = add_no_overflow(gc->memory_in_use, request_size_bytes);
return 1;
}
void GC_create_message_allocator() {
NewGC *gc = GC_get_GC();
Allocator *a;
@ -1769,8 +1807,10 @@ inline static void master_set_max_size(NewGC *gc)
inline static void reset_nursery(NewGC *gc)
{
uintptr_t new_gen0_size;
new_gen0_size = NUM((GEN0_SIZE_FACTOR * (float)gc->memory_in_use) + GEN0_SIZE_ADDITION);
if(new_gen0_size > GEN0_MAX_SIZE)
if ((new_gen0_size > GEN0_MAX_SIZE)
|| (gc->memory_in_use > GEN0_MAX_SIZE)) /* => overflow */
new_gen0_size = GEN0_MAX_SIZE;
resize_gen0(gc, new_gen0_size);
@ -2206,6 +2246,34 @@ inline static void check_finalizers(NewGC *gc, int level)
#undef is_marked
#undef weak_box_resolve
/*****************************************************************************/
/* phantom bytes and accounting */
/*****************************************************************************/
typedef struct {
short tag;
intptr_t count;
} Phantom_Bytes;
static int size_phantom(void *p, struct NewGC *gc)
{
return gcBYTES_TO_WORDS(sizeof(Phantom_Bytes));
}
static int mark_phantom(void *p, struct NewGC *gc)
{
Phantom_Bytes *pb = (Phantom_Bytes *)p;
gc->phantom_count = add_no_overflow(gc->phantom_count, pb->count);
return gcBYTES_TO_WORDS(sizeof(Phantom_Bytes));
}
static int fixup_phantom(void *p, struct NewGC *gc)
{
return gcBYTES_TO_WORDS(sizeof(Phantom_Bytes));
}
/*****************************************************************************/
/* Internal Stack Routines */
/*****************************************************************************/
@ -2729,7 +2797,9 @@ static void NewGC_initialize(NewGC *newgc, NewGC *inheritgc, NewGC *parentgc) {
/* NOTE This method sets the constructed GC as the new Thread Specific GC. */
static NewGC *init_type_tags_worker(NewGC *inheritgc, NewGC *parentgc,
int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox)
int count, int pair, int mutable_pair, int weakbox,
int ephemeron, int weakarray,
int custbox, int phantom)
{
NewGC *gc;
@ -2744,6 +2814,7 @@ static NewGC *init_type_tags_worker(NewGC *inheritgc, NewGC *parentgc,
# ifdef NEWGC_BTC_ACCOUNT
gc->cust_box_tag = custbox;
# endif
gc->phantom_tag = phantom;
NewGC_initialize(gc, inheritgc, parentgc);
@ -2763,6 +2834,7 @@ static NewGC *init_type_tags_worker(NewGC *inheritgc, NewGC *parentgc,
GC_register_traversers2(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0);
GC_register_traversers2(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0);
GC_register_traversers2(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
GC_register_traversers2(gc->phantom_tag, size_phantom, mark_phantom, fixup_phantom, 0, 0);
}
initialize_signal_handler(gc);
GC_add_roots(&gc->park, (char *)&gc->park + sizeof(gc->park) + 1);
@ -2771,13 +2843,15 @@ static NewGC *init_type_tags_worker(NewGC *inheritgc, NewGC *parentgc,
return gc;
}
void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray, int custbox)
void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int ephemeron, int weakarray,
int custbox, int phantom)
{
static int initialized = 0;
if (!initialized) {
initialized = 1;
init_type_tags_worker(NULL, NULL, count, pair, mutable_pair, weakbox, ephemeron, weakarray, custbox);
init_type_tags_worker(NULL, NULL, count, pair, mutable_pair, weakbox, ephemeron, weakarray,
custbox, phantom);
} else {
GCPRINT(GCOUTF, "GC_init_type_tags should only be called once!\n");
abort();
@ -2791,7 +2865,8 @@ struct NewGC *GC_get_current_instance() {
#ifdef MZ_USE_PLACES
void GC_construct_child_gc(struct NewGC *parent_gc, intptr_t limit) {
NewGC *gc = MASTERGC;
NewGC *newgc = init_type_tags_worker(gc, parent_gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag);
NewGC *newgc = init_type_tags_worker(gc, parent_gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag,
gc->weak_array_tag, gc->cust_box_tag, gc->phantom_tag);
newgc->primoridal_gc = MASTERGC;
newgc->dont_master_gc_until_child_registers = 1;
if (limit)
@ -2972,19 +3047,20 @@ void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark,
intptr_t GC_get_memory_use(void *o)
{
NewGC *gc = GC_get_GC();
intptr_t amt;
uintptr_t amt;
#ifdef NEWGC_BTC_ACCOUNT
if (o) {
return BTC_get_memory_use(gc, o);
}
#endif
amt = gen0_size_in_use(gc) + gc->memory_in_use;
amt = add_no_overflow(gen0_size_in_use(gc), gc->memory_in_use);
#ifdef MZ_USE_PLACES
mzrt_mutex_lock(gc->child_total_lock);
amt += gc->child_gc_total;
amt = add_no_overflow(amt, gc->child_gc_total);
mzrt_mutex_unlock(gc->child_total_lock);
#endif
return amt;
return (intptr_t)amt;
}
/*****************************************************************************/
@ -4255,7 +4331,7 @@ inline static void gen0_free_big_pages(NewGC *gc) {
static void clean_up_heap(NewGC *gc)
{
int i;
size_t memory_in_use = 0;
uintptr_t memory_in_use = 0;
PageMap pagemap = gc->page_maps;
gen0_free_big_pages(gc);
@ -4346,6 +4422,8 @@ static void clean_up_heap(NewGC *gc)
gc->med_freelist_pages[i] = prev;
}
memory_in_use = add_no_overflow(memory_in_use, gc->phantom_count);
gc->memory_in_use = memory_in_use;
cleanup_vacated_pages(gc);
}
@ -4533,6 +4611,9 @@ static void garbage_collect(NewGC *gc, int force_full, int switching_master, Log
gc->in_unsafe_allocation_mode = 1;
gc->unsafe_allocation_abort = out_of_memory_gc;
if (gc->gc_full)
gc->phantom_count = 0;
TIME_INIT();
/* inform the system (if it wants us to) that we're starting collection */
@ -4811,7 +4892,7 @@ intptr_t GC_propagate_hierarchy_memory_use()
}
#endif
return gc->memory_in_use + gc->child_gc_total;
return add_no_overflow(gc->memory_in_use, gc->child_gc_total);
}
#if MZ_GC_BACKTRACE

5
src/racket/gc2/newgc.h
View File

@ -231,6 +231,9 @@ typedef struct NewGC {
unsigned short weak_box_tag;
unsigned short ephemeron_tag;
unsigned short cust_box_tag;
unsigned short phantom_tag;
uintptr_t phantom_count;
Roots roots;
GC_Weak_Array *weak_arrays;
@ -246,7 +249,7 @@ typedef struct NewGC {
intptr_t previously_reported_total; /* how much we previously reported to the parent */
mzrt_mutex *child_total_lock; /* lock on `child_gc_total' */
#endif
intptr_t child_gc_total;
uintptr_t child_gc_total;
uintptr_t place_memory_limit; /* set to propagate a custodian limit from a parent place */

2062
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

2
src/racket/src/salloc.c
View File

@ -113,7 +113,7 @@ void scheme_set_stack_base(void *base, int no_auto_statics) XFORM_SKIP_PROC
GC_init_type_tags(_scheme_last_type_,
scheme_pair_type, scheme_mutable_pair_type, scheme_weak_box_type,
scheme_ephemeron_type, scheme_rt_weak_array,
scheme_cust_box_type);
scheme_cust_box_type, scheme_phantom_bytes_type);
/* We want to be able to allocate symbols early. */
scheme_register_traversers();
#endif

2
src/racket/src/schminc.h
View File

@ -14,7 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1073
#define EXPECTED_PRIM_COUNT 1076
#define EXPECTED_UNSAFE_COUNT 80
#define EXPECTED_FLFXNUM_COUNT 69
#define EXPECTED_FUTURES_COUNT 15

4
src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.1.9"
#define MZSCHEME_VERSION "5.3.1.10"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 9
#define MZSCHEME_VERSION_W 10
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

147
src/racket/src/stypes.h
View File

@ -200,83 +200,84 @@ enum {
scheme_port_closed_evt_type, /* 180 */
scheme_proc_shape_type, /* 181 */
scheme_struct_proc_shape_type, /* 182 */
scheme_phantom_bytes_type, /* 183 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 183 */
_scheme_last_normal_type_, /* 184 */
scheme_rt_weak_array, /* 184 */
scheme_rt_weak_array, /* 185 */
scheme_rt_comp_env, /* 185 */
scheme_rt_constant_binding, /* 186 */
scheme_rt_resolve_info, /* 187 */
scheme_rt_unresolve_info, /* 188 */
scheme_rt_optimize_info, /* 189 */
scheme_rt_compile_info, /* 190 */
scheme_rt_cont_mark, /* 191 */
scheme_rt_saved_stack, /* 192 */
scheme_rt_reply_item, /* 193 */
scheme_rt_closure_info, /* 194 */
scheme_rt_overflow, /* 195 */
scheme_rt_overflow_jmp, /* 196 */
scheme_rt_meta_cont, /* 197 */
scheme_rt_dyn_wind_cell, /* 198 */
scheme_rt_dyn_wind_info, /* 199 */
scheme_rt_dyn_wind, /* 200 */
scheme_rt_dup_check, /* 201 */
scheme_rt_thread_memory, /* 202 */
scheme_rt_input_file, /* 203 */
scheme_rt_input_fd, /* 204 */
scheme_rt_oskit_console_input, /* 205 */
scheme_rt_tested_input_file, /* 206 */
scheme_rt_tested_output_file, /* 207 */
scheme_rt_indexed_string, /* 208 */
scheme_rt_output_file, /* 209 */
scheme_rt_load_handler_data, /* 210 */
scheme_rt_pipe, /* 211 */
scheme_rt_beos_process, /* 212 */
scheme_rt_system_child, /* 213 */
scheme_rt_tcp, /* 214 */
scheme_rt_write_data, /* 215 */
scheme_rt_tcp_select_info, /* 216 */
scheme_rt_param_data, /* 217 */
scheme_rt_will, /* 218 */
scheme_rt_linker_name, /* 219 */
scheme_rt_param_map, /* 220 */
scheme_rt_finalization, /* 221 */
scheme_rt_finalizations, /* 222 */
scheme_rt_cpp_object, /* 223 */
scheme_rt_cpp_array_object, /* 224 */
scheme_rt_stack_object, /* 225 */
scheme_rt_preallocated_object, /* 226 */
scheme_thread_hop_type, /* 227 */
scheme_rt_srcloc, /* 228 */
scheme_rt_evt, /* 229 */
scheme_rt_syncing, /* 230 */
scheme_rt_comp_prefix, /* 231 */
scheme_rt_user_input, /* 232 */
scheme_rt_user_output, /* 233 */
scheme_rt_compact_port, /* 234 */
scheme_rt_read_special_dw, /* 235 */
scheme_rt_regwork, /* 236 */
scheme_rt_rx_lazy_string, /* 237 */
scheme_rt_buf_holder, /* 238 */
scheme_rt_parameterization, /* 239 */
scheme_rt_print_params, /* 240 */
scheme_rt_read_params, /* 241 */
scheme_rt_native_code, /* 242 */
scheme_rt_native_code_plus_case, /* 243 */
scheme_rt_jitter_data, /* 244 */
scheme_rt_module_exports, /* 245 */
scheme_rt_delay_load_info, /* 246 */
scheme_rt_marshal_info, /* 247 */
scheme_rt_unmarshal_info, /* 248 */
scheme_rt_runstack, /* 249 */
scheme_rt_sfs_info, /* 250 */
scheme_rt_validate_clearing, /* 251 */
scheme_rt_avl_node, /* 252 */
scheme_rt_lightweight_cont, /* 253 */
scheme_rt_export_info, /* 254 */
scheme_rt_cont_jmp, /* 255 */
scheme_rt_comp_env, /* 186 */
scheme_rt_constant_binding, /* 187 */
scheme_rt_resolve_info, /* 188 */
scheme_rt_unresolve_info, /* 189 */
scheme_rt_optimize_info, /* 190 */
scheme_rt_compile_info, /* 191 */
scheme_rt_cont_mark, /* 192 */
scheme_rt_saved_stack, /* 193 */
scheme_rt_reply_item, /* 194 */
scheme_rt_closure_info, /* 195 */
scheme_rt_overflow, /* 196 */
scheme_rt_overflow_jmp, /* 197 */
scheme_rt_meta_cont, /* 198 */
scheme_rt_dyn_wind_cell, /* 199 */
scheme_rt_dyn_wind_info, /* 200 */
scheme_rt_dyn_wind, /* 201 */
scheme_rt_dup_check, /* 202 */
scheme_rt_thread_memory, /* 203 */
scheme_rt_input_file, /* 204 */
scheme_rt_input_fd, /* 205 */
scheme_rt_oskit_console_input, /* 206 */
scheme_rt_tested_input_file, /* 207 */
scheme_rt_tested_output_file, /* 208 */
scheme_rt_indexed_string, /* 209 */
scheme_rt_output_file, /* 210 */
scheme_rt_load_handler_data, /* 211 */
scheme_rt_pipe, /* 212 */
scheme_rt_beos_process, /* 213 */
scheme_rt_system_child, /* 214 */
scheme_rt_tcp, /* 215 */
scheme_rt_write_data, /* 216 */
scheme_rt_tcp_select_info, /* 217 */
scheme_rt_param_data, /* 218 */
scheme_rt_will, /* 219 */
scheme_rt_linker_name, /* 220 */
scheme_rt_param_map, /* 221 */
scheme_rt_finalization, /* 222 */
scheme_rt_finalizations, /* 223 */
scheme_rt_cpp_object, /* 224 */
scheme_rt_cpp_array_object, /* 225 */
scheme_rt_stack_object, /* 226 */
scheme_rt_preallocated_object, /* 227 */
scheme_thread_hop_type, /* 228 */
scheme_rt_srcloc, /* 229 */
scheme_rt_evt, /* 230 */
scheme_rt_syncing, /* 231 */
scheme_rt_comp_prefix, /* 232 */
scheme_rt_user_input, /* 233 */
scheme_rt_user_output, /* 234 */
scheme_rt_compact_port, /* 235 */
scheme_rt_read_special_dw, /* 236 */
scheme_rt_regwork, /* 237 */
scheme_rt_rx_lazy_string, /* 238 */
scheme_rt_buf_holder, /* 239 */
scheme_rt_parameterization, /* 240 */
scheme_rt_print_params, /* 241 */
scheme_rt_read_params, /* 242 */
scheme_rt_native_code, /* 243 */
scheme_rt_native_code_plus_case, /* 244 */
scheme_rt_jitter_data, /* 245 */
scheme_rt_module_exports, /* 246 */
scheme_rt_delay_load_info, /* 247 */
scheme_rt_marshal_info, /* 248 */
scheme_rt_unmarshal_info, /* 249 */
scheme_rt_runstack, /* 250 */
scheme_rt_sfs_info, /* 251 */
scheme_rt_validate_clearing, /* 252 */
scheme_rt_avl_node, /* 253 */
scheme_rt_lightweight_cont, /* 254 */
scheme_rt_export_info, /* 255 */
scheme_rt_cont_jmp, /* 256 */
#endif
_scheme_last_type_

73
src/racket/src/thread.c
View File

@ -271,7 +271,7 @@ extern intptr_t GC_is_place();
#ifdef MZ_PRECISE_GC
extern intptr_t GC_get_memory_use(void *c);
#else
extern MZ_DLLIMPORT long GC_get_memory_use();
extern MZ_DLLIMPORT intptr_t GC_get_memory_use();
#endif
typedef struct Thread_Cell {
@ -316,6 +316,11 @@ SHARED_OK static Proc_Global_Rec *process_globals;
static mzrt_mutex *process_global_lock;
#endif
typedef struct {
Scheme_Object so;
intptr_t size;
} Scheme_Phantom_Bytes;
#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif
@ -392,6 +397,10 @@ static Scheme_Object *current_thread_set(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_thread_initial_stack_size(int argc, Scheme_Object *argv[]);
static Scheme_Object *phantom_bytes_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_phantom_bytes(int argc, Scheme_Object *argv[]);
static Scheme_Object *set_phantom_bytes(int argc, Scheme_Object *argv[]);
static void adjust_custodian_family(void *pr, void *ignored);
static Scheme_Object *make_will_executor(int argc, Scheme_Object *args[]);
@ -579,6 +588,10 @@ void scheme_init_thread(Scheme_Env *env)
GLOBAL_PRIM_W_ARITY("choice-evt" , evts_to_evt , 0, -1, env);
GLOBAL_PARAMETER("current-thread-initial-stack-size", current_thread_initial_stack_size, MZCONFIG_THREAD_INIT_STACK_SIZE, env);
GLOBAL_PRIM_W_ARITY("phantom-bytes?", phantom_bytes_p, 1, 1, env);
GLOBAL_PRIM_W_ARITY("make-phantom-bytes", make_phantom_bytes, 1, 1, env);
GLOBAL_PRIM_W_ARITY("set-phantom-bytes!", set_phantom_bytes, 2, 2, env);
}
void scheme_init_thread_places(void) {
@ -679,7 +692,7 @@ static Scheme_Object *collect_garbage(int c, Scheme_Object *p[])
static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[])
{
Scheme_Object *arg = NULL;
intptr_t retval = 0;
uintptr_t retval = 0;
if (argc) {
if (SCHEME_FALSEP(args[0])) {
@ -700,7 +713,7 @@ static Scheme_Object *current_memory_use(int argc, Scheme_Object *args[])
retval = GC_get_memory_use();
#endif
return scheme_make_integer_value(retval);
return scheme_make_integer_value_from_unsigned(retval);
}
@ -7586,7 +7599,7 @@ Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos,
static Scheme_Object *
exact_positive_integer_p (int argc, Scheme_Object *argv[])
{
Scheme_Object *n = argv[0];
Scheme_Object *n = argv[argc-1];
if (SCHEME_INTP(n) && (SCHEME_INT_VAL(n) > 0))
return scheme_true;
if (SCHEME_BIGNUMP(n) && SCHEME_BIGPOS(n))
@ -7603,6 +7616,58 @@ static Scheme_Object *current_thread_initial_stack_size(int argc, Scheme_Object
-1, exact_positive_integer_p, "exact positive integer", 0);
}
static Scheme_Object *phantom_bytes_p(int argc, Scheme_Object *argv[])
{
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_phantom_bytes_type)
? scheme_true
: scheme_false);
}
static Scheme_Object *make_phantom_bytes(int argc, Scheme_Object *argv[])
{
Scheme_Phantom_Bytes *pb;
if (!scheme_nonneg_exact_p(argv[0]))
scheme_wrong_contract("make-phantom-bytes", "exact-nonnegative-integer?", 0, argc, argv);
if (!SCHEME_INTP(argv[0]))
scheme_raise_out_of_memory("make-phantom-bytes", NULL);
pb = MALLOC_ONE_TAGGED(Scheme_Phantom_Bytes);
pb->so.type = scheme_phantom_bytes_type;
pb->size = SCHEME_INT_VAL(argv[0]);
# ifdef MZ_PRECISE_GC
if (!GC_allocate_phantom_bytes(pb->size))
scheme_raise_out_of_memory("make-phantom-bytes", NULL);
# endif
return (Scheme_Object *)pb;
}
static Scheme_Object *set_phantom_bytes(int argc, Scheme_Object *argv[])
{
Scheme_Phantom_Bytes *pb;
intptr_t amt;
if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_phantom_bytes_type))
scheme_wrong_contract("set-phantom-bytes!", "phantom-bytes?", 0, argc, argv);
if (!scheme_nonneg_exact_p(argv[1]))
scheme_wrong_contract("set-phantom-bytes!", "exact-nonnegative-integer?", 1, argc, argv);
pb = (Scheme_Phantom_Bytes *)argv[0];
amt = SCHEME_INT_VAL(argv[1]);
# ifdef MZ_PRECISE_GC
if (!GC_allocate_phantom_bytes(amt - pb->size))
scheme_raise_out_of_memory("make-phantom-bytes", NULL);
# endif
pb->size = amt;
return scheme_void;
}
/*========================================================================*/
/* namespaces */
/*========================================================================*/

2
src/racket/src/type.c
View File

@ -307,6 +307,8 @@ scheme_init_type ()
set_name(scheme_resolved_module_path_type, "<resolve-module-path>");
set_name(scheme_phantom_bytes_type, "<phantom-bytes>");
#ifdef MZ_GC_BACKTRACE
set_name(scheme_rt_meta_cont, "<meta-continuation>");
#endif