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

sync to trunk

Browse Source 
svn: r17263
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-10 18:35:02 +00:00
commit 314270113a
14 changed files with 141 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "9dec2009")
#lang scheme/base (provide stamp) (define stamp "10dec2009")

34
collects/scheme/private/for.ss
View File

@ -35,6 +35,7 @@
(rename *in-input-port-chars in-input-port-chars)
(rename *in-port in-port)
(rename *in-lines in-lines)
(rename *in-bytes-lines in-bytes-lines)
in-hash
in-hash-keys
in-hash-values
@ -489,6 +490,19 @@
"'linefeed, 'return, 'return-linefeed, 'any, or 'any-one"
mode))
(in-producer (lambda () (read-line p mode)) eof)]))
(define in-bytes-lines
(case-lambda
[() (in-bytes-lines (current-input-port) 'any)]
[(p) (in-bytes-lines p 'any)]
[(p mode)
(unless (input-port? p) (raise-type-error 'in-bytes-lines "input-port" p))
(unless (memq mode '(linefeed return return-linefeed any any-one))
(raise-type-error
'in-bytes-lines
"'linefeed, 'return, 'return-linefeed, 'any, or 'any-one"
mode))
(in-producer (lambda () (read-bytes-line p mode)) eof)]))
(define (in-hash ht)
(unless (hash? ht) (raise-type-error 'in-hash "hash" ht))
@ -1255,6 +1269,26 @@
mode*))
(lambda () (read-line p* mode*)))
eof)]])))
(define-sequence-syntax *in-bytes-lines
(lambda () #'in-bytes-lines)
(lambda (stx)
(syntax-case stx ()
[[(id) (_)] #'[(id) (*in-bytes-lines (current-input-port) 'any)]]
[[(id) (_ p)] #'[(id) (*in-bytes-lines p 'any)]]
[[(id) (_ p mode)]
#'[(id) (*in-producer
(let ([p* p] [mode* mode])
(unless (input-port? p*)
(raise-type-error 'in-bytes-lines "input-port" p*))
(unless (memq mode* '(linefeed return return-linefeed any
any-one))
(raise-type-error
'in-bytes-lines
"'linefeed, 'return, 'return-linefeed, 'any, or 'any-one"
mode*))
(lambda () (read-bytes-line p* mode*)))
eof)]])))
(define-sequence-syntax *in-input-port-bytes
(lambda () #'in-input-port-bytes)

3
collects/scribblings/gui/dialog-funcs.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc
@(require "common.ss")
@(require "common.ss"
(for-label mrlib/path-dialog))
@title{Dialogs}

9
collects/scribblings/reference/sequences.scrbl
View File

@ -167,6 +167,15 @@ Returns a sequence equivalent to @scheme[(in-port (lambda (p)
whereas the default mode of @scheme[read-line] is
@scheme['linefeed]. }
@defproc[(in-bytes-lines [in input-port? (current-input-port)]
[mode (or/c 'linefeed 'return 'return-linefeed 'any 'any-one) 'any])
sequence?]{
Returns a sequence equivalent to @scheme[(in-port (lambda (p)
(read-bytes-line p mode)) in)]. Note that the default mode is @scheme['any],
whereas the default mode of @scheme[read-bytes-line] is
@scheme['linefeed]. }
@defproc[(in-hash [hash hash?]) sequence?]{
Returns a sequence equivalent to @scheme[hash].

3
collects/tests/mzscheme/for.ss
View File

@ -135,6 +135,9 @@
(test-generator [((123) 4)] (in-port read (open-input-string "(123) 4")))
(test-generator [(65 66 67)] (in-port read-byte (open-input-string "ABC")))
(test-generator [("abc" "def")] (in-lines (open-input-string "abc\ndef")))
(test-generator [(#"abc" #"def")] (in-bytes-lines (open-input-string "abc\ndef")))
(test-generator [(0 1 2 3 4 5)] (in-sequences (in-range 6)))
(test-generator [(0 1 2 3 4 5)] (in-sequences (in-range 4) '(4 5)))
(test-generator [(0 1 2 3 4 5)] (in-sequences (in-range 6) '()))

11
src/mzscheme/gc2/gc2.h
View File

@ -410,9 +410,16 @@ GC2_EXTERN void GC_switch_back_from_master(void *gc);
Switches to back to gc from the master GC
*/
GC2_EXTERN unsigned long GC_make_jit_nursery_page();
GC2_EXTERN long GC_alloc_alignment();
/*
Obtains a nursery page from the GC for thread local allocation.
Guaranteeed alignment for nusery pages. Returns a constant, and
can be called from any thread.
*/
GC2_EXTERN unsigned long GC_make_jit_nursery_page(int count);
/*
Obtains nursery pages from the GC for thread local allocation;
resulting space is count times the allocation alignment.
The result is an unsigned long because it's not a valid
pointer to a GCable object. The result becomes invalid (i.e. it's collected)
with the next GC.

14
src/mzscheme/gc2/newgc.c
View File

@ -814,6 +814,7 @@ inline static mpage *gen0_create_new_nursery_mpage(NewGC *gc, const size_t page_
newmpage->addr = malloc_dirty_pages(gc, page_size, APAGE_SIZE);
newmpage->size_class = 0;
newmpage->size = PREFIX_SIZE;
newmpage->previous_size = page_size;
pagemap_add_with_size(gc->page_maps, newmpage, page_size);
GCVERBOSEPAGE("NEW gen0", newmpage);
@ -829,18 +830,19 @@ inline static void gen0_free_nursery_mpage(NewGC *gc, mpage *page, size_t page_s
/* Needs to be consistent with GC_alloc_alignment(): */
#define THREAD_LOCAL_PAGE_SIZE APAGE_SIZE
unsigned long GC_make_jit_nursery_page() {
unsigned long GC_make_jit_nursery_page(int count) {
NewGC *gc = GC_get_GC();
mpage *new_mpage;
long size = count * THREAD_LOCAL_PAGE_SIZE;
if((gc->gen0.current_size + THREAD_LOCAL_PAGE_SIZE) >= gc->gen0.max_size) {
if((gc->gen0.current_size + size) >= gc->gen0.max_size) {
if (!gc->dumping_avoid_collection)
garbage_collect(gc, 0);
}
gc->gen0.current_size += THREAD_LOCAL_PAGE_SIZE;
gc->gen0.current_size += size;
{
new_mpage = gen0_create_new_nursery_mpage(gc, THREAD_LOCAL_PAGE_SIZE);
new_mpage = gen0_create_new_nursery_mpage(gc, size);
/* push page */
new_mpage->next = gc->thread_local_pages;
@ -865,7 +867,7 @@ unsigned long GC_make_jit_nursery_page() {
}
inline static void gen0_free_jit_nursery_page(NewGC *gc, mpage *page) {
gen0_free_nursery_mpage(gc, page, THREAD_LOCAL_PAGE_SIZE);
gen0_free_nursery_mpage(gc, page, page->previous_size);
}
inline static mpage *gen0_create_new_mpage(NewGC *gc) {
@ -1211,7 +1213,7 @@ inline static int marked(NewGC *gc, void *p)
if (page->size_class > 1) {
return (page->size_class > 2);
}
} else {
} else if (page->generation) {
if((NUM(page->addr) + page->previous_size) > NUM(p))
return 1;
}

4
src/mzscheme/gc2/newgc.h
View File

@ -5,8 +5,8 @@ typedef struct mpage {
struct mpage *next;
struct mpage *prev;
void *addr;
unsigned long previous_size; /* for med page, points to place to search for available block */
unsigned long size; /* big page size or med page element size */
unsigned long previous_size; /* for med page, place to search for available block; for jit nursery, allocated size */
unsigned long size; /* big page size, med page element size, or nursery starting point */
unsigned char generation;
/*
unsigned char back_pointers :1;

5
src/mzscheme/src/bool.c
View File

@ -340,13 +340,8 @@ static int is_equal_overflow(Scheme_Object *obj1, Scheme_Object *obj2, Equal_Inf
return SCHEME_TRUEP(v);
}
/* Number of lists/vectors/structs/boxes to compare before
paying for a stack check. */
#define EQUAL_COUNT_START 20
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
{
static int equal_counter = EQUAL_COUNT_START;
top:
if (eql->next_next) {

53
src/mzscheme/src/future.c
View File

@ -199,6 +199,10 @@ typedef struct Scheme_Future_Thread_State {
volatile int *fuel_pointer;
volatile unsigned long *stack_boundary_pointer;
volatile int *need_gc_pointer;
unsigned long gen0_start;
unsigned long gen0_size;
unsigned long gen0_initial_offset;
} Scheme_Future_Thread_State;
THREAD_LOCAL_DECL(static Scheme_Future_State *scheme_future_state);
@ -411,6 +415,8 @@ static void init_future_thread(Scheme_Future_State *fs, int i)
sema_destroy(&params.ready_sema);
fts->threadid = threadid;
fts->gen0_size = 1;
scheme_register_static(&fts->current_ft, sizeof(void*));
scheme_register_static(params.scheme_current_runstack_ptr, sizeof(void*));
@ -434,6 +440,9 @@ static void start_gc_not_ok(Scheme_Future_State *fs)
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
if (fts->worker_gc_counter != *fs->gc_counter_ptr) {
GC_gen0_alloc_page_ptr = 0; /* forces future to ask for memory */
fts->gen0_start = 0;
if (fts->gen0_size > 1)
fts->gen0_size >>= 1;
fts->worker_gc_counter = *fs->gc_counter_ptr;
}
}
@ -959,9 +968,8 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts,
}
}
/**********************************************************************/
/* Functions for primitive invocation */
/* Functions for primitive invocation */
/**********************************************************************/
void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f)
XFORM_SKIP_PROC
@ -983,7 +991,9 @@ void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void
future->arg_S0 = NULL;
}
unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f)
#ifdef MZ_PRECISE_GC
unsigned long scheme_rtcall_alloc(const char *who, int src_type)
XFORM_SKIP_PROC
/* Called in future thread */
{
@ -991,21 +1001,43 @@ unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim
unsigned long retval;
Scheme_Future_Thread_State *fts = scheme_future_thread_state;
Scheme_Future_State *fs = scheme_future_state;
long align;
align = GC_alloc_alignment();
/* Do we actually still have space? */
if (fts->gen0_start) {
long cur;
cur = GC_gen0_alloc_page_ptr;
if (cur < (fts->gen0_start + (fts->gen0_size - 1) * align)) {
cur &= ~(align - 1);
cur += align + fts->gen0_initial_offset;
return cur;
}
}
/* Grow nursery size as long as we don't trigger a GC */
if (fts->gen0_size < 16)
fts->gen0_size <<= 1;
while (1) {
future = fts->current_ft;
future->time_of_request = 0; /* takes too long?: scheme_get_inexact_milliseconds(); */
future->time_of_request = scheme_get_inexact_milliseconds();
future->source_of_request = who;
future->source_type = src_type;
future->prim_protocol = SIG_ALLOC_VOID_PVOID;
future->prim_protocol = SIG_ALLOC;
future->arg_i0 = fts->gen0_size;
future_do_runtimecall(fts, (void*)f, 1);
future_do_runtimecall(fts, (void*)GC_make_jit_nursery_page, 1);
future = fts->current_ft;
retval = future->alloc_retval;
future->alloc_retval = 0;
fts->gen0_start = retval;
fts->gen0_initial_offset = retval & (align - 1);
if (*fs->gc_counter_ptr == future->alloc_retval_counter)
break;
}
@ -1013,6 +1045,8 @@ unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim
return retval;
}
#endif
static void receive_special_result(future_t *f, Scheme_Object *retval, int clear)
XFORM_SKIP_PROC
/* Called in future or runtime thread */
@ -1108,15 +1142,16 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future)
break;
}
case SIG_ALLOC_VOID_PVOID:
#ifdef MZ_PRECISE_GC
case SIG_ALLOC:
{
unsigned long ret;
prim_alloc_void_pvoid_t func = (prim_alloc_void_pvoid_t)future->prim_func;
ret = func();
ret = GC_make_jit_nursery_page(future->arg_i0);
future->alloc_retval = ret;
future->alloc_retval_counter = scheme_did_gc_count;
break;
}
#endif
# include "jit_ts_runtime_glue.c"
default:
scheme_signal_error("unknown protocol %d", future->prim_protocol);

9
src/mzscheme/src/future.h
View File

@ -24,7 +24,6 @@ int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2);
#include <stdio.h>
typedef void (*prim_void_void_3args_t)(Scheme_Object **);
typedef unsigned long (*prim_alloc_void_pvoid_t)();
typedef Scheme_Object* (*prim_obj_int_pobj_obj_t)(Scheme_Object*, int, Scheme_Object**);
typedef Scheme_Object* (*prim_int_pobj_obj_t)(int, Scheme_Object**);
typedef Scheme_Object* (*prim_int_pobj_obj_obj_t)(int, Scheme_Object**, Scheme_Object*);
@ -105,7 +104,7 @@ typedef struct future_t {
//Signature flags for primitive invocations
//Here the convention is SIG_[arg1type]_[arg2type]..._[return type]
#define SIG_VOID_VOID_3ARGS 1 //void -> void, copy 3 args from runstack
#define SIG_ALLOC_VOID_PVOID 2 //void -> void*
#define SIG_ALLOC 2 //void -> void*
# include "jit_ts_protos.h"
@ -122,7 +121,7 @@ extern Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v);
}
extern void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f);
extern unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f);
extern unsigned long scheme_rtcall_alloc(const char *who, int src_type);
#else
@ -136,7 +135,7 @@ extern unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_typ
#define LOG_THISCALL LOG(__FUNCTION__)
#define LOG_RTCALL_VOID_VOID_3ARGS(f) LOG("(function=%p)", f)
#define LOG_RTCALL_ALLOC_VOID_PVOID(f) LOG("(function=%p)", f)
#define LOG_RTCALL_ALLOC(f) LOG("(function=%p)", f)
#define LOG_RTCALL_OBJ_INT_POBJ_OBJ(f,a,b,c) LOG("(function = %p, a=%p, b=%d, c=%p)", f, a, b, c)
#define LOG_RTCALL_OBJ_INT_POBJ_VOID(a,b,c) LOG("(%p, %d, %p)", a, b,c)
#define LOG_RTCALL_INT_OBJARR_OBJ(a,b) LOG("(%d, %p)", a, b)
@ -159,7 +158,7 @@ extern unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_typ
#define LOG_THISCALL
#define LOG_RTCALL_VOID_VOID_3ARGS(f)
#define LOG_RTCALL_ALLOC_VOID_PVOID(f)
#define LOG_RTCALL_ALLOC(f)
#define LOG_RTCALL_OBJ_INT_POBJ_OBJ(f,a,b,c)
#define LOG_RTCALL_OBJ_INT_POBJ_VOID(a,b,c)
#define LOG_RTCALL_INT_OBJARR_OBJ(a,b)

3
src/mzscheme/src/jit.c
View File

@ -1394,7 +1394,6 @@ THREAD_LOCAL_DECL(extern unsigned long GC_gen0_alloc_page_ptr);
long GC_initial_word(int sizeb);
void GC_initial_words(char *buffer, int sizeb);
long GC_compute_alloc_size(long sizeb);
long GC_alloc_alignment(void);
static void *retry_alloc_code;
static void *retry_alloc_code_keep_r0_r1;
@ -2257,7 +2256,7 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) XFORM_SKIP_PROC
if (scheme_use_rtcall) {
jit_future_storage[0] = p;
jit_future_storage[1] = p2;
ret = scheme_rtcall_alloc_void_pvoid("[acquire_gc_page]", FSRC_OTHER, GC_make_jit_nursery_page);
ret = scheme_rtcall_alloc("[acquire_gc_page]", FSRC_OTHER);
GC_gen0_alloc_page_ptr = ret;
retry_alloc_r1 = jit_future_storage[1];
p = jit_future_storage[0];

7
src/mzscheme/src/mzeqchk.inc
View File

@ -1,12 +1,7 @@
if (!--equal_counter) {
equal_counter = EQUAL_COUNT_START;
SCHEME_USE_FUEL(EQUAL_COUNT_START);
SCHEME_USE_FUEL(1);
#ifdef DO_STACK_CHECK
{
#include "mzstkchk.h"
return is_equal_overflow(obj1, obj2, eql);
}
#endif
}

29
src/mzscheme/src/places.c
View File

@ -325,7 +325,7 @@ static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) {
worker_thread = mz_proc_thread_create(mz_proc_thread_wait_worker, wd);
mz_proc_thread_detach(worker_thread);
scheme_block_until(place_wait_ready, NULL, (Scheme_Object *) wd, 1.0);
scheme_block_until(place_wait_ready, NULL, (Scheme_Object *) wd, 0);
rc = scheme_make_integer((long)wd->rc);
free(wd);
@ -421,9 +421,9 @@ static void *place_start_proc(void *data_arg) {
Place_Start_Data *place_data;
Scheme_Object *a[2];
int ptid;
long rc = 0;
ptid = mz_proc_thread_self();
stack_base = PROMPT_STACK(stack_base);
place_data = (Place_Start_Data *) data_arg;
@ -449,14 +449,31 @@ static void *place_start_proc(void *data_arg) {
Scheme_Object *place_main;
a[0] = scheme_places_deep_copy(place_data->module);
a[1] = scheme_places_deep_copy(place_data->function);
place_main = scheme_dynamic_require(2, a);
a[0] = scheme_places_deep_copy(place_data->channel);
scheme_apply(place_main, 1, a);
{
Scheme_Thread * volatile p;
mz_jmp_buf * volatile saved_error_buf;
mz_jmp_buf new_error_buf;
p = scheme_get_current_thread();
saved_error_buf = p->error_buf;
p->error_buf = &new_error_buf;
if (!scheme_setjmp(new_error_buf)) {
place_main = scheme_dynamic_require(2, a);
a[0] = scheme_places_deep_copy(place_data->channel);
scheme_apply(place_main, 1, a);
}
else {
rc = 1;
}
p->error_buf = saved_error_buf;
}
/*printf("Leavin place: proc thread id%u\n", ptid);*/
scheme_place_instance_destroy();
}
return scheme_true;
return (void*) rc;
}
Scheme_Object *scheme_places_deep_copy_in_master(Scheme_Object *so) {