From 8d96441673d07568b02d047e9f59575c09dec128 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 19 Nov 2009 20:29:36 +0000 Subject: [PATCH 01/92] PR 10591 svn: r16897 --- collects/framework/private/text.ss | 23 +++++++++++-------- collects/tests/framework/text.ss | 37 ++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 10 deletions(-) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 668834e816..e12ad06ec6 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -451,15 +451,18 @@ WARNING: printf is rebound in the body of the unit to always (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret) (when before (let-values ([(view-x view-y view-width view-height) - (let ([b1 (box 0)] - [b2 (box 0)] - [b3 (box 0)] - [b4 (box 0)]) - (send (get-admin) get-view b1 b2 b3 b4) - (values (unbox b1) - (unbox b2) - (unbox b3) - (unbox b4)))]) + (let ([admin (get-admin)]) + (if admin + (let ([b1 (box 0)] + [b2 (box 0)] + [b3 (box 0)] + [b4 (box 0)]) + (send admin get-view b1 b2 b3 b4) + (values (unbox b1) + (unbox b2) + (unbox b3) + (unbox b4))) + (values left-margin top-margin right-margin bottom-margin)))]) (let* ([old-pen (send dc get-pen)] [old-brush (send dc get-brush)] [old-smoothing (send dc get-smoothing)] @@ -472,7 +475,7 @@ WARNING: printf is rebound in the body of the unit to always [top (rectangle-top rectangle)] [right (if (number? (rectangle-right rectangle)) (rectangle-right rectangle) - (+ view-x view-width))] + view-x)] [bottom (rectangle-bottom rectangle)] [width (max 0 (- right left))] [height (max 0 (- bottom top))]) diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss index 00fe7cc228..f0047ebfa2 100644 --- a/collects/tests/framework/text.ss +++ b/collects/tests/framework/text.ss @@ -161,3 +161,40 @@ #:exists 'truncate) (send t load-file) (length (send t get-highlighted-ranges))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; print-to-dc +;; + +(test + 'print-to-dc + (λ (x) (equal? x 'no-error)) + (λ () + (send-sexp-to-mred + '(let* ([t (new text:basic%)] + [bmp (make-object bitmap% 100 40)] + [dc (new bitmap-dc% (bitmap bmp))]) + (send t insert "Hello world") + (send dc clear) + (send t print-to-dc dc 1) + 'no-error)))) + + +(test + 'print-to-dc2 + (λ (x) (equal? x 'no-error)) + (λ () + (send-sexp-to-mred + `(let* ([f (new frame% [label ""])] + [t (new text:basic%)] + [ec (new editor-canvas% [parent f] [editor t])] + [bmp (make-object bitmap% 100 40)] + [dc (new bitmap-dc% (bitmap bmp))]) + (send t insert "Hello world") + (send t highlight-range 2 5 "orange") + (send f reflow-container) + (send dc clear) + (send t print-to-dc dc 1) + 'no-error)))) \ No newline at end of file From eb9eeda873726f59f4576e0ff215aae5430e948f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Nov 2009 21:56:17 +0000 Subject: [PATCH 02/92] cover all functions called form JIT that need to go back to runtime thread svn: r16898 --- src/mzscheme/include/schthread.h | 2 + src/mzscheme/src/Makefile.in | 5 +- src/mzscheme/src/future.c | 322 +++-------------------- src/mzscheme/src/future.h | 77 ++---- src/mzscheme/src/gen-jit-ts.ss | 167 ++++++++++++ src/mzscheme/src/jit.c | 253 +++++++----------- src/mzscheme/src/jit_ts.c | 134 ++++++++++ src/mzscheme/src/jit_ts_def.c | 190 ++++++++++++++ src/mzscheme/src/jit_ts_future_glue.c | 341 +++++++++++++++++++++++++ src/mzscheme/src/jit_ts_glue.c | 240 +++++++++++++++++ src/mzscheme/src/jit_ts_protos.h | 57 +++++ src/mzscheme/src/jit_ts_runtime_glue.c | 171 +++++++++++++ src/mzscheme/src/mzmark.c | 24 +- src/mzscheme/src/mzmarksrc.c | 12 +- 14 files changed, 1482 insertions(+), 513 deletions(-) create mode 100644 src/mzscheme/src/gen-jit-ts.ss create mode 100644 src/mzscheme/src/jit_ts.c create mode 100644 src/mzscheme/src/jit_ts_def.c create mode 100644 src/mzscheme/src/jit_ts_future_glue.c create mode 100644 src/mzscheme/src/jit_ts_glue.c create mode 100644 src/mzscheme/src/jit_ts_protos.h create mode 100644 src/mzscheme/src/jit_ts_runtime_glue.c diff --git a/src/mzscheme/include/schthread.h b/src/mzscheme/include/schthread.h index 37fb3b7dba..e86aad0b49 100644 --- a/src/mzscheme/include/schthread.h +++ b/src/mzscheme/include/schthread.h @@ -92,6 +92,7 @@ typedef struct Thread_Local_Variables { unsigned long scheme_stack_boundary_; unsigned long volatile scheme_jit_stack_boundary_; volatile int scheme_future_need_gc_pause_; + int scheme_use_rtcall_; struct Scheme_Object *quick_stx_; int scheme_continuation_application_count_; int scheme_cont_capture_count_; @@ -255,6 +256,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define scheme_stack_boundary XOA (scheme_get_thread_local_variables()->scheme_stack_boundary_) #define scheme_jit_stack_boundary XOA (scheme_get_thread_local_variables()->scheme_jit_stack_boundary_) #define scheme_future_need_gc_pause XOA (scheme_get_thread_local_variables()->scheme_future_need_gc_pause_) +#define scheme_use_rtcall XOA (scheme_get_thread_local_variables()->scheme_use_rtcall_) #define quick_stx XOA (scheme_get_thread_local_variables()->quick_stx_) #define scheme_continuation_application_count XOA (scheme_get_thread_local_variables()->scheme_continuation_application_count_) #define scheme_cont_capture_count XOA (scheme_get_thread_local_variables()->scheme_cont_capture_count_) diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index b95cadcb60..5b6dce72e8 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -272,7 +272,8 @@ fun.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schmap.inc \ $(srcdir)/future.h future.@LTO@: $(srcdir)/schpriv.h $(srcdir)/future.h $(SCONFIG) $(srcdir)/../include/scheme.h \ - $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c \ + $(srcdir)/jit_ts_future_glue.c $(srcdir)/jit_ts_runtime_glue.c $(srcdir)/jit_ts_protos.h hash.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c jit.@LTO@: $(COMMON_HEADERS) \ @@ -285,7 +286,7 @@ jit.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/lightning/ppc/asm.h $(srcdir)/lightning/ppc/asm-common.h \ $(srcdir)/lightning/ppc/funcs.h $(srcdir)/lightning/ppc/funcs-common.h \ $(srcdir)/lightning/ppc/fp.h $(srcdir)/lightning/ppc/fp-common.h \ - $(srcdir)/future.h + $(srcdir)/future.h $(srcdir)/jit_ts.c $(srcdir)/jit_ts_protos.h list.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h module.@LTO@: $(COMMON_HEADERS) \ diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index b7fa5e1c85..e95e3505cb 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -61,8 +61,8 @@ static unsigned long g_cur_cpu_mask = 1; static void *g_signal_handle = NULL; static struct NewGC *g_shared_GC; -future_t *g_future_queue = NULL; -future_t *g_future_waiting_atomic = NULL; +static future_t *g_future_queue = NULL; +static future_t *g_future_waiting_atomic = NULL; int g_next_futureid = 0; pthread_t g_rt_threadid = 0; @@ -86,13 +86,15 @@ static void **g_jit_future_storage; static int *gc_counter_ptr; THREAD_LOCAL_DECL(static int worker_gc_counter); +#ifdef MZ_PRECISE_GC static void register_traversers(void); +#endif extern void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv); static void start_gc_not_ok(int with_lock); static void end_gc_not_ok(future_t *ft, int with_lock); -static int future_do_runtimecall(void *func, int is_atomic, void *retval); +static void future_do_runtimecall(void *func, int is_atomic); THREAD_LOCAL_DECL(static future_t *current_ft); @@ -110,7 +112,6 @@ static void *worker_thread_future_loop(void *arg); static void invoke_rtcall(future_t *future); static future_t *enqueue_future(future_t *ft);; static future_t *get_pending_future(void); -static future_t *get_my_future(void); static future_t *get_last_future(void); #else //Garbage stubs for unit testing @@ -549,7 +550,7 @@ int future_ready(Scheme_Object *obj) int ret = 0; future_t *ft = (future_t*)obj; pthread_mutex_lock(&g_future_queue_mutex); - if (ft->work_completed || ft->rt_prim != NULL) + if (ft->work_completed || ft->rt_prim) { ret = 1; } @@ -630,7 +631,7 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) g_num_avail_threads++; pthread_mutex_unlock(&g_future_queue_mutex); } - else if (ft->rt_prim != NULL) + else if (ft->rt_prim) { //Invoke the primitive and stash the result //Release the lock so other threads can manipulate the queue @@ -683,6 +684,8 @@ void *worker_thread_future_loop(void *arg) pthread_cond_init(&worker_can_continue_cv, NULL); + scheme_use_rtcall = 1; + scheme_fuel_counter = 1; scheme_jit_stack_boundary = ((unsigned long)&v) - INITIAL_C_STACK_SIZE; @@ -795,12 +798,8 @@ void scheme_check_future_work() //i.e. if we are already running on the runtime thread. Otherwise returns //1, and 'retval' is set to point to the return value of the runtime //call invocation. -int future_do_runtimecall( - void *func, - int is_atomic, - //int sigtype, - //void *args, - void *retval) +void future_do_runtimecall(void *func, + int is_atomic) /* Called in future thread */ { START_XFORM_SKIP; @@ -813,7 +812,7 @@ int future_do_runtimecall( { //Should never get here! This check should be done //by the caller using the macros defined in scheme-futures.h! - return 0; + return; } //Fetch the future descriptor for this thread @@ -829,6 +828,7 @@ int future_do_runtimecall( //will use this value to temporarily swap its stack //for the worker thread's future->runstack = MZ_RUNSTACK; + future->prim_func = func; future->rt_prim = 1; future->rt_prim_is_atomic = is_atomic; @@ -853,7 +853,6 @@ int future_do_runtimecall( pthread_mutex_unlock(&g_future_queue_mutex); - return 1; END_XFORM_SKIP; } @@ -861,244 +860,43 @@ int future_do_runtimecall( /**********************************************************************/ /* Functions for primitive invocation */ /**********************************************************************/ -int rtcall_void_void_3args(void (*f)()) +void rtcall_void_void_3args(void (*f)()) /* Called in future thread */ { START_XFORM_SKIP; - future_t *future; - prim_data_t data; - if (!IS_WORKER_THREAD) - { - return 0; - } + current_ft->prim_protocol = SIG_VOID_VOID_3ARGS; - memset(&data, 0, sizeof(prim_data_t)); - data.void_void_3args = f; - data.sigtype = SIG_VOID_VOID_3ARGS; + future_do_runtimecall((void*)f, 1); - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 1, NULL); - future = current_ft; - - return 1; END_XFORM_SKIP; } - -int rtcall_alloc_void_pvoid(void (*f)(), void **retval) +void *rtcall_alloc_void_pvoid(void (*f)()) /* Called in future thread */ { START_XFORM_SKIP; future_t *future; - prim_data_t data; - - if (!IS_WORKER_THREAD) - { - return 0; - } + void *retval; while (1) { - memset(&data, 0, sizeof(prim_data_t)); + current_ft->prim_protocol = SIG_ALLOC_VOID_PVOID; - data.alloc_void_pvoid = f; - data.sigtype = SIG_ALLOC_VOID_PVOID; + future_do_runtimecall((void*)f, 1); future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 1, NULL); - future = current_ft; - - *retval = future->alloc_retval; + retval = future->alloc_retval; future->alloc_retval = NULL; if (*gc_counter_ptr == future->alloc_retval_counter) break; } - return 1; + return retval; END_XFORM_SKIP; } - -int rtcall_obj_int_pobj_obj( - prim_obj_int_pobj_obj_t f, - Scheme_Object *rator, - int argc, - Scheme_Object **argv, - Scheme_Object **retval) -/* Called in future thread */ -{ - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - if (!IS_WORKER_THREAD) - { - return 0; - } - - memset(&data, 0, sizeof(prim_data_t)); - -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.obj_int_pobj_obj = f; - data.p = rator; - data.argc = argc; - data.argv = argv; - data.sigtype = SIG_OBJ_INT_POBJ_OBJ; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.retval; - future->prim_data.retval = NULL; - - return 1; - END_XFORM_SKIP; -} - - -int rtcall_int_pobj_obj( - prim_int_pobj_obj_t f, - int argc, - Scheme_Object **argv, - Scheme_Object **retval) -/* Called in future thread */ -{ - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - if (!IS_WORKER_THREAD) - { - return 0; - } - - memset(&data, 0, sizeof(prim_data_t)); - -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.int_pobj_obj = f; - data.argc = argc; - data.argv = argv; - data.sigtype = SIG_INT_OBJARR_OBJ; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.retval; - future->prim_data.retval = NULL; - - return 1; - END_XFORM_SKIP; -} - - -int rtcall_pvoid_pvoid_pvoid( - prim_pvoid_pvoid_pvoid_t f, - void *a, - void *b, - void **retval) -/* Called in future thread */ -{ - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - - if (!IS_WORKER_THREAD) - { - return 0; - } - - memset(&data, 0, sizeof(prim_data_t)); - -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.pvoid_pvoid_pvoid = f; - data.a = a; - data.b = b; - data.sigtype = SIG_PVOID_PVOID_PVOID; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.c; - - return 1; - END_XFORM_SKIP; -} - - -int rtcall_int_pobj_obj_obj( - prim_int_pobj_obj_obj_t f, - int argc, - Scheme_Object **argv, - Scheme_Object *p, - Scheme_Object **retval) -/* Called in future thread */ -{ - START_XFORM_SKIP; - future_t *future; - prim_data_t data; - - if (!IS_WORKER_THREAD) - { - return 0; - } - - memset(&data, 0, sizeof(prim_data_t)); - -#ifdef DEBUG_FUTURES - printf("scheme_fuel_counter = %d\n", scheme_fuel_counter); - printf("scheme_jit_stack_boundary = %p\n", (void*)scheme_jit_stack_boundary); - printf("scheme_current_runstack = %p\n", scheme_current_runstack); - printf("scheme_current_runstack_start = %p\n", scheme_current_runstack_start); - printf("stack address = %p\n", &future); -#endif - - data.int_pobj_obj_obj = f; - data.argc = argc; - data.argv = argv; - data.p = p; - data.sigtype = SIG_INT_POBJ_OBJ_OBJ; - - future = current_ft; - future->prim_data = data; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - *retval = future->prim_data.retval; - future->prim_data.retval = NULL; - - return 1; - END_XFORM_SKIP; -} +#include "jit_ts_future_glue.c" //Does the work of actually invoking a primitive on behalf of a //future. This function is always invoked on the main (runtime) @@ -1112,11 +910,11 @@ void invoke_rtcall(future_t *future) future->rt_prim = 0; - switch (future->prim_data.sigtype) + switch (future->prim_protocol) { case SIG_VOID_VOID_3ARGS: { - prim_void_void_3args_t func = future->prim_data.void_void_3args; + prim_void_void_3args_t func = (prim_void_void_3args_t)future->prim_func; func(future->runstack); @@ -1125,77 +923,17 @@ void invoke_rtcall(future_t *future) case SIG_ALLOC_VOID_PVOID: { void *ret; - prim_alloc_void_pvoid_t func = future->prim_data.alloc_void_pvoid; + prim_alloc_void_pvoid_t func = (prim_alloc_void_pvoid_t)future->prim_func; ret = func(); future->alloc_retval = ret; ret = NULL; future->alloc_retval_counter = scheme_did_gc_count; break; } - case SIG_OBJ_INT_POBJ_OBJ: - { - Scheme_Object *ret; - prim_obj_int_pobj_obj_t func = future->prim_data.obj_int_pobj_obj; - ret = func( - future->prim_data.p, - future->prim_data.argc, - future->prim_data.argv); - - future->prim_data.retval = ret; - - /*future->prim_data.retval = future->prim_data.prim_obj_int_pobj_obj( - future->prim_data.p, - future->prim_data.argc, - future->prim_data.argv); */ - - break; - } - case SIG_INT_OBJARR_OBJ: - { - Scheme_Object *ret; - prim_int_pobj_obj_t func = future->prim_data.int_pobj_obj; - ret = func( - future->prim_data.argc, - future->prim_data.argv); - - future->prim_data.retval = ret; - - /*future->prim_data.retval = future->prim_data.prim_int_pobj_obj( - future->prim_data.argc, - future->prim_data.argv); - */ - break; - } - case SIG_INT_POBJ_OBJ_OBJ: - { - Scheme_Object *ret; - prim_int_pobj_obj_obj_t func = future->prim_data.int_pobj_obj_obj; - ret = func( - future->prim_data.argc, - future->prim_data.argv, - future->prim_data.p); - - future->prim_data.retval = ret; - /*future->prim_data.retval = future->prim_data.prim_int_pobj_obj_obj( - future->prim_data.argc, - future->prim_data.argv, - future->prim_data.p); - */ - break; - } - case SIG_PVOID_PVOID_PVOID: - { - void *pret = NULL; - prim_pvoid_pvoid_pvoid_t func = future->prim_data.pvoid_pvoid_pvoid; - pret = func(future->prim_data.a, future->prim_data.b); - - future->prim_data.c = pret; - /*future->prim_data.c = future->prim_data.prim_pvoid_pvoid_pvoid( - future->prim_data.a, - future->prim_data.b); - */ - break; - } +# include "jit_ts_runtime_glue.c" + default: + scheme_signal_error("unknown protocol %d", future->prim_protocol); + break; } pthread_mutex_lock(&g_future_queue_mutex); diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 69d03ae6b5..364e06c325 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -38,39 +38,12 @@ 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*); typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*); -typedef struct { - unsigned int sigtype; - - prim_void_void_3args_t void_void_3args; - prim_alloc_void_pvoid_t alloc_void_pvoid; - prim_obj_int_pobj_obj_t obj_int_pobj_obj; - prim_int_pobj_obj_t int_pobj_obj; - prim_int_pobj_obj_obj_t int_pobj_obj_obj; - prim_pvoid_pvoid_pvoid_t pvoid_pvoid_pvoid; - - //Scheme_Object* (*prim_obj_int_pobj_obj)(Scheme_Object* rator, int argc, Scheme_Object** argv); - //Scheme_Object* (*prim_int_pobj_obj)(int argc, Scheme_Object** argv); - //Scheme_Object* (*prim_int_pobj_obj_obj)(int argc, Scheme_Object** argv, Scheme_Object* p); - //void (*prim_void_void)(void); - //void* (*prim_pvoid_pvoid_pvoid)(void *a, void *b); - - Scheme_Object *p; - int argc; - Scheme_Object **argv; - Scheme_Object *retval; - - void *a; - void *b; - void *c; - -} prim_data_t; - #define PENDING 0 #define RUNNING 1 #define WAITING_FOR_PRIM 2 #define FINISHED 3 -typedef struct future { +typedef struct future_t { Scheme_Object so; int id; @@ -89,14 +62,32 @@ typedef struct future { int rt_prim; /* flag to indicate waiting for a prim call */ int rt_prim_is_atomic; - prim_data_t prim_data; void *alloc_retval; int alloc_retval_counter; + void *prim_func; + int prim_protocol; + Scheme_Object *arg_s0; + Scheme_Object **arg_S0; + Scheme_Bucket *arg_b0; + int arg_i0; + long arg_l0; + Scheme_Native_Closure_Data *arg_n0; + Scheme_Object *arg_s1; + Scheme_Object **arg_S1; + int arg_i1; + long arg_l1; + Scheme_Object **arg_s2; + Scheme_Object **arg_S2; + int arg_i2; + + Scheme_Object *retval_s; + MZ_MARK_STACK_TYPE retval_m; + Scheme_Object *retval; - struct future *prev; - struct future *next; - struct future *next_waiting_atomic; + struct future_t *prev; + struct future_t *next; + struct future_t *next_waiting_atomic; } future_t; #ifdef UNIT_TEST @@ -156,10 +147,8 @@ extern void print_ms_and_us(void); //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_OBJ_INT_POBJ_OBJ 3 //Scheme_Object* -> int -> Scheme_Object** -> Scheme_Object* -#define SIG_INT_OBJARR_OBJ 4 //int -> Scheme_Object*[] -> Scheme_Object -#define SIG_INT_POBJ_OBJ_OBJ 17 //int -> Scheme_Object** -> Scheme_Object* -> Scheme_Object* -#define SIG_PVOID_PVOID_PVOID 18 //void* -> void* -> void* + +# include "jit_ts_protos.h" //Helper macros for argument marshaling #ifdef FUTURES_ENABLED @@ -171,20 +160,8 @@ extern void print_ms_and_us(void); /*GDB_BREAK;*/ \ } -extern int rtcall_void_void_3args(void (*f)()); -extern int rtcall_alloc_void_pvoid(void (*f)(), void **retval); -extern int rtcall_obj_int_pobj_obj( - Scheme_Object* (*f)(Scheme_Object*, int, Scheme_Object**), - Scheme_Object *a, - int b, - Scheme_Object **c, - Scheme_Object **retval); - -extern int rtcall_int_pobj_obj( - Scheme_Object* (*f)(int, Scheme_Object**), - int argc, - Scheme_Object **argv, - Scheme_Object **retval); +extern void rtcall_void_void_3args(void (*f)()); +extern void *rtcall_alloc_void_pvoid(void (*f)()); #else diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss new file mode 100644 index 0000000000..b11dc24e51 --- /dev/null +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -0,0 +1,167 @@ +#lang at-exp scheme/base +(require scheme/string) + +(define (char->type c) + (case c + [(#\s) "Scheme_Object*"] + [(#\S) "Scheme_Object**"] + [(#\b) "Scheme_Bucket*"] + [(#\n) "Scheme_Native_Closure_Data*"] + [(#\m) "MZ_MARK_STACK_TYPE"] + [(#\i) "int"] + [(#\l) "long"] + [(#\v) "void"] + [else (error 'char->type "unknown: ~e" c)])) + +(define (type->arg-string t) + (let* ([t (symbol->string t)]) + (substring t 0 (- (string-length t) 2)))) + +(define (parse-type t) + (let* ([s (symbol->string t)]) + (values + (for/list ([c (in-string (type->arg-string t))]) + (char->type c)) + (char->type (string-ref s (sub1 (string-length s))))))) + +(define (make-arg-list arg-types arg-names) + (string-join (map (lambda (t a) + (string-append t " " a)) + arg-types arg-names) + ", ")) + +(define (gen-definer t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (for-each display + @list{#define define_ts_@|ts|(id) \ + static @|result-type| ts_ ## id(@|args|) \ + { \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + @|return| scheme_rtcall_@|t|(id, @(string-join arg-names ", ")); \ + else \ + @|return| id(@(string-join arg-names ", ")); \ + END_XFORM_SKIP; \ + }}) + (newline)) + +(define (gen-future-side t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (define fretval @string-append{future->retval_@|(substring ts (sub1 (string-length ts)))|}) + (for-each + display + @list{ + @|result-type| scheme_rtcall_@|ts|(prim_@|ts| f@|(if (null? arg-types) "" ",")| @|args|) + { + START_XFORM_SKIP; + future_t *future; + @(if (string=? result-type "void") "" @string-append{@|result-type| retval;}) + + future = current_ft; + future->prim_protocol = SIG_@|ts|; + future->prim_func = f; + @(string-join + (for/list ([t (in-string (type->arg-string t))] + [a arg-names] + [i (in-naturals)]) + @string-append{ future->arg_@|(string t)|@|(number->string i)| = @|a|;}) + "\n") + future_do_runtimecall((void*)f, 0); + future = current_ft; + @(if (string=? result-type "void") "" @string-append{retval = @|fretval|;}) + @(if (string=? result-type "void") "" @string-append{@|fretval| = NULL;}) + @(if (string=? result-type "void") "" "return retval;") + END_XFORM_SKIP; + } + }) + (newline)) + +(define (gen-runtime-side t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (for-each + display + @list{ + case SIG_@|ts|: + { + prim_@|ts| f = (prim_@|ts|)future->prim_func; + @(if (string=? result-type "void") "" @string-append{@|result-type| retval;}) + @(if (string=? result-type "void") "" "retval = ") + f(@(string-join + (for/list ([t (in-string (type->arg-string t))] + [i (in-naturals)]) + @string-append{future->arg_@|(string t)|@|(number->string i)|}) + ", ")); + @(if (string=? result-type "void") "" @string-append{future->retval_@(substring ts (sub1 (string-length ts))) = retval;}) + break; + } + }) + (newline)) + +(define proto-counter 5) + +(define (gen-protos t) + (define-values (arg-types result-type) (parse-type t)) + (define arg-names (map symbol->string (map (lambda (v) (gensym)) arg-types))) + (define return (if (equal? result-type "void") "" "return")) + (define args (make-arg-list arg-types arg-names)) + (define ts (symbol->string t)) + (printf "#define SIG_~a ~a\n" t proto-counter) + (set! proto-counter (add1 proto-counter)) + (display + @string-append{typedef @|result-type| (*prim_@|ts|)(@(string-join arg-types ", "));}) + (newline) + (display @string-append{@|result-type| scheme_rtcall_@|ts|(prim_@|ts| f@(if (null? arg-types) "" ",") @|args|);}) + (newline)) + +(define types + '(siS_s + iSs_s + s_s + n_s + _s + ss_s + ss_m + Sl_s + l_s + bsi_v + iiS_v + ss_v + b_v + sl_s + iS_s + S_s + s_v + iSi_s + siS_v)) + +(with-output-to-file "jit_ts_def.c" + #:exists 'replace + (lambda () + (for-each gen-definer types))) + +(with-output-to-file "jit_ts_future_glue.c" + #:exists 'replace + (lambda () + (for-each gen-future-side types))) + +(with-output-to-file "jit_ts_runtime_glue.c" + #:exists 'replace + (lambda () + (for-each gen-runtime-side types))) + +(with-output-to-file "jit_ts_protos.h" + #:exists 'replace + (lambda () + (for-each gen-protos types))) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 03afa3dea5..c5fb9152e4 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2157,104 +2157,42 @@ extern int g_print_prims; # define mz_direct_only(p) /* skip this arg, so that total count <= 3 args */ static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) { - Scheme_Object *ret; - LOG_PRIM_START(proc); + START_XFORM_SKIP; - if (rtcall_int_pobj_obj(proc, - argc, - MZ_RUNSTACK, - &ret)) - { - LOG_PRIM_END(proc); - return ret; - } + if (scheme_use_rtcall) + return scheme_rtcall_iS_s(proc, + argc, + MZ_RUNSTACK); + else + return proc(argc, MZ_RUNSTACK); - ret = proc(argc, MZ_RUNSTACK); - LOG_PRIM_END(proc); - - return ret; + END_XFORM_SKIP; } static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self) { - Scheme_Object *ret; - LOG_PRIM_START(proc); + START_XFORM_SKIP; - if (rtcall_int_pobj_obj_obj(proc, - argc, - MZ_RUNSTACK, - self, - &ret)) - { - LOG_PRIM_END(proc); - return ret; - } + if (scheme_use_rtcall) + return scheme_rtcall_iSs_s(proc, argc, MZ_RUNSTACK, self); + else + return proc(argc, MZ_RUNSTACK, self); - ret = proc(argc, MZ_RUNSTACK, self); - LOG_PRIM_END(proc); - - return ret; + END_XFORM_SKIP; } /* Various specific 'futurized' versions of primitives that may be invoked directly from JIT code and are not considered thread-safe (are not invoked via apply_multi_from_native, etc.) */ -static Scheme_Object *ts_scheme_apply_multi_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) -{ - START_XFORM_SKIP; - Scheme_Object *retptr; - if (rtcall_obj_int_pobj_obj(_scheme_apply_multi_from_native, - rator, - argc, - argv, - &retptr)) { - return retptr; - } - - return _scheme_apply_multi_from_native(rator, argc, argv); - END_XFORM_SKIP; -} - -static Scheme_Object *ts_scheme_apply_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) -{ - START_XFORM_SKIP; - Scheme_Object *retptr; - if (rtcall_obj_int_pobj_obj(_scheme_apply_from_native, - rator, - argc, - argv, - &retptr)) { - return retptr; - } - - return _scheme_apply_from_native(rator, argc, argv); - END_XFORM_SKIP; -} - -static Scheme_Object *ts_scheme_tail_apply_from_native(Scheme_Object *rator, int argc, Scheme_Object **argv) -{ - START_XFORM_SKIP; - Scheme_Object *retptr; - if (rtcall_obj_int_pobj_obj(_scheme_tail_apply_from_native, - rator, - argc, - argv, - &retptr)) { - return retptr; - } - - return _scheme_tail_apply_from_native(rator, argc, argv); - END_XFORM_SKIP; -} +#include "jit_ts.c" static void ts_on_demand(void) { START_XFORM_SKIP; - if (rtcall_void_void_3args(on_demand_with_args)) { - return; - } - - on_demand(); + if (scheme_use_rtcall) + rtcall_void_void_3args(on_demand_with_args); + else + on_demand(); END_XFORM_SKIP; } @@ -2264,10 +2202,11 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) START_XFORM_SKIP; void *ret; LOG_PRIM_START(&prepare_retry_alloc); - jit_future_storage[0] = p; - jit_future_storage[1] = p2; - if (rtcall_alloc_void_pvoid(GC_make_jit_nursery_page, - &ret)) { + + if (scheme_use_rtcall) { + jit_future_storage[0] = p; + jit_future_storage[1] = p2; + ret = rtcall_alloc_void_pvoid(GC_make_jit_nursery_page); GC_gen0_alloc_page_ptr = ret; retry_alloc_r1 = jit_future_storage[1]; p = jit_future_storage[0]; @@ -2276,9 +2215,6 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) return p; } - jit_future_storage[0] = NULL; - jit_future_storage[1] = NULL; - ret = prepare_retry_alloc(p, p2); LOG_PRIM_END(&prepare_retry_alloc); return ret; @@ -2290,9 +2226,6 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) # define mz_prepare_direct_prim(n) mz_prepare(n) # define mz_finishr_direct_prim(reg, proc) mz_finishr(reg) # define mz_direct_only(p) p -# define ts_scheme_apply_multi_from_native _scheme_apply_multi_from_native -# define ts_scheme_apply_from_native _scheme_apply_from_native -# define ts_scheme_tail_apply_from_native _scheme_tail_apply_from_native # define ts_on_demand on_demand # define ts_prepare_retry_alloc prepare_retry_alloc #endif @@ -2540,9 +2473,9 @@ static int generate_finish_tail_call(mz_jit_state *jitter, int direct_native) jit_pusharg_i(JIT_R0); jit_pusharg_p(JIT_V1); if (direct_native > 1) { /* => some_args_already_in_place */ - (void)mz_finish(_scheme_tail_apply_from_native_fixup_args); + (void)mz_finish(ts__scheme_tail_apply_from_native_fixup_args); } else { - (void)mz_finish(ts_scheme_tail_apply_from_native); + (void)mz_finish(ts__scheme_tail_apply_from_native); } CHECK_LIMIT(); /* Return: */ @@ -2840,9 +2773,9 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { - (void)mz_finish(scheme_force_value_same_mark); + (void)mz_finish(ts_scheme_force_value_same_mark); } else { - (void)mz_finish(scheme_force_one_value_same_mark); + (void)mz_finish(ts_scheme_force_one_value_same_mark); } ref5 = jit_jmpi(jit_forward()); CHECK_LIMIT(); @@ -2894,9 +2827,9 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { - (void)mz_finish(scheme_force_value_same_mark); + (void)mz_finish(ts_scheme_force_value_same_mark); } else { - (void)mz_finish(scheme_force_one_value_same_mark); + (void)mz_finish(ts_scheme_force_one_value_same_mark); } CHECK_LIMIT(); ref8 = jit_jmpi(jit_forward()); @@ -2940,9 +2873,9 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc jit_pusharg_p(JIT_V1); if (num_rands < 0) { jit_movr_p(JIT_V1, JIT_R0); } /* save argc to manually pop runstack */ if (multi_ok) { - (void)mz_finish(ts_scheme_apply_multi_from_native); + (void)mz_finish(ts__scheme_apply_multi_from_native); } else { - (void)mz_finish(ts_scheme_apply_from_native); + (void)mz_finish(ts__scheme_apply_from_native); } CHECK_LIMIT(); mz_patch_ucbranch(ref5); @@ -3793,7 +3726,7 @@ static int generate_alloc_double(mz_jit_state *jitter) (void)mz_tl_sti_d_fppop(tl_double_result, JIT_FPR0, JIT_R0); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(0); - (void)mz_finish(malloc_double); + (void)mz_finish(ts_malloc_double); jit_retval(JIT_R0); # endif #endif @@ -5375,7 +5308,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_box); + (void)mz_finish(ts_scheme_box); jit_retval(JIT_R0); #endif @@ -6061,7 +5994,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i mz_prepare(2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_mutable_pair); + (void)mz_finish(ts_scheme_make_mutable_pair); jit_retval(JIT_R0); #endif @@ -6311,9 +6244,9 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int jit_pusharg_l(JIT_R0); jit_pusharg_l(JIT_RUNSTACK); if (star) - (void)mz_finish(make_list_star); + (void)mz_finish(ts_make_list_star); else - (void)mz_finish(make_list); + (void)mz_finish(ts_make_list); jit_retval(JIT_R0); #endif @@ -6376,7 +6309,7 @@ static int generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry) jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); } - (void)mz_finish(scheme_make_pair); + (void)mz_finish(ts_scheme_make_pair); jit_retval(JIT_R0); #endif @@ -6433,25 +6366,25 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, mz_prepare(1); jit_pusharg_p(JIT_R0); if (imm) - (void)mz_finish(make_one_element_ivector); + (void)mz_finish(ts_make_one_element_ivector); else - (void)mz_finish(make_one_element_vector); + (void)mz_finish(ts_make_one_element_vector); } else if (c == 2) { mz_prepare(2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); if (imm) - (void)mz_finish(make_two_element_ivector); + (void)mz_finish(ts_make_two_element_ivector); else - (void)mz_finish(make_two_element_vector); + (void)mz_finish(ts_make_two_element_vector); } else { jit_movi_l(JIT_R1, c); mz_prepare(1); jit_pusharg_l(JIT_R1); if (imm) - (void)mz_finish(make_ivector); + (void)mz_finish(ts_make_ivector); else - (void)mz_finish(make_vector); + (void)mz_finish(ts_make_vector); } jit_retval(JIT_R0); #endif @@ -6539,9 +6472,9 @@ static int generate_closure(Scheme_Closure_Data *data, mz_prepare(1); jit_pusharg_l(JIT_R0); if (immediately_filled) { - (void)mz_finish(GC_malloc_one_small_dirty_tagged); + (void)mz_finish(ts_GC_malloc_one_small_dirty_tagged); } else { - (void)mz_finish(GC_malloc_one_small_tagged); + (void)mz_finish(ts_GC_malloc_one_small_tagged); } jit_retval(JIT_R0); memcpy(&init_word, &example_so, sizeof(long)); @@ -6566,7 +6499,7 @@ static int generate_closure(Scheme_Closure_Data *data, (void)jit_patchable_movi_p(JIT_R0, code); /* !! */ #endif jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_native_closure); + (void)mz_finish(ts_scheme_make_native_closure); jit_retval(JIT_R0); return 1; @@ -6665,7 +6598,7 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t (void)jit_patchable_movi_p(JIT_R0, ndata); /* !! */ #endif jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_native_case_closure); + (void)mz_finish(ts_scheme_make_native_case_closure); jit_retval(JIT_R1); CHECK_LIMIT(); @@ -7061,7 +6994,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_pusharg_p(JIT_R0); jit_pusharg_p(JIT_R2); CHECK_LIMIT(); - (void)mz_finish(call_set_global_bucket); + (void)mz_finish(ts_call_set_global_bucket); CHECK_LIMIT(); (void)jit_movi_p(target, scheme_void); END_JIT_DATA(7); @@ -7227,7 +7160,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); mz_prepare(1); jit_pusharg_p(JIT_R2); - (void)mz_finish(scheme_make_envunbox); + (void)mz_finish(ts_scheme_make_envunbox); jit_retval(JIT_R0); jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R0); CHECK_LIMIT(); @@ -7254,7 +7187,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(1); jit_pusharg_p(JIT_R2); - (void)mz_finish(make_global_ref); + (void)mz_finish(ts_make_global_ref); CHECK_LIMIT(); jit_retval(target); VALIDATE_RESULT(target); @@ -7594,7 +7527,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m CHECK_LIMIT(); jit_movi_i(JIT_V1, lv->count); jit_pusharg_i(JIT_V1); - (void)mz_finish(lexical_binding_wrong_return_arity); + (void)mz_finish(ts_lexical_binding_wrong_return_arity); CHECK_LIMIT(); /* Continue with expected values; R2 has value array: */ @@ -7642,7 +7575,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m (void)jit_movi_p(JIT_R0, scheme_undefined); mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_make_envunbox); + (void)mz_finish(ts_scheme_make_envunbox); jit_retval(JIT_R0); jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_R0); } @@ -7768,7 +7701,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_prepare(2); jit_pusharg_p(JIT_R0); jit_pusharg_p(JIT_V1); - (void)mz_finish(scheme_set_cont_mark); + (void)mz_finish(ts_scheme_set_cont_mark); CHECK_LIMIT(); END_JIT_DATA(18); @@ -8021,7 +7954,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) CHECK_LIMIT(); jit_movi_i(JIT_V1, 1); jit_pusharg_i(JIT_V1); - (void)mz_finish(call_wrong_return_arity); + (void)mz_finish(ts_call_wrong_return_arity); CHECK_LIMIT(); /* *** unbound_global_code *** */ @@ -8029,7 +7962,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); mz_prepare(1); jit_pusharg_p(JIT_R2); - (void)mz_finish(scheme_unbound_global); + (void)mz_finish(ts_scheme_unbound_global); CHECK_LIMIT(); /* *** quote_syntax_code *** */ @@ -8067,7 +8000,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_prepare(2); jit_pusharg_l(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(scheme_delayed_rename); + (void)mz_finish(ts_scheme_delayed_rename); CHECK_LIMIT(); jit_retval(JIT_R0); /* Restore global array into JIT_R1, and put computed element at i+p+1: */ @@ -8130,28 +8063,28 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_i(JIT_R1); switch (i) { case 0: - (void)mz_finish(scheme_checked_car); + (void)mz_finish(ts_scheme_checked_car); break; case 1: - (void)mz_finish(scheme_checked_cdr); + (void)mz_finish(ts_scheme_checked_cdr); break; case 2: - (void)mz_finish(scheme_checked_caar); + (void)mz_finish(ts_scheme_checked_caar); break; case 3: - (void)mz_finish(scheme_checked_cadr); + (void)mz_finish(ts_scheme_checked_cadr); break; case 4: - (void)mz_finish(scheme_checked_cdar); + (void)mz_finish(ts_scheme_checked_cdar); break; case 5: - (void)mz_finish(scheme_checked_cddr); + (void)mz_finish(ts_scheme_checked_cddr); break; case 6: - (void)mz_finish(scheme_checked_mcar); + (void)mz_finish(ts_scheme_checked_mcar); break; case 7: - (void)mz_finish(scheme_checked_mcdr); + (void)mz_finish(ts_scheme_checked_mcdr); break; } CHECK_LIMIT(); @@ -8185,10 +8118,10 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_i(JIT_R1); switch (i) { case 0: - (void)mz_finish(scheme_checked_set_mcar); + (void)mz_finish(ts_scheme_checked_set_mcar); break; case 1: - (void)mz_finish(scheme_checked_set_mcdr); + (void)mz_finish(ts_scheme_checked_set_mcdr); break; } CHECK_LIMIT(); @@ -8200,8 +8133,8 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) bad_unbox_code = jit_get_ip().ptr; mz_prolog(JIT_R1); jit_prepare(1); - jit_pusharg_i(JIT_R0); - (void)mz_finish(scheme_unbox); + jit_pusharg_p(JIT_R0); + (void)mz_finish(ts_scheme_unbox); CHECK_LIMIT(); register_sub_func(jitter, bad_unbox_code, scheme_false); @@ -8211,7 +8144,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_prolog(JIT_R1); jit_prepare(1); jit_pusharg_i(JIT_R0); - (void)mz_finish(scheme_vector_length); + (void)mz_finish(ts_scheme_vector_length); CHECK_LIMIT(); register_sub_func(jitter, bad_vector_length_code, scheme_false); @@ -8353,7 +8286,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R2); jit_pusharg_p(JIT_R1); jit_pusharg_p(JIT_R0); - (void)mz_finish(ts_scheme_apply_multi_from_native); + (void)mz_finish(ts__scheme_apply_multi_from_native); CHECK_LIMIT(); mz_pop_threadlocal(); mz_pop_locals(); @@ -8368,7 +8301,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); mz_prepare(1); jit_pusharg_p(JIT_V1); - (void)mz_finish(tail_call_with_values_from_multiple_result); + (void)mz_finish(ts_tail_call_with_values_from_multiple_result); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); /* Return: */ @@ -8441,7 +8374,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_finish(raise_bad_call_with_values); + (void)mz_finish(ts_raise_bad_call_with_values); /* Doesn't return */ CHECK_LIMIT(); @@ -8457,9 +8390,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_prepare(1); jit_pusharg_p(JIT_V1); if (i) { - (void)mz_finish(call_with_values_from_multiple_result_multi); + (void)mz_finish(ts_call_with_values_from_multiple_result_multi); } else { - (void)mz_finish(call_with_values_from_multiple_result); + (void)mz_finish(ts_call_with_values_from_multiple_result); } jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -8570,28 +8503,28 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) switch (ii) { case 0: if (!iii) { - (void)mz_finish(scheme_checked_vector_ref); + (void)mz_finish(ts_scheme_checked_vector_ref); } else { - (void)mz_finish(scheme_checked_vector_set); + (void)mz_finish(ts_scheme_checked_vector_set); } break; case 1: if (!iii) { - (void)mz_finish(scheme_checked_string_ref); + (void)mz_finish(ts_scheme_checked_string_ref); /* might return, if char was outside Latin-1 */ jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2)); JIT_UPDATE_THREAD_RSPTR(); jit_retval(JIT_R0); mz_epilog(JIT_R2); } else { - (void)mz_finish(scheme_checked_string_set); + (void)mz_finish(ts_scheme_checked_string_set); } break; case 2: if (!iii) { - (void)mz_finish(scheme_checked_byte_string_ref); + (void)mz_finish(ts_scheme_checked_byte_string_ref); } else { - (void)mz_finish(scheme_checked_byte_string_set); + (void)mz_finish(ts_scheme_checked_byte_string_set); } break; } @@ -8704,7 +8637,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_prepare(2); jit_pusharg_p(JIT_RUNSTACK); jit_pusharg_i(JIT_R1); - (void)mz_finish(scheme_checked_syntax_e); + (void)mz_finish(ts_scheme_checked_syntax_e); jit_retval(JIT_R0); jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); mz_epilog(JIT_R2); @@ -8802,9 +8735,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_V1); jit_pusharg_p(JIT_R0); if (ii == 1) { - (void)mz_finish(ts_scheme_apply_multi_from_native); + (void)mz_finish(ts__scheme_apply_multi_from_native); } else { - (void)mz_finish(ts_scheme_apply_from_native); + (void)mz_finish(ts__scheme_apply_from_native); } jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -9044,8 +8977,8 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) jit_movi_i(JIT_V1, 5); jit_prepare(2); jit_pusharg_p(JIT_RUNSTACK); - jit_pusharg_p(JIT_V1); - (void)mz_finish(scheme_extract_checked_procedure); + jit_pusharg_i(JIT_V1); + (void)mz_finish(ts_scheme_extract_checked_procedure); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); mz_epilog(JIT_V1); @@ -9112,7 +9045,7 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) JIT_UPDATE_THREAD_RSPTR(); jit_prepare(1); jit_pusharg_p(JIT_RUNSTACK); - (void)mz_finish(apply_checked_fail); + (void)mz_finish(ts_apply_checked_fail); CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -9353,7 +9286,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R2); jit_pusharg_i(JIT_R1); CHECK_LIMIT(); - (void)mz_finish(scheme_build_list_offset); + (void)mz_finish(ts_scheme_build_list_offset); jit_retval(JIT_V1); #ifndef JIT_PRECISE_GC if (data->closure_size) @@ -9667,10 +9600,10 @@ static int generate_simple_arity_check(mz_jit_state *jitter, int num_params, int /* Not negative, so report run-time arity mismatch */ mz_prepare(3); jit_pusharg_p(JIT_R2); - jit_pusharg_p(JIT_R1); + jit_pusharg_i(JIT_R1); jit_pusharg_p(JIT_R0); CHECK_LIMIT(); - (void)mz_nonrs_finish(wrong_argument_count); + (void)mz_nonrs_finish(ts_wrong_argument_count); CHECK_LIMIT(); /* Arity check or reporting. If argv is NULL, it's a reporting request */ @@ -9705,7 +9638,7 @@ static int generate_simple_arity_check(mz_jit_state *jitter, int num_params, int if (is_method) { mz_prepare(1); jit_pusharg_p(JIT_R0); - (void)mz_nonrs_finish(scheme_box); + (void)mz_nonrs_finish(ts_scheme_box); mz_pop_threadlocal(); mz_pop_locals(); jit_ret(); @@ -9805,10 +9738,10 @@ static int generate_case_lambda_dispatch(mz_jit_state *jitter, Scheme_Case_Lambd JIT_UPDATE_THREAD_RSPTR(); mz_prepare(3); jit_pusharg_p(JIT_R2); - jit_pusharg_p(JIT_R1); + jit_pusharg_i(JIT_R1); jit_pusharg_p(JIT_R0); CHECK_LIMIT(); - (void)mz_finish(wrong_argument_count); + (void)mz_finish(ts_wrong_argument_count); CHECK_LIMIT(); } diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c new file mode 100644 index 0000000000..75ce340f12 --- /dev/null +++ b/src/mzscheme/src/jit_ts.c @@ -0,0 +1,134 @@ +#ifdef FUTURES_ENABLED + +# include "jit_ts_def.c" + +/* s = Scheme_Object* + i = int + l = long + S = Scheme_Object** + v = void + b = Scheme_Bucket* + n = Scheme_Native_Closure_Data* + m = MZ_MARK_STACK_TYPE */ + +define_ts_siS_s(_scheme_apply_multi_from_native) +define_ts_siS_s(_scheme_apply_from_native) +define_ts_siS_s(_scheme_tail_apply_from_native) +define_ts_siS_s(_scheme_tail_apply_from_native_fixup_args) +define_ts_s_s(scheme_force_value_same_mark) +define_ts_s_s(scheme_force_one_value_same_mark) +#if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC) +define_ts__s(malloc_double) +#endif +define_ts_s_s(scheme_box) +#ifndef CAN_INLINE_ALLOC +define_ts_ss_s(scheme_make_mutable_pair) +define_ts_Sl_s(make_list_star) +define_ts_Sl_s(make_list) +define_ts_ss_s(scheme_make_pair) +define_ts_s_s(make_one_element_ivector) +define_ts_s_s(make_one_element_vector) +define_ts_ss_s(make_two_element_ivector) +define_ts_ss_s(make_two_element_vector) +define_ts_l_s(make_ivector) +define_ts_l_s(make_vector) +#endif +#ifdef JIT_PRECISE_GC +define_ts_l_s(GC_malloc_one_small_dirty_tagged) +define_ts_l_s(GC_malloc_one_small_tagged) +#endif +define_ts_n_s(scheme_make_native_closure) +define_ts_n_s(scheme_make_native_case_closure) +define_ts_bsi_v(call_set_global_bucket) +define_ts_s_s(scheme_make_envunbox) +define_ts_s_s(make_global_ref) +define_ts_iiS_v(lexical_binding_wrong_return_arity) +define_ts_ss_m(scheme_set_cont_mark) +define_ts_iiS_v(call_wrong_return_arity) +define_ts_b_v(scheme_unbound_global) +define_ts_Sl_s(scheme_delayed_rename) +define_ts_iS_s(scheme_checked_car) +define_ts_iS_s(scheme_checked_cdr) +define_ts_iS_s(scheme_checked_caar) +define_ts_iS_s(scheme_checked_cadr) +define_ts_iS_s(scheme_checked_cdar) +define_ts_iS_s(scheme_checked_cddr) +define_ts_iS_s(scheme_checked_mcar) +define_ts_iS_s(scheme_checked_mcdr) +define_ts_iS_s(scheme_checked_set_mcar) +define_ts_iS_s(scheme_checked_set_mcdr) +define_ts_s_s(scheme_unbox) +define_ts_s_s(scheme_vector_length) +define_ts_s_s(tail_call_with_values_from_multiple_result) +define_ts_s_v(raise_bad_call_with_values) +define_ts_s_s(call_with_values_from_multiple_result_multi) +define_ts_s_s(call_with_values_from_multiple_result) +define_ts_iS_s(scheme_checked_vector_ref) +define_ts_iS_s(scheme_checked_vector_set) +define_ts_iS_s(scheme_checked_string_ref) +define_ts_iS_s(scheme_checked_string_set) +define_ts_iS_s(scheme_checked_byte_string_ref) +define_ts_iS_s(scheme_checked_byte_string_set) +define_ts_iS_s(scheme_checked_syntax_e) +define_ts_iS_s(scheme_extract_checked_procedure) +define_ts_S_s(apply_checked_fail) +define_ts_iSi_s(scheme_build_list_offset) +define_ts_siS_v(wrong_argument_count) +#else +# define ts__scheme_tail_apply_from_native_fixup_args _scheme_tail_apply_from_native_fixup_args +# define ts_scheme_force_value_same_mark scheme_force_value_same_mark +# define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark +# define ts_scheme_force_value_same_mark scheme_force_value_same_mark +# define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark +# define ts_malloc_double malloc_double +# define ts_scheme_box scheme_box +# define ts_scheme_make_mutable_pair scheme_make_mutable_pair +# define ts_make_list_star make_list_star +# define ts_make_list make_list +# define ts_scheme_make_pair scheme_make_pair +# define ts_make_one_element_ivector make_one_element_ivector +# define ts_make_one_element_vector make_one_element_vector +# define ts_make_two_element_ivector make_two_element_ivector +# define ts_make_two_element_vector make_two_element_vector +# define ts_make_ivector make_ivector +# define ts_make_vector make_vector +# define ts_GC_malloc_one_small_dirty_tagged GC_malloc_one_small_dirty_tagged +# define ts_GC_malloc_one_small_tagged GC_malloc_one_small_tagged +# define ts_scheme_make_native_closure scheme_make_native_closure +# define ts_scheme_make_native_case_closure scheme_make_native_case_closure +# define ts_call_set_global_bucket call_set_global_bucket +# define ts_scheme_make_envunbox scheme_make_envunbox +# define ts_make_global_ref make_global_ref +# define ts_lexical_binding_wrong_return_arity lexical_binding_wrong_return_arity +# define ts_scheme_set_cont_mark scheme_set_cont_mark +# define ts_call_wrong_return_arity call_wrong_return_arity +# define ts_scheme_unbound_global scheme_unbound_global +# define ts_scheme_delayed_rename scheme_delayed_rename +# define ts_scheme_checked_car scheme_checked_car +# define ts_scheme_checked_cdr scheme_checked_cdr +# define ts_scheme_checked_caar scheme_checked_caar +# define ts_scheme_checked_cadr scheme_checked_cadr +# define ts_scheme_checked_cdar scheme_checked_cdar +# define ts_scheme_checked_cddr scheme_checked_cddr +# define ts_scheme_checked_mcar scheme_checked_mcar +# define ts_scheme_checked_mcdr scheme_checked_mcdr +# define ts_scheme_checked_set_mcar scheme_checked_set_mcar +# define ts_scheme_checked_set_mcdr scheme_checked_set_mcdr +# define ts_scheme_unbox scheme_unbox +# define ts_scheme_vector_length scheme_vector_length +# define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result +# define ts_raise_bad_call_with_values raise_bad_call_with_values +# define ts_call_with_values_from_multiple_result_multi call_with_values_from_multiple_result_multi +# define ts_call_with_values_from_multiple_result call_with_values_from_multiple_result +# define ts_scheme_checked_vector_ref scheme_checked_vector_ref +# define ts_scheme_checked_vector_set scheme_checked_vector_set +# define ts_scheme_checked_string_ref scheme_checked_string_ref +# define ts_scheme_checked_string_set scheme_checked_string_set +# define ts_scheme_checked_byte_string_ref scheme_checked_byte_string_ref +# define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set +# define ts_scheme_checked_syntax_e scheme_checked_syntax_e +# define ts_scheme_extract_checked_procedure scheme_extract_checked_procedure +# define ts_apply_checked_fail apply_checked_fail +# define ts_scheme_build_list_offset scheme_build_list_offset +# define ts_wrong_argument_count wrong_argument_count +#endif diff --git a/src/mzscheme/src/jit_ts_def.c b/src/mzscheme/src/jit_ts_def.c new file mode 100644 index 0000000000..4add12c66d --- /dev/null +++ b/src/mzscheme/src/jit_ts_def.c @@ -0,0 +1,190 @@ +#define define_ts_siS_s(id) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_siS_s(id, g7, g8, g9); \ + else \ + return id(g7, g8, g9); \ + END_XFORM_SKIP; \ +} +#define define_ts_iSs_s(id) \ +static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iSs_s(id, g10, g11, g12); \ + else \ + return id(g10, g11, g12); \ + END_XFORM_SKIP; \ +} +#define define_ts_s_s(id) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_s_s(id, g13); \ + else \ + return id(g13); \ + END_XFORM_SKIP; \ +} +#define define_ts_n_s(id) \ +static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_n_s(id, g14); \ + else \ + return id(g14); \ + END_XFORM_SKIP; \ +} +#define define_ts__s(id) \ +static Scheme_Object* ts_ ## id() \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall__s(id, ); \ + else \ + return id(); \ + END_XFORM_SKIP; \ +} +#define define_ts_ss_s(id) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_ss_s(id, g15, g16); \ + else \ + return id(g15, g16); \ + END_XFORM_SKIP; \ +} +#define define_ts_ss_m(id) \ +static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_ss_m(id, g17, g18); \ + else \ + return id(g17, g18); \ + END_XFORM_SKIP; \ +} +#define define_ts_Sl_s(id) \ +static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_Sl_s(id, g19, g20); \ + else \ + return id(g19, g20); \ + END_XFORM_SKIP; \ +} +#define define_ts_l_s(id) \ +static Scheme_Object* ts_ ## id(long g21) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_l_s(id, g21); \ + else \ + return id(g21); \ + END_XFORM_SKIP; \ +} +#define define_ts_bsi_v(id) \ +static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + scheme_rtcall_bsi_v(id, g22, g23, g24); \ + else \ + id(g22, g23, g24); \ + END_XFORM_SKIP; \ +} +#define define_ts_iiS_v(id) \ +static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + scheme_rtcall_iiS_v(id, g25, g26, g27); \ + else \ + id(g25, g26, g27); \ + END_XFORM_SKIP; \ +} +#define define_ts_ss_v(id) \ +static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + scheme_rtcall_ss_v(id, g28, g29); \ + else \ + id(g28, g29); \ + END_XFORM_SKIP; \ +} +#define define_ts_b_v(id) \ +static void ts_ ## id(Scheme_Bucket* g30) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + scheme_rtcall_b_v(id, g30); \ + else \ + id(g30); \ + END_XFORM_SKIP; \ +} +#define define_ts_sl_s(id) \ +static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_sl_s(id, g31, g32); \ + else \ + return id(g31, g32); \ + END_XFORM_SKIP; \ +} +#define define_ts_iS_s(id) \ +static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iS_s(id, g33, g34); \ + else \ + return id(g33, g34); \ + END_XFORM_SKIP; \ +} +#define define_ts_S_s(id) \ +static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_S_s(id, g35); \ + else \ + return id(g35); \ + END_XFORM_SKIP; \ +} +#define define_ts_s_v(id) \ +static void ts_ ## id(Scheme_Object* g36) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + scheme_rtcall_s_v(id, g36); \ + else \ + id(g36); \ + END_XFORM_SKIP; \ +} +#define define_ts_iSi_s(id) \ +static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iSi_s(id, g37, g38, g39); \ + else \ + return id(g37, g38, g39); \ + END_XFORM_SKIP; \ +} +#define define_ts_siS_v(id) \ +static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + scheme_rtcall_siS_v(id, g40, g41, g42); \ + else \ + id(g40, g41, g42); \ + END_XFORM_SKIP; \ +} diff --git a/src/mzscheme/src/jit_ts_future_glue.c b/src/mzscheme/src/jit_ts_future_glue.c new file mode 100644 index 0000000000..894f3cd735 --- /dev/null +++ b/src/mzscheme/src/jit_ts_future_glue.c @@ -0,0 +1,341 @@ + Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g43, int g44, Scheme_Object** g45) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_siS_s; + future->prim_func = f; + future->arg_s0 = g43; + future->arg_i1 = g44; + future->arg_S2 = g45; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g46, Scheme_Object** g47, Scheme_Object* g48) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_iSs_s; + future->prim_func = f; + future->arg_i0 = g46; + future->arg_S1 = g47; + future->arg_s2 = g48; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g49) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_s_s; + future->prim_func = f; + future->arg_s0 = g49; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g50) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_n_s; + future->prim_func = f; + future->arg_n0 = g50; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall__s(prim__s f ) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG__s; + future->prim_func = f; + + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g51, Scheme_Object* g52) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_ss_s; + future->prim_func = f; + future->arg_s0 = g51; + future->arg_s1 = g52; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g53, Scheme_Object* g54) +{ + START_XFORM_SKIP; + future_t *future; + MZ_MARK_STACK_TYPE retval; + + future = current_ft; + future->prim_protocol = SIG_ss_m; + future->prim_func = f; + future->arg_s0 = g53; + future->arg_s1 = g54; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_m; + future->retval_m = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g55, long g56) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_Sl_s; + future->prim_func = f; + future->arg_S0 = g55; + future->arg_l1 = g56; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g57) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_l_s; + future->prim_func = f; + future->arg_l0 = g57; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g58, Scheme_Object* g59, int g60) +{ + START_XFORM_SKIP; + future_t *future; + + + future = current_ft; + future->prim_protocol = SIG_bsi_v; + future->prim_func = f; + future->arg_b0 = g58; + future->arg_s1 = g59; + future->arg_i2 = g60; + future_do_runtimecall((void*)f, 0); + future = current_ft; + + + + END_XFORM_SKIP; +} + void scheme_rtcall_iiS_v(prim_iiS_v f, int g61, int g62, Scheme_Object** g63) +{ + START_XFORM_SKIP; + future_t *future; + + + future = current_ft; + future->prim_protocol = SIG_iiS_v; + future->prim_func = f; + future->arg_i0 = g61; + future->arg_i1 = g62; + future->arg_S2 = g63; + future_do_runtimecall((void*)f, 0); + future = current_ft; + + + + END_XFORM_SKIP; +} + void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g64, Scheme_Object* g65) +{ + START_XFORM_SKIP; + future_t *future; + + + future = current_ft; + future->prim_protocol = SIG_ss_v; + future->prim_func = f; + future->arg_s0 = g64; + future->arg_s1 = g65; + future_do_runtimecall((void*)f, 0); + future = current_ft; + + + + END_XFORM_SKIP; +} + void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g66) +{ + START_XFORM_SKIP; + future_t *future; + + + future = current_ft; + future->prim_protocol = SIG_b_v; + future->prim_func = f; + future->arg_b0 = g66; + future_do_runtimecall((void*)f, 0); + future = current_ft; + + + + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g67, long g68) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_sl_s; + future->prim_func = f; + future->arg_s0 = g67; + future->arg_l1 = g68; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g69, Scheme_Object** g70) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_iS_s; + future->prim_func = f; + future->arg_i0 = g69; + future->arg_S1 = g70; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g71) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_S_s; + future->prim_func = f; + future->arg_S0 = g71; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g72) +{ + START_XFORM_SKIP; + future_t *future; + + + future = current_ft; + future->prim_protocol = SIG_s_v; + future->prim_func = f; + future->arg_s0 = g72; + future_do_runtimecall((void*)f, 0); + future = current_ft; + + + + END_XFORM_SKIP; +} + Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g73, Scheme_Object** g74, int g75) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->prim_protocol = SIG_iSi_s; + future->prim_func = f; + future->arg_i0 = g73; + future->arg_S1 = g74; + future->arg_i2 = g75; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_s; + future->retval_s = NULL; + return retval; + END_XFORM_SKIP; +} + void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g76, int g77, Scheme_Object** g78) +{ + START_XFORM_SKIP; + future_t *future; + + + future = current_ft; + future->prim_protocol = SIG_siS_v; + future->prim_func = f; + future->arg_s0 = g76; + future->arg_i1 = g77; + future->arg_S2 = g78; + future_do_runtimecall((void*)f, 0); + future = current_ft; + + + + END_XFORM_SKIP; +} diff --git a/src/mzscheme/src/jit_ts_glue.c b/src/mzscheme/src/jit_ts_glue.c new file mode 100644 index 0000000000..8c9bc4b6a1 --- /dev/null +++ b/src/mzscheme/src/jit_ts_glue.c @@ -0,0 +1,240 @@ + Scheme_Object* rtcall_siS_s(prim_siS_s f, Scheme_Object* g37, int g38, Scheme_Object** g39) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_s0 = g37; + future->arg_i1 = g38; + future->arg_S2 = g39; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_s_s(prim_s_s f, Scheme_Object* g40) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_s0 = g40; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall__s(prim__s f, ) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_ss_s(prim_ss_s f, Scheme_Object* g41, Scheme_Object* g42) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_s0 = g41; + future->arg_s1 = g42; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_lS_s(prim_lS_s f, long g43, Scheme_Object** g44) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_l0 = g43; + future->arg_S1 = g44; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_l_s(prim_l_s f, long g45) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_l0 = g45; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} void rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g46, Scheme_Object* g47, int g48) +{ + START_XFORM_SKIP; + future_t *future; + void retval; + + future = current_ft; + future->arg_b0 = g46; + future->arg_s1 = g47; + future->arg_i2 = g48; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_v; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_s_s(prim_s_s f, Scheme_Object* g49) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_s0 = g49; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} void rtcall_iiS_v(prim_iiS_v f, int g50, int g51, Scheme_Object** g52) +{ + START_XFORM_SKIP; + future_t *future; + void retval; + + future = current_ft; + future->arg_i0 = g50; + future->arg_i1 = g51; + future->arg_S2 = g52; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_v; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} void rtcall_ss_v(prim_ss_v f, Scheme_Object* g53, Scheme_Object* g54) +{ + START_XFORM_SKIP; + future_t *future; + void retval; + + future = current_ft; + future->arg_s0 = g53; + future->arg_s1 = g54; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_v; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} void rtcall_b_v(prim_b_v f, Scheme_Bucket* g55) +{ + START_XFORM_SKIP; + future_t *future; + void retval; + + future = current_ft; + future->arg_b0 = g55; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_v; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_sl_s(prim_sl_s f, Scheme_Object* g56, long g57) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_s0 = g56; + future->arg_l1 = g57; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_iS_s(prim_iS_s f, int g58, Scheme_Object** g59) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_i0 = g58; + future->arg_S1 = g59; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} void rtcall_s_v(prim_s_v f, Scheme_Object* g60) +{ + START_XFORM_SKIP; + future_t *future; + void retval; + + future = current_ft; + future->arg_s0 = g60; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_v; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} Scheme_Object* rtcall_iSi_s(prim_iSi_s f, int g61, Scheme_Object** g62, int g63) +{ + START_XFORM_SKIP; + future_t *future; + Scheme_Object* retval; + + future = current_ft; + future->arg_i0 = g61; + future->arg_S1 = g62; + future->arg_i2 = g63; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_s; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} void rtcall_siS_v(prim_siS_v f, Scheme_Object* g64, int g65, Scheme_Object** g66) +{ + START_XFORM_SKIP; + future_t *future; + void retval; + + future = current_ft; + future->arg_s0 = g64; + future->arg_i1 = g65; + future->arg_S2 = g66; + future_do_runtimecall((void*)f, 0, NULL); + future = current_ft; + retval = future->retval_v; + future->prim_data.retval = NULL; + return retval; + END_XFORM_SKIP; +} \ No newline at end of file diff --git a/src/mzscheme/src/jit_ts_protos.h b/src/mzscheme/src/jit_ts_protos.h new file mode 100644 index 0000000000..f065f74c5d --- /dev/null +++ b/src/mzscheme/src/jit_ts_protos.h @@ -0,0 +1,57 @@ +#define SIG_siS_s 5 +typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**); +Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g115, int g116, Scheme_Object** g117); +#define SIG_iSs_s 6 +typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*); +Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g118, Scheme_Object** g119, Scheme_Object* g120); +#define SIG_s_s 7 +typedef Scheme_Object* (*prim_s_s)(Scheme_Object*); +Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g121); +#define SIG_n_s 8 +typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Closure_Data*); +Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g122); +#define SIG__s 9 +typedef Scheme_Object* (*prim__s)(); +Scheme_Object* scheme_rtcall__s(prim__s f ); +#define SIG_ss_s 10 +typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*); +Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g123, Scheme_Object* g124); +#define SIG_ss_m 11 +typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*); +MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g125, Scheme_Object* g126); +#define SIG_Sl_s 12 +typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, long); +Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g127, long g128); +#define SIG_l_s 13 +typedef Scheme_Object* (*prim_l_s)(long); +Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g129); +#define SIG_bsi_v 14 +typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int); +void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g130, Scheme_Object* g131, int g132); +#define SIG_iiS_v 15 +typedef void (*prim_iiS_v)(int, int, Scheme_Object**); +void scheme_rtcall_iiS_v(prim_iiS_v f, int g133, int g134, Scheme_Object** g135); +#define SIG_ss_v 16 +typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*); +void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g136, Scheme_Object* g137); +#define SIG_b_v 17 +typedef void (*prim_b_v)(Scheme_Bucket*); +void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g138); +#define SIG_sl_s 18 +typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, long); +Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g139, long g140); +#define SIG_iS_s 19 +typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**); +Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g141, Scheme_Object** g142); +#define SIG_S_s 20 +typedef Scheme_Object* (*prim_S_s)(Scheme_Object**); +Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g143); +#define SIG_s_v 21 +typedef void (*prim_s_v)(Scheme_Object*); +void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g144); +#define SIG_iSi_s 22 +typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int); +Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g145, Scheme_Object** g146, int g147); +#define SIG_siS_v 23 +typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**); +void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g148, int g149, Scheme_Object** g150); diff --git a/src/mzscheme/src/jit_ts_runtime_glue.c b/src/mzscheme/src/jit_ts_runtime_glue.c new file mode 100644 index 0000000000..9ea93cabc5 --- /dev/null +++ b/src/mzscheme/src/jit_ts_runtime_glue.c @@ -0,0 +1,171 @@ +case SIG_siS_s: + { + prim_siS_s f = (prim_siS_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_s0, future->arg_i1, future->arg_S2); + future->retval_s = retval; + break; + } +case SIG_iSs_s: + { + prim_iSs_s f = (prim_iSs_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_i0, future->arg_S1, future->arg_s2); + future->retval_s = retval; + break; + } +case SIG_s_s: + { + prim_s_s f = (prim_s_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_s0); + future->retval_s = retval; + break; + } +case SIG_n_s: + { + prim_n_s f = (prim_n_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_n0); + future->retval_s = retval; + break; + } +case SIG__s: + { + prim__s f = (prim__s)future->prim_func; + Scheme_Object* retval; + retval = + f(); + future->retval_s = retval; + break; + } +case SIG_ss_s: + { + prim_ss_s f = (prim_ss_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_s0, future->arg_s1); + future->retval_s = retval; + break; + } +case SIG_ss_m: + { + prim_ss_m f = (prim_ss_m)future->prim_func; + MZ_MARK_STACK_TYPE retval; + retval = + f(future->arg_s0, future->arg_s1); + future->retval_m = retval; + break; + } +case SIG_Sl_s: + { + prim_Sl_s f = (prim_Sl_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_S0, future->arg_l1); + future->retval_s = retval; + break; + } +case SIG_l_s: + { + prim_l_s f = (prim_l_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_l0); + future->retval_s = retval; + break; + } +case SIG_bsi_v: + { + prim_bsi_v f = (prim_bsi_v)future->prim_func; + + + f(future->arg_b0, future->arg_s1, future->arg_i2); + + break; + } +case SIG_iiS_v: + { + prim_iiS_v f = (prim_iiS_v)future->prim_func; + + + f(future->arg_i0, future->arg_i1, future->arg_S2); + + break; + } +case SIG_ss_v: + { + prim_ss_v f = (prim_ss_v)future->prim_func; + + + f(future->arg_s0, future->arg_s1); + + break; + } +case SIG_b_v: + { + prim_b_v f = (prim_b_v)future->prim_func; + + + f(future->arg_b0); + + break; + } +case SIG_sl_s: + { + prim_sl_s f = (prim_sl_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_s0, future->arg_l1); + future->retval_s = retval; + break; + } +case SIG_iS_s: + { + prim_iS_s f = (prim_iS_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_i0, future->arg_S1); + future->retval_s = retval; + break; + } +case SIG_S_s: + { + prim_S_s f = (prim_S_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_S0); + future->retval_s = retval; + break; + } +case SIG_s_v: + { + prim_s_v f = (prim_s_v)future->prim_func; + + + f(future->arg_s0); + + break; + } +case SIG_iSi_s: + { + prim_iSi_s f = (prim_iSi_s)future->prim_func; + Scheme_Object* retval; + retval = + f(future->arg_i0, future->arg_S1, future->arg_i2); + future->retval_s = retval; + break; + } +case SIG_siS_v: + { + prim_siS_v f = (prim_siS_v)future->prim_func; + + + f(future->arg_s0, future->arg_i1, future->arg_S2); + + break; + } diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index c2c8dc974d..c680d4c4e2 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5423,9 +5423,15 @@ static int future_MARK(void *p) { gcMARK(f->runstack); gcMARK(f->runstack_start); gcMARK(f->orig_lambda); - gcMARK(f->prim_data.p); - gcMARK(f->prim_data.argv); - gcMARK(f->prim_data.retval); + gcMARK(f->arg_s0); + gcMARK(f->arg_S0); + gcMARK(f->arg_b0); + gcMARK(f->arg_n0); + gcMARK(f->arg_s1); + gcMARK(f->arg_S1); + gcMARK(f->arg_s2); + gcMARK(f->arg_S2); + gcMARK(f->retval_s); gcMARK(f->retval); gcMARK(f->prev); gcMARK(f->next); @@ -5439,9 +5445,15 @@ static int future_FIXUP(void *p) { gcFIXUP(f->runstack); gcFIXUP(f->runstack_start); gcFIXUP(f->orig_lambda); - gcFIXUP(f->prim_data.p); - gcFIXUP(f->prim_data.argv); - gcFIXUP(f->prim_data.retval); + gcFIXUP(f->arg_s0); + gcFIXUP(f->arg_S0); + gcFIXUP(f->arg_b0); + gcFIXUP(f->arg_n0); + gcFIXUP(f->arg_s1); + gcFIXUP(f->arg_S1); + gcFIXUP(f->arg_s2); + gcFIXUP(f->arg_S2); + gcFIXUP(f->retval_s); gcFIXUP(f->retval); gcFIXUP(f->prev); gcFIXUP(f->next); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 12599cc9ed..ebde7f7438 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2226,9 +2226,15 @@ future { gcMARK(f->runstack); gcMARK(f->runstack_start); gcMARK(f->orig_lambda); - gcMARK(f->prim_data.p); - gcMARK(f->prim_data.argv); - gcMARK(f->prim_data.retval); + gcMARK(f->arg_s0); + gcMARK(f->arg_S0); + gcMARK(f->arg_b0); + gcMARK(f->arg_n0); + gcMARK(f->arg_s1); + gcMARK(f->arg_S1); + gcMARK(f->arg_s2); + gcMARK(f->arg_S2); + gcMARK(f->retval_s); gcMARK(f->retval); gcMARK(f->prev); gcMARK(f->next); From e2cd7a51e55fea6bbc5f23080bda6de1ca951c8b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 19 Nov 2009 21:58:44 +0000 Subject: [PATCH 03/92] Fixed a comparison that was too strict, making the code go to the general case on lists of length 3. (Didn't have much effect since it's only the toplevel comparison). svn: r16899 --- collects/scheme/private/sort.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index b6b3060723..dcc9546366 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -154,7 +154,7 @@ lst] ;; below we can assume an unsorted list ;; inlined case, for optimization of short lists - [(< n 3) + [(<= n 3) (if (= n 2) ;; (because of the above test, we can assume that the input is ;; unsorted) From 9473d1809f2dc249c363b119e6290c1fd209de5f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 19 Nov 2009 22:05:02 +0000 Subject: [PATCH 04/92] test all orders fo lengths <= 3 svn: r16900 --- collects/tests/mzscheme/list.ss | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index 0aea0bd345..f6519acc96 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -113,7 +113,18 @@ (for-each (lambda (l) (test '((0 2) (0 3) (1 1)) sort* l)) '(((1 1) (0 2) (0 3)) ((0 2) (1 1) (0 3)) - ((0 2) (0 3) (1 1))))) + ((0 2) (0 3) (1 1)))) + ;; exhaustive tests for 2 and 3 item lists + (for-each (lambda (l) (test '((1 x) (2 y)) sort* l)) + '(((1 x) (2 y)) + ((2 y) (1 x)))) + (for-each (lambda (l) (test '((1 x) (2 y) (3 z)) sort* l)) + '(((1 x) (2 y) (3 z)) + ((2 y) (1 x) (3 z)) + ((2 y) (3 z) (1 x)) + ((3 z) (2 y) (1 x)) + ((3 z) (1 x) (2 y)) + ((1 x) (3 z) (2 y))))) ;; test #:key and #:cache-keys? (let () (define l '((0) (9) (1) (8) (2) (7) (3) (6) (4) (5))) From f0b5a9e6c60c580214c08f1819344379d5f647de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Nov 2009 22:06:54 +0000 Subject: [PATCH 05/92] fix non-futures build svn: r16901 --- src/mzscheme/src/jit.c | 4 ++-- src/mzscheme/src/jit_ts.c | 3 +++ 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index c5fb9152e4..2acb3962ce 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2150,6 +2150,8 @@ static jit_insn *generate_proc_struct_retry(mz_jit_state *jitter, int num_rands, extern int g_print_prims; #endif +#include "jit_ts.c" + /* Support for intercepting direct calls to primitives: */ #ifdef FUTURES_ENABLED # define mz_prepare_direct_prim(n) mz_prepare(n) @@ -2184,8 +2186,6 @@ static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc be invoked directly from JIT code and are not considered thread-safe (are not invoked via apply_multi_from_native, etc.) */ -#include "jit_ts.c" - static void ts_on_demand(void) { START_XFORM_SKIP; diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index 75ce340f12..e7c08b5c8b 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -75,6 +75,9 @@ define_ts_S_s(apply_checked_fail) define_ts_iSi_s(scheme_build_list_offset) define_ts_siS_v(wrong_argument_count) #else +# define ts__scheme_apply_multi_from_native _scheme_apply_multi_from_native +# define ts__scheme_apply_from_native _scheme_apply_from_native +# define ts__scheme_tail_apply_from_native _scheme_tail_apply_from_native # define ts__scheme_tail_apply_from_native_fixup_args _scheme_tail_apply_from_native_fixup_args # define ts_scheme_force_value_same_mark scheme_force_value_same_mark # define ts_scheme_force_one_value_same_mark scheme_force_one_value_same_mark From 6137c3267fc3841f015715e1f9bbead6239185d2 Mon Sep 17 00:00:00 2001 From: James Swaine Date: Thu, 19 Nov 2009 22:37:08 +0000 Subject: [PATCH 06/92] fixed issue with atomic primitive invocations in futures svn: r16903 --- src/mzscheme/src/future.c | 68 +++++++++++++++++++++++++++++++-------- src/mzscheme/src/future.h | 2 +- src/mzscheme/src/jit.c | 1 + 3 files changed, 56 insertions(+), 15 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index e95e3505cb..4f677ef804 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -32,8 +32,9 @@ void scheme_init_futures(Scheme_Env *env) newenv = scheme_primitive_module(scheme_intern_symbol("#%futures"), env); - FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); - FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("processor-count", processor_count, 1, 1, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -50,7 +51,7 @@ void scheme_init_futures(Scheme_Env *env) extern void *on_demand_jit_code; -#define THREAD_POOL_SIZE 7 +#define THREAD_POOL_SIZE 12 #define INITIAL_C_STACK_SIZE 500000 static pthread_t g_pool_threads[THREAD_POOL_SIZE]; static int *g_fuel_pointers[THREAD_POOL_SIZE]; @@ -250,10 +251,10 @@ void scheme_init_futures(Scheme_Env *env) newenv); scheme_add_global_constant( - "num-processors", + "processor-count", scheme_make_prim_w_arity( - num_processors, - "num-processors", + processor_count, + "processor-count", 0, 0), newenv); @@ -291,6 +292,7 @@ void scheme_init_futures(Scheme_Env *env) scheme_protect_primitive_provide(newenv, NULL); REGISTER_SO(g_future_queue); + REGISTER_SO(g_future_waiting_atomic); } @@ -537,13 +539,6 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) } -Scheme_Object *num_processors(int argc, Scheme_Object *argv[]) -/* Called in runtime thread */ -{ - return scheme_make_integer(THREAD_POOL_SIZE); -} - - int future_ready(Scheme_Object *obj) /* Called in runtime thread by Scheme scheduler */ { @@ -652,6 +647,51 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) return retval; } +#ifdef linux +#include +#elif OS_X +#include +#elif WINDOWS +#include +#endif + +Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) +/* Called in runtime thread */ +{ + int cpucount = 0; + + #ifdef linux + cpucount = sysconf(_SC_NPROCESSORS_ONLN); + #elif OS_X + nt mib[4]; + size_t len; + + /* set the mib for hw.ncpu */ + mib[0] = CTL_HW; + mib[1] = HW_AVAILCPU; // alternatively, try HW_NCPU; + + /* get the number of CPUs from the system */ + sysctl(mib, 2, &cpucount, &len, NULL, 0); + if (cpucount < 1) + { + mib[1] = HW_NCPU; + sysctl(mib, 2, &cpucount, &len, NULL, 0); + if(cpucount < 1) + { + cpucount = 1; + } + } + #elif WINDOWS + SYSTEM_INFO sysinfo; + GetSystemInfo(&sysinfo); + cpucount = sysinfo.dwNumberOfProcessors; + #else + cpucount = THREAD_POOL_SIZE; + #endif + + return scheme_make_integer(cpucount); +} + //Entry point for a worker thread allocated for //executing futures. This function will never terminate //(until the process dies). @@ -786,7 +826,7 @@ void scheme_check_future_work() } pthread_mutex_unlock(&g_future_queue_mutex); - if (ft) { + if (ft && ft->rt_prim && ft->rt_prim_is_atomic) { invoke_rtcall(ft); } else break; diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 364e06c325..07567968bd 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -28,7 +28,7 @@ extern Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]); extern Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]); extern Scheme_Object *future(int argc, Scheme_Object *argv[]); extern Scheme_Object *touch(int argc, Scheme_Object *argv[]); -extern Scheme_Object *num_processors(int argc, Scheme_Object *argv[]); +extern Scheme_Object *processor_count(int argc, Scheme_Object *argv[]); extern void futures_init(void); typedef void (*prim_void_void_3args_t)(Scheme_Object **); diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 2acb3962ce..e75936874b 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -39,6 +39,7 @@ argument, etc. */ + #include "schpriv.h" #include "schmach.h" #ifdef FUTURES_ENABLED From bf8c1826b4b1f66a4c4f3ca7e31dda81cdc2e431 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Nov 2009 22:41:49 +0000 Subject: [PATCH 07/92] fix non-future build svn: r16904 --- src/mzscheme/src/future.c | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 4f677ef804..52d513f3bf 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -23,6 +23,12 @@ static Scheme_Object *touch(int argc, Scheme_Object *argv[]) return NULL; } +static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) +{ + scheme_signal_error("processor-count: not enabled"); + return NULL; +} + # define FUTURE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) void scheme_init_futures(Scheme_Env *env) @@ -660,10 +666,10 @@ Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) { int cpucount = 0; - #ifdef linux +#ifdef linux cpucount = sysconf(_SC_NPROCESSORS_ONLN); - #elif OS_X - nt mib[4]; +#elif OS_X + int mib[4]; size_t len; /* set the mib for hw.ncpu */ @@ -681,13 +687,13 @@ Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) cpucount = 1; } } - #elif WINDOWS +#elif WINDOWS SYSTEM_INFO sysinfo; GetSystemInfo(&sysinfo); cpucount = sysinfo.dwNumberOfProcessors; - #else +#else cpucount = THREAD_POOL_SIZE; - #endif +#endif return scheme_make_integer(cpucount); } From ec1cfb5a12ebd2c3a2d4ef44fb52a2befc730dc4 Mon Sep 17 00:00:00 2001 From: James Swaine Date: Thu, 19 Nov 2009 23:34:18 +0000 Subject: [PATCH 08/92] made primitive tracking configurable at runtime svn: r16906 --- src/mzscheme/src/eval.c | 7 ++++--- src/mzscheme/src/future.c | 24 +++++++++++++++++------- src/mzscheme/src/future.h | 6 ------ src/mzscheme/src/schnapp.inc | 4 ++++ 4 files changed, 25 insertions(+), 16 deletions(-) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 7a3a8146cf..a67fb259fa 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -145,9 +145,6 @@ #endif #ifdef FUTURES_ENABLED # include "future.h" -#else -# define LOG_PRIM_START(x) /* empty */ -# define LOG_PRIM_END(x) /* empty */ #endif #define EMBEDDED_DEFINES_START_ANYWHERE 0 @@ -7863,9 +7860,13 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, f = prim->prim_val; + #ifdef FUTURES_ENABLED LOG_PRIM_START(f); + #endif v = f(num_rands, rands, (Scheme_Object *)prim); + #ifdef FUTURES_ENABLED LOG_PRIM_END(f); + #endif DEBUG_CHECK_TYPE(v); } else if (type == scheme_closure_type) { diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 52d513f3bf..dfa6130a00 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -3,9 +3,9 @@ # include "schpriv.h" #endif -#ifdef INSTRUMENT_PRIMITIVES +//This will be TRUE if primitive tracking has been enabled +//by the program int g_print_prims = 0; -#endif #ifndef FUTURES_ENABLED @@ -29,6 +29,18 @@ static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) return NULL; } +static Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]) +{ + scheme_signal_error("start-primitive-tracking: not enabled"); + return NULL; +} + +static Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]) +{ + scheme_signal_error("end-primitive-tracking: not enabled"); + return NULL; +} + # define FUTURE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) void scheme_init_futures(Scheme_Env *env) @@ -41,6 +53,8 @@ void scheme_init_futures(Scheme_Env *env) FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); FUTURE_PRIM_W_ARITY("processor-count", processor_count, 1, 1, newenv); + FUTURE_PRIM_W_ARITY("start-primitive-tracking", start_primitive_tracking, 0, 0, newenv); + FUTURE_PRIM_W_ARITY("end-primitive-tracking", end_primitive_tracking, 0, 0, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -274,7 +288,6 @@ void scheme_init_futures(Scheme_Env *env) 1), newenv); -#ifdef INSTRUMENT_PRIMITIVES scheme_add_global_constant( "start-primitive-tracking", scheme_make_prim_w_arity( @@ -292,7 +305,6 @@ void scheme_init_futures(Scheme_Env *env) 0, 0), newenv); -#endif scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -436,8 +448,7 @@ void scheme_future_gc_pause() /* Primitive implementations */ /**********************************************************************/ -#ifdef INSTRUMENT_PRIMITIVES -long start_ms = 0; +static long start_ms = 0; Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]) { @@ -475,7 +486,6 @@ void print_ms_and_us() us = now.tv_usec - (ms * 1000) - (start_ms * 1000); printf("%ld.%ld", ms, us); } -#endif Scheme_Object *future(int argc, Scheme_Object *argv[]) /* Called in runtime thread */ diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 07567968bd..774b7043c9 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -109,7 +109,6 @@ extern void clear_futures(void); #endif //Primitive instrumentation stuff -#ifdef INSTRUMENT_PRIMITIVES extern int g_print_prims; extern void print_ms_and_us(void); #define LOG_PRIM_START(p) \ @@ -137,11 +136,6 @@ extern void print_ms_and_us(void); print_ms_and_us(); \ printf("\n"); \ } -#else -#define LOG_PRIM_START(p) -#define LOG_PRIM_END(p) -#define LOG_PRIM_W_NAME(name) -#endif //Signature flags for primitive invocations //Here the convention is SIG_[arg1type]_[arg2type]..._[return type] diff --git a/src/mzscheme/src/schnapp.inc b/src/mzscheme/src/schnapp.inc index a12f945453..57f1e38441 100644 --- a/src/mzscheme/src/schnapp.inc +++ b/src/mzscheme/src/schnapp.inc @@ -31,9 +31,13 @@ static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator, } f = (Scheme_Primitive_Closure_Proc *)prim->prim_val; + #ifdef FUTURES_ENABLED LOG_PRIM_START(f); + #endif v = f(argc, argv, (Scheme_Object *)prim); + #ifdef FUTURES_ENABLED LOG_PRIM_END(f); + #endif #if PRIM_CHECK_VALUE if (v == SCHEME_TAIL_CALL_WAITING) { From 2781f1a4b8e324cf122a6d0cdb7dfa4e8b31ca72 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Nov 2009 23:39:31 +0000 Subject: [PATCH 09/92] fix use of multiple values in futures svn: r16907 --- src/mzscheme/src/future.c | 36 ++++++ src/mzscheme/src/future.h | 7 +- src/mzscheme/src/gen-jit-ts.ss | 9 +- src/mzscheme/src/jit_ts.c | 6 +- src/mzscheme/src/jit_ts_def.c | 10 ++ src/mzscheme/src/jit_ts_future_glue.c | 171 +++++++++++++++---------- src/mzscheme/src/jit_ts_protos.h | 39 +++--- src/mzscheme/src/jit_ts_runtime_glue.c | 29 +++++ src/mzscheme/src/mzmark.c | 2 + src/mzscheme/src/mzmarksrc.c | 1 + 10 files changed, 220 insertions(+), 90 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index dfa6130a00..fce07075ca 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -84,6 +84,7 @@ static void *g_signal_handle = NULL; static struct NewGC *g_shared_GC; static future_t *g_future_queue = NULL; static future_t *g_future_waiting_atomic = NULL; +static Scheme_Object *g_thread_skeleton; int g_next_futureid = 0; pthread_t g_rt_threadid = 0; @@ -104,6 +105,7 @@ static future_t **g_current_ft; static Scheme_Object ***g_scheme_current_runstack; static Scheme_Object ***g_scheme_current_runstack_start; static void **g_jit_future_storage; +static Scheme_Object **g_current_thread; static int *gc_counter_ptr; THREAD_LOCAL_DECL(static int worker_gc_counter); @@ -340,6 +342,11 @@ void futures_init(void) are all place-specific. */ gc_counter_ptr = &scheme_did_gc_count; g_shared_GC = GC; + + /* Make enough of a thread record to deal with multiple values. */ + g_thread_skeleton = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Thread); + g_thread_skeleton->type = scheme_thread_type; + pthread_create(&threadid, &attr, worker_thread_future_loop, &i); sema_wait(&ready_sema); @@ -347,6 +354,7 @@ void futures_init(void) scheme_register_static(g_scheme_current_runstack, sizeof(void*)); scheme_register_static(g_scheme_current_runstack_start, sizeof(void*)); scheme_register_static(g_jit_future_storage, 2 * sizeof(void*)); + scheme_register_static(g_current_thread, sizeof(void*)); g_pool_threads[i] = threadid; } @@ -382,6 +390,9 @@ static void end_gc_not_ok(future_t *ft, int with_lock) ft->runstack - ft->runstack_start, ft->runstack_size); } + + /* FIXME: clear scheme_current_thread->ku.multiple.array ? */ + if (with_lock) pthread_mutex_lock(&gc_ok_m); --gc_not_ok; @@ -724,6 +735,7 @@ void *worker_thread_future_loop(void *arg) scheme_init_os_thread(); GC = g_shared_GC; + scheme_current_thread = g_thread_skeleton; //Set processor affinity /*pthread_mutex_lock(&g_future_queue_mutex); @@ -753,6 +765,7 @@ void *worker_thread_future_loop(void *arg) g_scheme_current_runstack = &scheme_current_runstack; g_scheme_current_runstack_start = &scheme_current_runstack_start; g_jit_future_storage = &jit_future_storage[0]; + g_current_thread = &scheme_current_thread; sema_signal(&ready_sema); wait_for_work: @@ -952,8 +965,31 @@ void *rtcall_alloc_void_pvoid(void (*f)()) END_XFORM_SKIP; } +static void receive_special_result(future_t *f, Scheme_Object *retval) +{ + if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; + + p->ku.multiple.array = f->multiple_array; + p->ku.multiple.count = f->multiple_count; + f->multiple_array = NULL; + } +} + #include "jit_ts_future_glue.c" +static void send_special_result(future_t *f, Scheme_Object *retval) +{ + if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; + + f->multiple_array = p->ku.multiple.array; + f->multiple_count = p->ku.multiple.count; + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; + } +} + //Does the work of actually invoking a primitive on behalf of a //future. This function is always invoked on the main (runtime) //thread. diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 774b7043c9..f7fb0c6eb6 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -72,18 +72,23 @@ typedef struct future_t { Scheme_Bucket *arg_b0; int arg_i0; long arg_l0; + size_t arg_z0; Scheme_Native_Closure_Data *arg_n0; Scheme_Object *arg_s1; Scheme_Object **arg_S1; int arg_i1; long arg_l1; - Scheme_Object **arg_s2; + Scheme_Object *arg_s2; Scheme_Object **arg_S2; int arg_i2; Scheme_Object *retval_s; + void *retval_p; /* use only with conservative GC */ MZ_MARK_STACK_TYPE retval_m; + Scheme_Object **multiple_array; + int multiple_count; + Scheme_Object *retval; struct future_t *prev; struct future_t *next; diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss index b11dc24e51..428c41881c 100644 --- a/src/mzscheme/src/gen-jit-ts.ss +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -8,8 +8,10 @@ [(#\b) "Scheme_Bucket*"] [(#\n) "Scheme_Native_Closure_Data*"] [(#\m) "MZ_MARK_STACK_TYPE"] + [(#\p) "void*"] [(#\i) "int"] [(#\l) "long"] + [(#\z) "size_t"] [(#\v) "void"] [else (error 'char->type "unknown: ~e" c)])) @@ -77,7 +79,8 @@ future_do_runtimecall((void*)f, 0); future = current_ft; @(if (string=? result-type "void") "" @string-append{retval = @|fretval|;}) - @(if (string=? result-type "void") "" @string-append{@|fretval| = NULL;}) + @(if (string=? result-type "void") "" @string-append{@|fretval| = 0;}) + @(if (string=? result-type "Scheme_Object*") @string-append{receive_special_result(future, retval);} "") @(if (string=? result-type "void") "" "return retval;") END_XFORM_SKIP; } @@ -104,6 +107,7 @@ @string-append{future->arg_@|(string t)|@|(number->string i)|}) ", ")); @(if (string=? result-type "void") "" @string-append{future->retval_@(substring ts (sub1 (string-length ts))) = retval;}) + @(if (string=? result-type "Scheme_Object*") @string-append{send_special_result(future, retval);} "") break; } }) @@ -144,7 +148,8 @@ S_s s_v iSi_s - siS_v)) + siS_v + z_p)) (with-output-to-file "jit_ts_def.c" #:exists 'replace diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index e7c08b5c8b..6d96530909 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -9,6 +9,8 @@ v = void b = Scheme_Bucket* n = Scheme_Native_Closure_Data* + p = void*, CGC only + z = size_t m = MZ_MARK_STACK_TYPE */ define_ts_siS_s(_scheme_apply_multi_from_native) @@ -34,8 +36,8 @@ define_ts_l_s(make_ivector) define_ts_l_s(make_vector) #endif #ifdef JIT_PRECISE_GC -define_ts_l_s(GC_malloc_one_small_dirty_tagged) -define_ts_l_s(GC_malloc_one_small_tagged) +define_ts_z_p(GC_malloc_one_small_dirty_tagged) +define_ts_z_p(GC_malloc_one_small_tagged) #endif define_ts_n_s(scheme_make_native_closure) define_ts_n_s(scheme_make_native_case_closure) diff --git a/src/mzscheme/src/jit_ts_def.c b/src/mzscheme/src/jit_ts_def.c index 4add12c66d..2d98325f88 100644 --- a/src/mzscheme/src/jit_ts_def.c +++ b/src/mzscheme/src/jit_ts_def.c @@ -188,3 +188,13 @@ static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ id(g40, g41, g42); \ END_XFORM_SKIP; \ } +#define define_ts_z_p(id) \ +static void* ts_ ## id(size_t g43) \ +{ \ + START_XFORM_SKIP; \ + if (scheme_use_rtcall) \ + return scheme_rtcall_z_p(id, g43); \ + else \ + return id(g43); \ + END_XFORM_SKIP; \ +} diff --git a/src/mzscheme/src/jit_ts_future_glue.c b/src/mzscheme/src/jit_ts_future_glue.c index 894f3cd735..1d152a76b3 100644 --- a/src/mzscheme/src/jit_ts_future_glue.c +++ b/src/mzscheme/src/jit_ts_future_glue.c @@ -1,4 +1,4 @@ - Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g43, int g44, Scheme_Object** g45) + Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g44, int g45, Scheme_Object** g46) { START_XFORM_SKIP; future_t *future; @@ -7,17 +7,18 @@ future = current_ft; future->prim_protocol = SIG_siS_s; future->prim_func = f; - future->arg_s0 = g43; - future->arg_i1 = g44; - future->arg_S2 = g45; + future->arg_s0 = g44; + future->arg_i1 = g45; + future->arg_S2 = g46; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g46, Scheme_Object** g47, Scheme_Object* g48) + Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49) { START_XFORM_SKIP; future_t *future; @@ -26,17 +27,18 @@ future = current_ft; future->prim_protocol = SIG_iSs_s; future->prim_func = f; - future->arg_i0 = g46; - future->arg_S1 = g47; - future->arg_s2 = g48; + future->arg_i0 = g47; + future->arg_S1 = g48; + future->arg_s2 = g49; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g49) + Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g50) { START_XFORM_SKIP; future_t *future; @@ -45,15 +47,16 @@ future = current_ft; future->prim_protocol = SIG_s_s; future->prim_func = f; - future->arg_s0 = g49; + future->arg_s0 = g50; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g50) + Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g51) { START_XFORM_SKIP; future_t *future; @@ -62,11 +65,12 @@ future = current_ft; future->prim_protocol = SIG_n_s; future->prim_func = f; - future->arg_n0 = g50; + future->arg_n0 = g51; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } @@ -83,11 +87,12 @@ future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g51, Scheme_Object* g52) + Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53) { START_XFORM_SKIP; future_t *future; @@ -96,16 +101,17 @@ future = current_ft; future->prim_protocol = SIG_ss_s; future->prim_func = f; - future->arg_s0 = g51; - future->arg_s1 = g52; + future->arg_s0 = g52; + future->arg_s1 = g53; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g53, Scheme_Object* g54) + MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55) { START_XFORM_SKIP; future_t *future; @@ -114,16 +120,17 @@ future = current_ft; future->prim_protocol = SIG_ss_m; future->prim_func = f; - future->arg_s0 = g53; - future->arg_s1 = g54; + future->arg_s0 = g54; + future->arg_s1 = g55; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_m; - future->retval_m = NULL; + future->retval_m = 0; + return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g55, long g56) + Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g56, long g57) { START_XFORM_SKIP; future_t *future; @@ -132,16 +139,17 @@ future = current_ft; future->prim_protocol = SIG_Sl_s; future->prim_func = f; - future->arg_S0 = g55; - future->arg_l1 = g56; + future->arg_S0 = g56; + future->arg_l1 = g57; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g57) + Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g58) { START_XFORM_SKIP; future_t *future; @@ -150,15 +158,16 @@ future = current_ft; future->prim_protocol = SIG_l_s; future->prim_func = f; - future->arg_l0 = g57; + future->arg_l0 = g58; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g58, Scheme_Object* g59, int g60) + void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61) { START_XFORM_SKIP; future_t *future; @@ -167,17 +176,18 @@ future = current_ft; future->prim_protocol = SIG_bsi_v; future->prim_func = f; - future->arg_b0 = g58; - future->arg_s1 = g59; - future->arg_i2 = g60; + future->arg_b0 = g59; + future->arg_s1 = g60; + future->arg_i2 = g61; future_do_runtimecall((void*)f, 0); future = current_ft; + END_XFORM_SKIP; } - void scheme_rtcall_iiS_v(prim_iiS_v f, int g61, int g62, Scheme_Object** g63) + void scheme_rtcall_iiS_v(prim_iiS_v f, int g62, int g63, Scheme_Object** g64) { START_XFORM_SKIP; future_t *future; @@ -186,17 +196,18 @@ future = current_ft; future->prim_protocol = SIG_iiS_v; future->prim_func = f; - future->arg_i0 = g61; - future->arg_i1 = g62; - future->arg_S2 = g63; + future->arg_i0 = g62; + future->arg_i1 = g63; + future->arg_S2 = g64; future_do_runtimecall((void*)f, 0); future = current_ft; + END_XFORM_SKIP; } - void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g64, Scheme_Object* g65) + void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g65, Scheme_Object* g66) { START_XFORM_SKIP; future_t *future; @@ -205,16 +216,17 @@ future = current_ft; future->prim_protocol = SIG_ss_v; future->prim_func = f; - future->arg_s0 = g64; - future->arg_s1 = g65; + future->arg_s0 = g65; + future->arg_s1 = g66; future_do_runtimecall((void*)f, 0); future = current_ft; + END_XFORM_SKIP; } - void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g66) + void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g67) { START_XFORM_SKIP; future_t *future; @@ -223,15 +235,16 @@ future = current_ft; future->prim_protocol = SIG_b_v; future->prim_func = f; - future->arg_b0 = g66; + future->arg_b0 = g67; future_do_runtimecall((void*)f, 0); future = current_ft; + END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g67, long g68) + Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g68, long g69) { START_XFORM_SKIP; future_t *future; @@ -240,16 +253,17 @@ future = current_ft; future->prim_protocol = SIG_sl_s; future->prim_func = f; - future->arg_s0 = g67; - future->arg_l1 = g68; + future->arg_s0 = g68; + future->arg_l1 = g69; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g69, Scheme_Object** g70) + Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g70, Scheme_Object** g71) { START_XFORM_SKIP; future_t *future; @@ -258,16 +272,17 @@ future = current_ft; future->prim_protocol = SIG_iS_s; future->prim_func = f; - future->arg_i0 = g69; - future->arg_S1 = g70; + future->arg_i0 = g70; + future->arg_S1 = g71; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g71) + Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g72) { START_XFORM_SKIP; future_t *future; @@ -276,15 +291,16 @@ future = current_ft; future->prim_protocol = SIG_S_s; future->prim_func = f; - future->arg_S0 = g71; + future->arg_S0 = g72; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g72) + void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g73) { START_XFORM_SKIP; future_t *future; @@ -293,15 +309,16 @@ future = current_ft; future->prim_protocol = SIG_s_v; future->prim_func = f; - future->arg_s0 = g72; + future->arg_s0 = g73; future_do_runtimecall((void*)f, 0); future = current_ft; + END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g73, Scheme_Object** g74, int g75) + Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g74, Scheme_Object** g75, int g76) { START_XFORM_SKIP; future_t *future; @@ -310,17 +327,18 @@ future = current_ft; future->prim_protocol = SIG_iSi_s; future->prim_func = f; - future->arg_i0 = g73; - future->arg_S1 = g74; - future->arg_i2 = g75; + future->arg_i0 = g74; + future->arg_S1 = g75; + future->arg_i2 = g76; future_do_runtimecall((void*)f, 0); future = current_ft; retval = future->retval_s; - future->retval_s = NULL; + future->retval_s = 0; + receive_special_result(future, retval); return retval; END_XFORM_SKIP; } - void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g76, int g77, Scheme_Object** g78) + void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79) { START_XFORM_SKIP; future_t *future; @@ -329,13 +347,32 @@ future = current_ft; future->prim_protocol = SIG_siS_v; future->prim_func = f; - future->arg_s0 = g76; - future->arg_i1 = g77; - future->arg_S2 = g78; + future->arg_s0 = g77; + future->arg_i1 = g78; + future->arg_S2 = g79; future_do_runtimecall((void*)f, 0); future = current_ft; + + END_XFORM_SKIP; +} + void* scheme_rtcall_z_p(prim_z_p f, size_t g80) +{ + START_XFORM_SKIP; + future_t *future; + void* retval; + + future = current_ft; + future->prim_protocol = SIG_z_p; + future->prim_func = f; + future->arg_z0 = g80; + future_do_runtimecall((void*)f, 0); + future = current_ft; + retval = future->retval_p; + future->retval_p = 0; + + return retval; END_XFORM_SKIP; } diff --git a/src/mzscheme/src/jit_ts_protos.h b/src/mzscheme/src/jit_ts_protos.h index f065f74c5d..136bfdad9c 100644 --- a/src/mzscheme/src/jit_ts_protos.h +++ b/src/mzscheme/src/jit_ts_protos.h @@ -1,57 +1,60 @@ #define SIG_siS_s 5 typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**); -Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g115, int g116, Scheme_Object** g117); +Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g118, int g119, Scheme_Object** g120); #define SIG_iSs_s 6 typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*); -Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g118, Scheme_Object** g119, Scheme_Object* g120); +Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g121, Scheme_Object** g122, Scheme_Object* g123); #define SIG_s_s 7 typedef Scheme_Object* (*prim_s_s)(Scheme_Object*); -Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g121); +Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g124); #define SIG_n_s 8 typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Closure_Data*); -Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g122); +Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g125); #define SIG__s 9 typedef Scheme_Object* (*prim__s)(); Scheme_Object* scheme_rtcall__s(prim__s f ); #define SIG_ss_s 10 typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*); -Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g123, Scheme_Object* g124); +Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g126, Scheme_Object* g127); #define SIG_ss_m 11 typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*); -MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g125, Scheme_Object* g126); +MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g128, Scheme_Object* g129); #define SIG_Sl_s 12 typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, long); -Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g127, long g128); +Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g130, long g131); #define SIG_l_s 13 typedef Scheme_Object* (*prim_l_s)(long); -Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g129); +Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g132); #define SIG_bsi_v 14 typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int); -void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g130, Scheme_Object* g131, int g132); +void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g133, Scheme_Object* g134, int g135); #define SIG_iiS_v 15 typedef void (*prim_iiS_v)(int, int, Scheme_Object**); -void scheme_rtcall_iiS_v(prim_iiS_v f, int g133, int g134, Scheme_Object** g135); +void scheme_rtcall_iiS_v(prim_iiS_v f, int g136, int g137, Scheme_Object** g138); #define SIG_ss_v 16 typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*); -void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g136, Scheme_Object* g137); +void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g139, Scheme_Object* g140); #define SIG_b_v 17 typedef void (*prim_b_v)(Scheme_Bucket*); -void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g138); +void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g141); #define SIG_sl_s 18 typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, long); -Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g139, long g140); +Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g142, long g143); #define SIG_iS_s 19 typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**); -Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g141, Scheme_Object** g142); +Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g144, Scheme_Object** g145); #define SIG_S_s 20 typedef Scheme_Object* (*prim_S_s)(Scheme_Object**); -Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g143); +Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g146); #define SIG_s_v 21 typedef void (*prim_s_v)(Scheme_Object*); -void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g144); +void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g147); #define SIG_iSi_s 22 typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int); -Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g145, Scheme_Object** g146, int g147); +Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g148, Scheme_Object** g149, int g150); #define SIG_siS_v 23 typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**); -void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g148, int g149, Scheme_Object** g150); +void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g151, int g152, Scheme_Object** g153); +#define SIG_z_p 24 +typedef void* (*prim_z_p)(size_t); +void* scheme_rtcall_z_p(prim_z_p f, size_t g154); diff --git a/src/mzscheme/src/jit_ts_runtime_glue.c b/src/mzscheme/src/jit_ts_runtime_glue.c index 9ea93cabc5..6fa9143cb1 100644 --- a/src/mzscheme/src/jit_ts_runtime_glue.c +++ b/src/mzscheme/src/jit_ts_runtime_glue.c @@ -5,6 +5,7 @@ case SIG_siS_s: retval = f(future->arg_s0, future->arg_i1, future->arg_S2); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_iSs_s: @@ -14,6 +15,7 @@ case SIG_iSs_s: retval = f(future->arg_i0, future->arg_S1, future->arg_s2); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_s_s: @@ -23,6 +25,7 @@ case SIG_s_s: retval = f(future->arg_s0); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_n_s: @@ -32,6 +35,7 @@ case SIG_n_s: retval = f(future->arg_n0); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG__s: @@ -41,6 +45,7 @@ case SIG__s: retval = f(); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_ss_s: @@ -50,6 +55,7 @@ case SIG_ss_s: retval = f(future->arg_s0, future->arg_s1); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_ss_m: @@ -59,6 +65,7 @@ case SIG_ss_m: retval = f(future->arg_s0, future->arg_s1); future->retval_m = retval; + break; } case SIG_Sl_s: @@ -68,6 +75,7 @@ case SIG_Sl_s: retval = f(future->arg_S0, future->arg_l1); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_l_s: @@ -77,6 +85,7 @@ case SIG_l_s: retval = f(future->arg_l0); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_bsi_v: @@ -86,6 +95,7 @@ case SIG_bsi_v: f(future->arg_b0, future->arg_s1, future->arg_i2); + break; } case SIG_iiS_v: @@ -95,6 +105,7 @@ case SIG_iiS_v: f(future->arg_i0, future->arg_i1, future->arg_S2); + break; } case SIG_ss_v: @@ -104,6 +115,7 @@ case SIG_ss_v: f(future->arg_s0, future->arg_s1); + break; } case SIG_b_v: @@ -113,6 +125,7 @@ case SIG_b_v: f(future->arg_b0); + break; } case SIG_sl_s: @@ -122,6 +135,7 @@ case SIG_sl_s: retval = f(future->arg_s0, future->arg_l1); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_iS_s: @@ -131,6 +145,7 @@ case SIG_iS_s: retval = f(future->arg_i0, future->arg_S1); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_S_s: @@ -140,6 +155,7 @@ case SIG_S_s: retval = f(future->arg_S0); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_s_v: @@ -149,6 +165,7 @@ case SIG_s_v: f(future->arg_s0); + break; } case SIG_iSi_s: @@ -158,6 +175,7 @@ case SIG_iSi_s: retval = f(future->arg_i0, future->arg_S1, future->arg_i2); future->retval_s = retval; + send_special_result(future, retval); break; } case SIG_siS_v: @@ -167,5 +185,16 @@ case SIG_siS_v: f(future->arg_s0, future->arg_i1, future->arg_S2); + + break; + } +case SIG_z_p: + { + prim_z_p f = (prim_z_p)future->prim_func; + void* retval; + retval = + f(future->arg_z0); + future->retval_p = retval; + break; } diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index c680d4c4e2..39d52678fe 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5433,6 +5433,7 @@ static int future_MARK(void *p) { gcMARK(f->arg_S2); gcMARK(f->retval_s); gcMARK(f->retval); + gcMARK(f->multiple_array); gcMARK(f->prev); gcMARK(f->next); gcMARK(f->next_waiting_atomic); @@ -5455,6 +5456,7 @@ static int future_FIXUP(void *p) { gcFIXUP(f->arg_S2); gcFIXUP(f->retval_s); gcFIXUP(f->retval); + gcFIXUP(f->multiple_array); gcFIXUP(f->prev); gcFIXUP(f->next); gcFIXUP(f->next_waiting_atomic); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index ebde7f7438..b772e4f527 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2236,6 +2236,7 @@ future { gcMARK(f->arg_S2); gcMARK(f->retval_s); gcMARK(f->retval); + gcMARK(f->multiple_array); gcMARK(f->prev); gcMARK(f->next); gcMARK(f->next_waiting_atomic); From 1224ad19be64b2bfa77c738c88aaec64ed2328d2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 00:47:44 +0000 Subject: [PATCH 10/92] handle escapes in futures svn: r16910 --- src/mzscheme/src/future.c | 59 ++++++++++++++++++++++++++++++++++++--- src/mzscheme/src/future.h | 1 + 2 files changed, 56 insertions(+), 4 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index fce07075ca..cf6ae59297 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -153,6 +153,15 @@ void *g_funcargs[5]; void *func_retval = NULL; +#ifdef MZ_PRECISE_GC +# define scheme_future_setjmp(newbuf) scheme_jit_setjmp((newbuf).jb) +# define scheme_future_longjmp(newbuf, v) scheme_jit_longjmp((newbuf).jb, v) +#else +# define scheme_future_setjmp(newbuf) scheme_setjmp(newbuf) +# define scheme_future_longjmp(newbuf, v) scheme_longjmp(newbuf, v) +#endif + + /**********************************************************************/ /* Helpers for debugging */ /**********************************************************************/ @@ -582,7 +591,9 @@ int future_ready(Scheme_Object *obj) } static void dequeue_future(future_t *ft) +/* called from both future and runtime threads */ { + START_XFORM_SKIP; if (ft->prev == NULL) { //Set next to be the head of the queue @@ -596,6 +607,7 @@ static void dequeue_future(future_t *ft) if (NULL != ft->next) ft->next->prev = ft->prev; } + END_XFORM_SKIP; } @@ -647,8 +659,6 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) LOG("Successfully touched future %d\n", ft->id); // fflush(stdout); - dequeue_future(ft); - //Increment the number of available pool threads g_num_avail_threads++; pthread_mutex_unlock(&g_future_queue_mutex); @@ -671,6 +681,10 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) goto wait_for_rtcall_or_completion; } + if (!retval) { + scheme_signal_error("touch: future previously aborted"); + } + return retval; } @@ -731,6 +745,7 @@ void *worker_thread_future_loop(void *arg) Scheme_Object* (*jitcode)(Scheme_Object*, int, Scheme_Object**); future_t *ft; int id = *(int *)arg; + mz_jmp_buf newbuf; scheme_init_os_thread(); @@ -811,7 +826,15 @@ void *worker_thread_future_loop(void *arg) //If jitcode asks the runrtime thread to do work, then //a GC can occur. LOG("Running JIT code at %p...\n", ft->code); - v = jitcode(ft->orig_lambda, 0, NULL); + + scheme_current_thread->error_buf = &newbuf; + if (scheme_future_setjmp(newbuf)) { + /* failed */ + v = NULL; + } else { + v = jitcode(ft->orig_lambda, 0, NULL); + } + LOG("Finished running JIT code at %p.\n", ft->code); // Get future again, since a GC may have occurred @@ -827,6 +850,8 @@ void *worker_thread_future_loop(void *arg) //Update the status ft->status = FINISHED; + dequeue_future(ft); + scheme_signal_received_at(g_signal_handle); pthread_mutex_unlock(&g_future_queue_mutex); @@ -922,6 +947,11 @@ void future_do_runtimecall(void *func, pthread_mutex_unlock(&g_future_queue_mutex); + if (future->no_retval) { + future->no_retval = 0; + scheme_future_longjmp(*scheme_current_thread->error_buf, 1); + } + END_XFORM_SKIP; } @@ -993,7 +1023,7 @@ static void send_special_result(future_t *f, Scheme_Object *retval) //Does the work of actually invoking a primitive on behalf of a //future. This function is always invoked on the main (runtime) //thread. -void invoke_rtcall(future_t *future) +static void do_invoke_rtcall(future_t *future) /* Called in runtime thread */ { #ifdef DEBUG_FUTURES @@ -1035,6 +1065,27 @@ void invoke_rtcall(future_t *future) pthread_mutex_unlock(&g_future_queue_mutex); } +static void invoke_rtcall(future_t * volatile future) +{ + Scheme_Thread *p = scheme_current_thread; + mz_jmp_buf newbuf, * volatile savebuf; + + savebuf = p->error_buf; + p->error_buf = &newbuf; + if (scheme_setjmp(newbuf)) { + pthread_mutex_lock(&g_future_queue_mutex); + future->no_retval = 1; + //Signal the waiting worker thread that it + //can continue running machine code + pthread_cond_signal(future->can_continue_cv); + pthread_mutex_unlock(&g_future_queue_mutex); + scheme_longjmp(*savebuf, 1); + } else { + do_invoke_rtcall(future); + } + p->error_buf = savebuf; +} + /**********************************************************************/ /* Helpers for manipulating the futures queue */ diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index f7fb0c6eb6..6b5007ff0b 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -85,6 +85,7 @@ typedef struct future_t { Scheme_Object *retval_s; void *retval_p; /* use only with conservative GC */ MZ_MARK_STACK_TYPE retval_m; + int no_retval; Scheme_Object **multiple_array; int multiple_count; From b064ebfa751f255c7bf4b454e64920e8966f767d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 02:24:54 +0000 Subject: [PATCH 11/92] fix an old JIT optimization; more future logging; trampolined tail calls in futures svn: r16911 --- src/mzscheme/src/future.c | 14 ++++++++++++++ src/mzscheme/src/future.h | 4 ++++ src/mzscheme/src/gen-jit-ts.ss | 1 + src/mzscheme/src/jit.c | 8 +++++++- src/mzscheme/src/jit_ts_def.c | 20 ++++++++++++++++++++ src/mzscheme/src/mzmark.c | 4 ++++ src/mzscheme/src/mzmarksrc.c | 2 ++ 7 files changed, 52 insertions(+), 1 deletion(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index cf6ae59297..b10d589a2c 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -1003,6 +1003,12 @@ static void receive_special_result(future_t *f, Scheme_Object *retval) p->ku.multiple.array = f->multiple_array; p->ku.multiple.count = f->multiple_count; f->multiple_array = NULL; + } else if (SAME_OBJ(retval, SCHEME_TAIL_CALL_WAITING)) { + Scheme_Thread *p = scheme_current_thread; + + p->ku.apply.tail_rator = f->tail_rator; + p->ku.apply.tail_rands = f->tail_rands; + p->ku.apply.tail_num_rands = f->num_tail_rands; } } @@ -1017,6 +1023,14 @@ static void send_special_result(future_t *f, Scheme_Object *retval) f->multiple_count = p->ku.multiple.count; if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) p->values_buffer = NULL; + } else if (SAME_OBJ(retval, SCHEME_TAIL_CALL_WAITING)) { + Scheme_Thread *p = scheme_current_thread; + + f->tail_rator = p->ku.apply.tail_rator; + f->tail_rands = p->ku.apply.tail_rands; + f->num_tail_rands = p->ku.apply.tail_num_rands; + p->ku.apply.tail_rator = NULL; + p->ku.apply.tail_rands = NULL; } } diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 6b5007ff0b..2db66dfc7a 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -90,6 +90,10 @@ typedef struct future_t { Scheme_Object **multiple_array; int multiple_count; + Scheme_Object *tail_rator; + Scheme_Object **tail_rands; + int num_tail_rands; + Scheme_Object *retval; struct future_t *prev; struct future_t *next; diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss index 428c41881c..e7413ce057 100644 --- a/src/mzscheme/src/gen-jit-ts.ss +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -43,6 +43,7 @@ static @|result-type| ts_ ## id(@|args|) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ @|return| scheme_rtcall_@|t|(id, @(string-join arg-names ", ")); \ else \ diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index e75936874b..413b4e8db7 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -380,6 +380,12 @@ static void *decrement_cache_stack_pos(void *p) THREAD_LOCAL_DECL(static Scheme_Object **fixup_runstack_base); THREAD_LOCAL_DECL(static int fixup_already_in_place); +/* FIXME?: If _scheme_tail_apply_from_native_fixup_args is called from + a future thread, then the wrong thread-local `fixup_runstack_base' + was set. But exercising this code seems to be impossible, maybe + because current bytecode optimizations never produce the case that + _scheme_tail_apply_from_native_fixup_args() was design to support. */ + static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator, int argc, Scheme_Object **argv) @@ -3274,7 +3280,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ && !(SCHEME_LOCAL_FLAGS(v) & SCHEME_LOCAL_OTHER_CLEARS)) { int pos; pos = mz_remap(SCHEME_LOCAL_POS(v)); - if (pos == (jitter->depth + args_already_in_place)) + if (pos == (jitter->depth + jitter->extra_pushed + args_already_in_place)) args_already_in_place++; else break; diff --git a/src/mzscheme/src/jit_ts_def.c b/src/mzscheme/src/jit_ts_def.c index 2d98325f88..838dadf60d 100644 --- a/src/mzscheme/src/jit_ts_def.c +++ b/src/mzscheme/src/jit_ts_def.c @@ -2,6 +2,7 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_siS_s(id, g7, g8, g9); \ else \ @@ -12,6 +13,7 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_iSs_s(id, g10, g11, g12); \ else \ @@ -22,6 +24,7 @@ static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12 static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_s_s(id, g13); \ else \ @@ -32,6 +35,7 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_n_s(id, g14); \ else \ @@ -42,6 +46,7 @@ static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ static Scheme_Object* ts_ ## id() \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall__s(id, ); \ else \ @@ -52,6 +57,7 @@ static Scheme_Object* ts_ ## id() \ static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_ss_s(id, g15, g16); \ else \ @@ -62,6 +68,7 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_ss_m(id, g17, g18); \ else \ @@ -72,6 +79,7 @@ static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_Sl_s(id, g19, g20); \ else \ @@ -82,6 +90,7 @@ static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ static Scheme_Object* ts_ ## id(long g21) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_l_s(id, g21); \ else \ @@ -92,6 +101,7 @@ static Scheme_Object* ts_ ## id(long g21) \ static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ scheme_rtcall_bsi_v(id, g22, g23, g24); \ else \ @@ -102,6 +112,7 @@ static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ scheme_rtcall_iiS_v(id, g25, g26, g27); \ else \ @@ -112,6 +123,7 @@ static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ scheme_rtcall_ss_v(id, g28, g29); \ else \ @@ -122,6 +134,7 @@ static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ static void ts_ ## id(Scheme_Bucket* g30) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ scheme_rtcall_b_v(id, g30); \ else \ @@ -132,6 +145,7 @@ static void ts_ ## id(Scheme_Bucket* g30) \ static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_sl_s(id, g31, g32); \ else \ @@ -142,6 +156,7 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_iS_s(id, g33, g34); \ else \ @@ -152,6 +167,7 @@ static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_S_s(id, g35); \ else \ @@ -162,6 +178,7 @@ static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ static void ts_ ## id(Scheme_Object* g36) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ scheme_rtcall_s_v(id, g36); \ else \ @@ -172,6 +189,7 @@ static void ts_ ## id(Scheme_Object* g36) \ static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_iSi_s(id, g37, g38, g39); \ else \ @@ -182,6 +200,7 @@ static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ scheme_rtcall_siS_v(id, g40, g41, g42); \ else \ @@ -192,6 +211,7 @@ static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ static void* ts_ ## id(size_t g43) \ { \ START_XFORM_SKIP; \ + LOG_PRIM_START(&id); \ if (scheme_use_rtcall) \ return scheme_rtcall_z_p(id, g43); \ else \ diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 39d52678fe..db5cbca0e4 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5434,6 +5434,8 @@ static int future_MARK(void *p) { gcMARK(f->retval_s); gcMARK(f->retval); gcMARK(f->multiple_array); + gcMARK(f->tail_rator); + gcMARK(f->tail_rands); gcMARK(f->prev); gcMARK(f->next); gcMARK(f->next_waiting_atomic); @@ -5457,6 +5459,8 @@ static int future_FIXUP(void *p) { gcFIXUP(f->retval_s); gcFIXUP(f->retval); gcFIXUP(f->multiple_array); + gcFIXUP(f->tail_rator); + gcFIXUP(f->tail_rands); gcFIXUP(f->prev); gcFIXUP(f->next); gcFIXUP(f->next_waiting_atomic); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index b772e4f527..47c96e960c 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2237,6 +2237,8 @@ future { gcMARK(f->retval_s); gcMARK(f->retval); gcMARK(f->multiple_array); + gcMARK(f->tail_rator); + gcMARK(f->tail_rands); gcMARK(f->prev); gcMARK(f->next); gcMARK(f->next_waiting_atomic); From 1e98ff1667cca9908449a235906d0f9314cbcbcf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 03:22:10 +0000 Subject: [PATCH 12/92] change to future logging svn: r16912 --- src/mzscheme/src/eval.c | 6 -- src/mzscheme/src/future.c | 34 +++------- src/mzscheme/src/future.h | 31 ++------- src/mzscheme/src/gen-jit-ts.ss | 6 +- src/mzscheme/src/jit.c | 17 +++-- src/mzscheme/src/jit_ts_def.c | 120 ++++++++++++++++----------------- src/mzscheme/src/schnapp.inc | 6 -- 7 files changed, 89 insertions(+), 131 deletions(-) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index a67fb259fa..08725e0da4 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -7860,13 +7860,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, f = prim->prim_val; - #ifdef FUTURES_ENABLED - LOG_PRIM_START(f); - #endif v = f(num_rands, rands, (Scheme_Object *)prim); - #ifdef FUTURES_ENABLED - LOG_PRIM_END(f); - #endif DEBUG_CHECK_TYPE(v); } else if (type == scheme_closure_type) { diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index b10d589a2c..c6f8734664 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -468,43 +468,31 @@ void scheme_future_gc_pause() /* Primitive implementations */ /**********************************************************************/ -static long start_ms = 0; - Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]) { - //Get the start time - struct timeval now; - long ms; - gettimeofday(&now, NULL); - - start_ms = now.tv_usec / 1000.0; - g_print_prims = 1; - printf("Primitive tracking started at "); - print_ms_and_us(); - printf("\n"); return scheme_void; } Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]) { g_print_prims = 0; - printf("Primitive tracking ended at "); - print_ms_and_us(); - printf("\n"); return scheme_void; } -void print_ms_and_us() +void scheme_log_future_to_runtime(const char *who, void *p) +/* Called in future thread */ { - struct timeval now; - long ms, us; - gettimeofday(&now, NULL); + START_XFORM_SKIP; - //ms = (now.tv_sec * 1000.0) - start_ms; - ms = (now.tv_usec / 1000) - start_ms; - us = now.tv_usec - (ms * 1000) - (start_ms * 1000); - printf("%ld.%ld", ms, us); + if (g_print_prims) { + if (p) + fprintf(stderr, "%p at %lf\n", p, scheme_get_inexact_milliseconds()); + else + fprintf(stderr, "%s at %lf\n", who, scheme_get_inexact_milliseconds()); + } + + END_XFORM_SKIP; } Scheme_Object *future(int argc, Scheme_Object *argv[]) diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 2db66dfc7a..c0d7994a09 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -119,33 +119,12 @@ extern void clear_futures(void); #endif //Primitive instrumentation stuff -extern int g_print_prims; -extern void print_ms_and_us(void); -#define LOG_PRIM_START(p) \ - if (g_print_prims) \ - { \ - printf("%p ", p); \ - print_ms_and_us(); \ - printf("\n"); \ - } -#define LOG_PRIM_END(p) -/* -#define LOG_PRIM_END(p) \ - if (g_print_prims) \ - { \ - print_ms_and_us(); \ - printf("\n"); \ - } -*/ - -#define LOG_PRIM_W_NAME(name) \ - if (g_print_prims) \ - { \ - printf("%s ", name); \ - print_ms_and_us(); \ - printf("\n"); \ - } +extern void scheme_log_future_to_runtime(const char *who, void *addr); +#define LOG_PRIM_START(p) scheme_log_future_to_runtime(# p, NULL) +#define LOG_PRIM_END(p) /* empty */ +#define LOG_PRIM_W_NAME(name) scheme_log_future_to_runtime(name, NULL) +#define LOG_PRIM_W_ADDR(addr) scheme_log_future_to_runtime(NULL, addr) //Signature flags for primitive invocations //Here the convention is SIG_[arg1type]_[arg2type]..._[return type] diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss index e7413ce057..e8b102bc98 100644 --- a/src/mzscheme/src/gen-jit-ts.ss +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -43,10 +43,10 @@ static @|result-type| ts_ ## id(@|args|) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ @|return| scheme_rtcall_@|t|(id, @(string-join arg-names ", ")); \ - else \ + } else \ @|return| id(@(string-join arg-names ", ")); \ END_XFORM_SKIP; \ }}) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 413b4e8db7..d61b91d4cc 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2168,11 +2168,12 @@ static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) { START_XFORM_SKIP; - if (scheme_use_rtcall) + if (scheme_use_rtcall) { + LOG_PRIM_W_ADDR(proc); return scheme_rtcall_iS_s(proc, argc, MZ_RUNSTACK); - else + } else return proc(argc, MZ_RUNSTACK); END_XFORM_SKIP; @@ -2181,9 +2182,10 @@ static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc { START_XFORM_SKIP; - if (scheme_use_rtcall) + if (scheme_use_rtcall) { + LOG_PRIM_W_ADDR(proc); return scheme_rtcall_iSs_s(proc, argc, MZ_RUNSTACK, self); - else + } else return proc(argc, MZ_RUNSTACK, self); END_XFORM_SKIP; @@ -2196,9 +2198,10 @@ static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc static void ts_on_demand(void) { START_XFORM_SKIP; - if (scheme_use_rtcall) + if (scheme_use_rtcall) { + LOG_PRIM_START(on_demand); rtcall_void_void_3args(on_demand_with_args); - else + } else on_demand(); END_XFORM_SKIP; } @@ -2208,9 +2211,9 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) { START_XFORM_SKIP; void *ret; - LOG_PRIM_START(&prepare_retry_alloc); if (scheme_use_rtcall) { + LOG_PRIM_START(prepare_retry_alloc); jit_future_storage[0] = p; jit_future_storage[1] = p2; ret = rtcall_alloc_void_pvoid(GC_make_jit_nursery_page); diff --git a/src/mzscheme/src/jit_ts_def.c b/src/mzscheme/src/jit_ts_def.c index 838dadf60d..d606a61223 100644 --- a/src/mzscheme/src/jit_ts_def.c +++ b/src/mzscheme/src/jit_ts_def.c @@ -2,10 +2,10 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_siS_s(id, g7, g8, g9); \ - else \ + } else \ return id(g7, g8, g9); \ END_XFORM_SKIP; \ } @@ -13,10 +13,10 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_iSs_s(id, g10, g11, g12); \ - else \ + } else \ return id(g10, g11, g12); \ END_XFORM_SKIP; \ } @@ -24,10 +24,10 @@ static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12 static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_s_s(id, g13); \ - else \ + } else \ return id(g13); \ END_XFORM_SKIP; \ } @@ -35,10 +35,10 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_n_s(id, g14); \ - else \ + } else \ return id(g14); \ END_XFORM_SKIP; \ } @@ -46,10 +46,10 @@ static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ static Scheme_Object* ts_ ## id() \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall__s(id, ); \ - else \ + } else \ return id(); \ END_XFORM_SKIP; \ } @@ -57,10 +57,10 @@ static Scheme_Object* ts_ ## id() \ static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_ss_s(id, g15, g16); \ - else \ + } else \ return id(g15, g16); \ END_XFORM_SKIP; \ } @@ -68,10 +68,10 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_ss_m(id, g17, g18); \ - else \ + } else \ return id(g17, g18); \ END_XFORM_SKIP; \ } @@ -79,10 +79,10 @@ static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_Sl_s(id, g19, g20); \ - else \ + } else \ return id(g19, g20); \ END_XFORM_SKIP; \ } @@ -90,10 +90,10 @@ static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ static Scheme_Object* ts_ ## id(long g21) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_l_s(id, g21); \ - else \ + } else \ return id(g21); \ END_XFORM_SKIP; \ } @@ -101,10 +101,10 @@ static Scheme_Object* ts_ ## id(long g21) \ static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ scheme_rtcall_bsi_v(id, g22, g23, g24); \ - else \ + } else \ id(g22, g23, g24); \ END_XFORM_SKIP; \ } @@ -112,10 +112,10 @@ static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ scheme_rtcall_iiS_v(id, g25, g26, g27); \ - else \ + } else \ id(g25, g26, g27); \ END_XFORM_SKIP; \ } @@ -123,10 +123,10 @@ static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ scheme_rtcall_ss_v(id, g28, g29); \ - else \ + } else \ id(g28, g29); \ END_XFORM_SKIP; \ } @@ -134,10 +134,10 @@ static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ static void ts_ ## id(Scheme_Bucket* g30) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ scheme_rtcall_b_v(id, g30); \ - else \ + } else \ id(g30); \ END_XFORM_SKIP; \ } @@ -145,10 +145,10 @@ static void ts_ ## id(Scheme_Bucket* g30) \ static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_sl_s(id, g31, g32); \ - else \ + } else \ return id(g31, g32); \ END_XFORM_SKIP; \ } @@ -156,10 +156,10 @@ static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_iS_s(id, g33, g34); \ - else \ + } else \ return id(g33, g34); \ END_XFORM_SKIP; \ } @@ -167,10 +167,10 @@ static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_S_s(id, g35); \ - else \ + } else \ return id(g35); \ END_XFORM_SKIP; \ } @@ -178,10 +178,10 @@ static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ static void ts_ ## id(Scheme_Object* g36) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ scheme_rtcall_s_v(id, g36); \ - else \ + } else \ id(g36); \ END_XFORM_SKIP; \ } @@ -189,10 +189,10 @@ static void ts_ ## id(Scheme_Object* g36) \ static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_iSi_s(id, g37, g38, g39); \ - else \ + } else \ return id(g37, g38, g39); \ END_XFORM_SKIP; \ } @@ -200,10 +200,10 @@ static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ scheme_rtcall_siS_v(id, g40, g41, g42); \ - else \ + } else \ id(g40, g41, g42); \ END_XFORM_SKIP; \ } @@ -211,10 +211,10 @@ static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ static void* ts_ ## id(size_t g43) \ { \ START_XFORM_SKIP; \ - LOG_PRIM_START(&id); \ - if (scheme_use_rtcall) \ + if (scheme_use_rtcall) { \ + LOG_PRIM_START(id); \ return scheme_rtcall_z_p(id, g43); \ - else \ + } else \ return id(g43); \ END_XFORM_SKIP; \ } diff --git a/src/mzscheme/src/schnapp.inc b/src/mzscheme/src/schnapp.inc index 57f1e38441..c045d7ef66 100644 --- a/src/mzscheme/src/schnapp.inc +++ b/src/mzscheme/src/schnapp.inc @@ -31,13 +31,7 @@ static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator, } f = (Scheme_Primitive_Closure_Proc *)prim->prim_val; - #ifdef FUTURES_ENABLED - LOG_PRIM_START(f); - #endif v = f(argc, argv, (Scheme_Object *)prim); - #ifdef FUTURES_ENABLED - LOG_PRIM_END(f); - #endif #if PRIM_CHECK_VALUE if (v == SCHEME_TAIL_CALL_WAITING) { From d5f50056b1afb7898f5b448c18ecee96e3bdb1d9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 04:19:37 +0000 Subject: [PATCH 13/92] revise future logging to report names and use the main logger svn: r16914 --- src/mzscheme/src/env.c | 31 +++++ src/mzscheme/src/error.c | 1 - src/mzscheme/src/fun.c | 3 + src/mzscheme/src/future.c | 97 +++++--------- src/mzscheme/src/future.h | 19 +-- src/mzscheme/src/gen-jit-ts.ss | 18 ++- src/mzscheme/src/jit.c | 23 ++-- src/mzscheme/src/jit_ts.c | 114 ++++++++-------- src/mzscheme/src/jit_ts_def.c | 180 ++++++++++++-------------- src/mzscheme/src/jit_ts_future_glue.c | 140 +++++++++++++++++--- src/mzscheme/src/jit_ts_protos.h | 40 +++--- src/mzscheme/src/schpriv.h | 1 + 12 files changed, 376 insertions(+), 291 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index a4c4d2ac19..c98945537b 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1361,6 +1361,37 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void) return result; } +const char *scheme_look_for_primitive(void *code) +{ + Scheme_Bucket_Table *ht; + Scheme_Bucket **bs; + Scheme_Env *kenv; + long i; + int j; + + for (j = 0; j < 2; j++) { + if (!j) + kenv = kernel_env; + else + kenv = unsafe_env; + + ht = kenv->toplevel; + bs = ht->buckets; + + for (i = ht->size; i--; ) { + Scheme_Bucket *b = bs[i]; + if (b && b->val) { + if (SCHEME_PRIMP(b->val)) { + if (SCHEME_PRIM(b->val) == code) + return ((Scheme_Primitive_Proc *)b->val)->name; + } + } + } + } + + return NULL; +} + /*========================================================================*/ /* compile-time env, constructors and simple queries */ /*========================================================================*/ diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 1bb6fa88e2..0ba8526b9a 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -343,7 +343,6 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch case 'f': { double f; - j++; f = dbls[dp++]; sprintf(buf, "%f", f); t = buf; diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index bf32589335..c47c12e119 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -7972,7 +7972,9 @@ long scheme_get_milliseconds(void) } double scheme_get_inexact_milliseconds(void) +/* this function can be called from any OS thread */ { + START_XFORM_SKIP; #ifdef USE_MACTIME { UnsignedWide time; @@ -7997,6 +7999,7 @@ double scheme_get_inexact_milliseconds(void) # endif # endif #endif + END_XFORM_SKIP; } long scheme_get_process_milliseconds(void) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index c6f8734664..a2754c27cb 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -5,7 +5,6 @@ //This will be TRUE if primitive tracking has been enabled //by the program -int g_print_prims = 0; #ifndef FUTURES_ENABLED @@ -29,18 +28,6 @@ static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) return NULL; } -static Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]) -{ - scheme_signal_error("start-primitive-tracking: not enabled"); - return NULL; -} - -static Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]) -{ - scheme_signal_error("end-primitive-tracking: not enabled"); - return NULL; -} - # define FUTURE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) void scheme_init_futures(Scheme_Env *env) @@ -53,8 +40,6 @@ void scheme_init_futures(Scheme_Env *env) FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); FUTURE_PRIM_W_ARITY("processor-count", processor_count, 1, 1, newenv); - FUTURE_PRIM_W_ARITY("start-primitive-tracking", start_primitive_tracking, 0, 0, newenv); - FUTURE_PRIM_W_ARITY("end-primitive-tracking", end_primitive_tracking, 0, 0, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -299,24 +284,6 @@ void scheme_init_futures(Scheme_Env *env) 1), newenv); - scheme_add_global_constant( - "start-primitive-tracking", - scheme_make_prim_w_arity( - start_primitive_tracking, - "start-primitive-tracking", - 0, - 0), - newenv); - - scheme_add_global_constant( - "end-primitive-tracking", - scheme_make_prim_w_arity( - end_primitive_tracking, - "end-primitive-tracking", - 0, - 0), - newenv); - scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); @@ -468,33 +435,6 @@ void scheme_future_gc_pause() /* Primitive implementations */ /**********************************************************************/ -Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]) -{ - g_print_prims = 1; - return scheme_void; -} - -Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]) -{ - g_print_prims = 0; - return scheme_void; -} - -void scheme_log_future_to_runtime(const char *who, void *p) -/* Called in future thread */ -{ - START_XFORM_SKIP; - - if (g_print_prims) { - if (p) - fprintf(stderr, "%p at %lf\n", p, scheme_get_inexact_milliseconds()); - else - fprintf(stderr, "%s at %lf\n", who, scheme_get_inexact_milliseconds()); - } - - END_XFORM_SKIP; -} - Scheme_Object *future(int argc, Scheme_Object *argv[]) /* Called in runtime thread */ { @@ -947,19 +887,24 @@ void future_do_runtimecall(void *func, /**********************************************************************/ /* Functions for primitive invocation */ /**********************************************************************/ -void rtcall_void_void_3args(void (*f)()) +void scheme_rtcall_void_void_3args(const char *who, int src_type, void (*f)()) /* Called in future thread */ { START_XFORM_SKIP; + future_t *future = current_ft; - current_ft->prim_protocol = SIG_VOID_VOID_3ARGS; + future->prim_protocol = SIG_VOID_VOID_3ARGS; + + future->time_of_request = scheme_get_inexact_milliseconds(); + future->source_of_request = who; + future->source_type = src_type; future_do_runtimecall((void*)f, 1); END_XFORM_SKIP; } -void *rtcall_alloc_void_pvoid(void (*f)()) +void *scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, void (*f)()) /* Called in future thread */ { START_XFORM_SKIP; @@ -967,7 +912,12 @@ void *rtcall_alloc_void_pvoid(void (*f)()) void *retval; while (1) { - current_ft->prim_protocol = SIG_ALLOC_VOID_PVOID; + future = current_ft; + 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_do_runtimecall((void*)f, 1); @@ -1034,6 +984,25 @@ static void do_invoke_rtcall(future_t *future) future->rt_prim = 0; + if (scheme_log_level_p(scheme_main_logger, SCHEME_LOG_DEBUG)) { + const char *src; + + src = future->source_of_request; + if (future->source_type == FSRC_RATOR) { + int len; + src = scheme_get_proc_name(future->arg_s0, &len, 1); + } else if (future->source_type == FSRC_PRIM) { + const char *src2; + src2 = scheme_look_for_primitive(future->prim_func); + if (src2) src = src2; + } + + scheme_log(scheme_main_logger, SCHEME_LOG_DEBUG, 0, + "future: waiting for runtime at %f: %s", + future->time_of_request, + src); + } + switch (future->prim_protocol) { case SIG_VOID_VOID_3ARGS: diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index c0d7994a09..0d51b00c69 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -32,7 +32,7 @@ extern Scheme_Object *processor_count(int argc, Scheme_Object *argv[]); extern void futures_init(void); typedef void (*prim_void_void_3args_t)(Scheme_Object **); -typedef void *(*prim_alloc_void_pvoid_t)(void); +typedef void *(*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*); @@ -43,6 +43,10 @@ typedef void* (*prim_pvoid_pvoid_pvoid_t)(void*, void*); #define WAITING_FOR_PRIM 2 #define FINISHED 3 +#define FSRC_OTHER 0 +#define FSRC_RATOR 1 +#define FSRC_PRIM 2 + typedef struct future_t { Scheme_Object so; @@ -61,6 +65,9 @@ typedef struct future_t { //Runtime call stuff int rt_prim; /* flag to indicate waiting for a prim call */ int rt_prim_is_atomic; + double time_of_request; + const char *source_of_request; + int source_type; void *alloc_retval; int alloc_retval_counter; @@ -120,12 +127,6 @@ extern void clear_futures(void); //Primitive instrumentation stuff -extern void scheme_log_future_to_runtime(const char *who, void *addr); -#define LOG_PRIM_START(p) scheme_log_future_to_runtime(# p, NULL) -#define LOG_PRIM_END(p) /* empty */ -#define LOG_PRIM_W_NAME(name) scheme_log_future_to_runtime(name, NULL) -#define LOG_PRIM_W_ADDR(addr) scheme_log_future_to_runtime(NULL, addr) - //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 @@ -143,8 +144,8 @@ extern void scheme_log_future_to_runtime(const char *who, void *addr); /*GDB_BREAK;*/ \ } -extern void rtcall_void_void_3args(void (*f)()); -extern void *rtcall_alloc_void_pvoid(void (*f)()); +extern void scheme_rtcall_void_void_3args(const char *who, int src_type, void (*f)()); +extern void *scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, void (*f)()); #else diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss index e8b102bc98..7d4928c723 100644 --- a/src/mzscheme/src/gen-jit-ts.ss +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -39,14 +39,13 @@ (define args (make-arg-list arg-types arg-names)) (define ts (symbol->string t)) (for-each display - @list{#define define_ts_@|ts|(id) \ + @list{#define define_ts_@|ts|(id, src_type) \ static @|result-type| ts_ ## id(@|args|) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - @|return| scheme_rtcall_@|t|(id, @(string-join arg-names ", ")); \ - } else \ + if (scheme_use_rtcall) \ + @|return| scheme_rtcall_@|t|("[" #id "]", src_type, id, @(string-join arg-names ", ")); \ + else \ @|return| id(@(string-join arg-names ", ")); \ END_XFORM_SKIP; \ }}) @@ -62,15 +61,20 @@ (for-each display @list{ - @|result-type| scheme_rtcall_@|ts|(prim_@|ts| f@|(if (null? arg-types) "" ",")| @|args|) + @|result-type| scheme_rtcall_@|ts|(const char *who, int src_type, prim_@|ts| f@|(if (null? arg-types) "" ",")| @|args|) { START_XFORM_SKIP; future_t *future; + double tm; @(if (string=? result-type "void") "" @string-append{@|result-type| retval;}) future = current_ft; future->prim_protocol = SIG_@|ts|; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; @(string-join (for/list ([t (in-string (type->arg-string t))] [a arg-names] @@ -127,7 +131,7 @@ (display @string-append{typedef @|result-type| (*prim_@|ts|)(@(string-join arg-types ", "));}) (newline) - (display @string-append{@|result-type| scheme_rtcall_@|ts|(prim_@|ts| f@(if (null? arg-types) "" ",") @|args|);}) + (display @string-append{@|result-type| scheme_rtcall_@|ts|(const char *who, int src_type, prim_@|ts| f@(if (null? arg-types) "" ",") @|args|);}) (newline)) (define types diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index d61b91d4cc..a944f94a8d 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2168,12 +2168,13 @@ static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) { START_XFORM_SKIP; - if (scheme_use_rtcall) { - LOG_PRIM_W_ADDR(proc); - return scheme_rtcall_iS_s(proc, + if (scheme_use_rtcall) + return scheme_rtcall_iS_s("[prim_indirect]", + FSRC_PRIM, + proc, argc, MZ_RUNSTACK); - } else + else return proc(argc, MZ_RUNSTACK); END_XFORM_SKIP; @@ -2182,10 +2183,9 @@ static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc { START_XFORM_SKIP; - if (scheme_use_rtcall) { - LOG_PRIM_W_ADDR(proc); - return scheme_rtcall_iSs_s(proc, argc, MZ_RUNSTACK, self); - } else + if (scheme_use_rtcall) + return scheme_rtcall_iSs_s("[prim_indirect]", FSRC_PRIM, proc, argc, MZ_RUNSTACK, self); + else return proc(argc, MZ_RUNSTACK, self); END_XFORM_SKIP; @@ -2199,8 +2199,7 @@ static void ts_on_demand(void) { START_XFORM_SKIP; if (scheme_use_rtcall) { - LOG_PRIM_START(on_demand); - rtcall_void_void_3args(on_demand_with_args); + scheme_rtcall_void_void_3args("[jit_on_demand]", FSRC_OTHER, on_demand_with_args); } else on_demand(); END_XFORM_SKIP; @@ -2213,10 +2212,9 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) void *ret; if (scheme_use_rtcall) { - LOG_PRIM_START(prepare_retry_alloc); jit_future_storage[0] = p; jit_future_storage[1] = p2; - ret = rtcall_alloc_void_pvoid(GC_make_jit_nursery_page); + ret = scheme_rtcall_alloc_void_pvoid("[acquire_gc_page]", FSRC_OTHER, GC_make_jit_nursery_page); GC_gen0_alloc_page_ptr = ret; retry_alloc_r1 = jit_future_storage[1]; p = jit_future_storage[0]; @@ -2226,7 +2224,6 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) } ret = prepare_retry_alloc(p, p2); - LOG_PRIM_END(&prepare_retry_alloc); return ret; END_XFORM_SKIP; } diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index 6d96530909..1b778e1f7c 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -13,69 +13,69 @@ z = size_t m = MZ_MARK_STACK_TYPE */ -define_ts_siS_s(_scheme_apply_multi_from_native) -define_ts_siS_s(_scheme_apply_from_native) -define_ts_siS_s(_scheme_tail_apply_from_native) -define_ts_siS_s(_scheme_tail_apply_from_native_fixup_args) -define_ts_s_s(scheme_force_value_same_mark) -define_ts_s_s(scheme_force_one_value_same_mark) +define_ts_siS_s(_scheme_apply_multi_from_native, FSRC_RATOR) +define_ts_siS_s(_scheme_apply_from_native, FSRC_RATOR) +define_ts_siS_s(_scheme_tail_apply_from_native, FSRC_RATOR) +define_ts_siS_s(_scheme_tail_apply_from_native_fixup_args, FSRC_RATOR) +define_ts_s_s(scheme_force_value_same_mark, FSRC_OTHER) +define_ts_s_s(scheme_force_one_value_same_mark, FSRC_OTHER) #if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC) -define_ts__s(malloc_double) +define_ts__s(malloc_double, FSRC_OTHER) #endif -define_ts_s_s(scheme_box) +define_ts_s_s(scheme_box, FSRC_OTHER) #ifndef CAN_INLINE_ALLOC -define_ts_ss_s(scheme_make_mutable_pair) -define_ts_Sl_s(make_list_star) -define_ts_Sl_s(make_list) -define_ts_ss_s(scheme_make_pair) -define_ts_s_s(make_one_element_ivector) -define_ts_s_s(make_one_element_vector) -define_ts_ss_s(make_two_element_ivector) -define_ts_ss_s(make_two_element_vector) -define_ts_l_s(make_ivector) -define_ts_l_s(make_vector) +define_ts_ss_s(scheme_make_mutable_pair, FSRC_OTHER) +define_ts_Sl_s(make_list_star, FSRC_OTHER) +define_ts_Sl_s(make_list, FSRC_OTHER) +define_ts_ss_s(scheme_make_pair, FSRC_OTHER) +define_ts_s_s(make_one_element_ivector, FSRC_OTHER) +define_ts_s_s(make_one_element_vector, FSRC_OTHER) +define_ts_ss_s(make_two_element_ivector, FSRC_OTHER) +define_ts_ss_s(make_two_element_vector, FSRC_OTHER) +define_ts_l_s(make_ivector, FSRC_OTHER) +define_ts_l_s(make_vector, FSRC_OTHER) #endif #ifdef JIT_PRECISE_GC -define_ts_z_p(GC_malloc_one_small_dirty_tagged) -define_ts_z_p(GC_malloc_one_small_tagged) +define_ts_z_p(GC_malloc_one_small_dirty_tagged, FSRC_OTHER) +define_ts_z_p(GC_malloc_one_small_tagged, FSRC_OTHER) #endif -define_ts_n_s(scheme_make_native_closure) -define_ts_n_s(scheme_make_native_case_closure) -define_ts_bsi_v(call_set_global_bucket) -define_ts_s_s(scheme_make_envunbox) -define_ts_s_s(make_global_ref) -define_ts_iiS_v(lexical_binding_wrong_return_arity) -define_ts_ss_m(scheme_set_cont_mark) -define_ts_iiS_v(call_wrong_return_arity) -define_ts_b_v(scheme_unbound_global) -define_ts_Sl_s(scheme_delayed_rename) -define_ts_iS_s(scheme_checked_car) -define_ts_iS_s(scheme_checked_cdr) -define_ts_iS_s(scheme_checked_caar) -define_ts_iS_s(scheme_checked_cadr) -define_ts_iS_s(scheme_checked_cdar) -define_ts_iS_s(scheme_checked_cddr) -define_ts_iS_s(scheme_checked_mcar) -define_ts_iS_s(scheme_checked_mcdr) -define_ts_iS_s(scheme_checked_set_mcar) -define_ts_iS_s(scheme_checked_set_mcdr) -define_ts_s_s(scheme_unbox) -define_ts_s_s(scheme_vector_length) -define_ts_s_s(tail_call_with_values_from_multiple_result) -define_ts_s_v(raise_bad_call_with_values) -define_ts_s_s(call_with_values_from_multiple_result_multi) -define_ts_s_s(call_with_values_from_multiple_result) -define_ts_iS_s(scheme_checked_vector_ref) -define_ts_iS_s(scheme_checked_vector_set) -define_ts_iS_s(scheme_checked_string_ref) -define_ts_iS_s(scheme_checked_string_set) -define_ts_iS_s(scheme_checked_byte_string_ref) -define_ts_iS_s(scheme_checked_byte_string_set) -define_ts_iS_s(scheme_checked_syntax_e) -define_ts_iS_s(scheme_extract_checked_procedure) -define_ts_S_s(apply_checked_fail) -define_ts_iSi_s(scheme_build_list_offset) -define_ts_siS_v(wrong_argument_count) +define_ts_n_s(scheme_make_native_closure, FSRC_OTHER) +define_ts_n_s(scheme_make_native_case_closure, FSRC_OTHER) +define_ts_bsi_v(call_set_global_bucket, FSRC_OTHER) +define_ts_s_s(scheme_make_envunbox, FSRC_OTHER) +define_ts_s_s(make_global_ref, FSRC_OTHER) +define_ts_iiS_v(lexical_binding_wrong_return_arity, FSRC_OTHER) +define_ts_ss_m(scheme_set_cont_mark, FSRC_OTHER) +define_ts_iiS_v(call_wrong_return_arity, FSRC_OTHER) +define_ts_b_v(scheme_unbound_global, FSRC_OTHER) +define_ts_Sl_s(scheme_delayed_rename, FSRC_OTHER) +define_ts_iS_s(scheme_checked_car, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cdr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_caar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cadr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cdar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_cddr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_mcar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_mcdr, FSRC_OTHER) +define_ts_iS_s(scheme_checked_set_mcar, FSRC_OTHER) +define_ts_iS_s(scheme_checked_set_mcdr, FSRC_OTHER) +define_ts_s_s(scheme_unbox, FSRC_OTHER) +define_ts_s_s(scheme_vector_length, FSRC_OTHER) +define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_OTHER) +define_ts_s_v(raise_bad_call_with_values, FSRC_OTHER) +define_ts_s_s(call_with_values_from_multiple_result_multi, FSRC_OTHER) +define_ts_s_s(call_with_values_from_multiple_result, FSRC_OTHER) +define_ts_iS_s(scheme_checked_vector_ref, FSRC_OTHER) +define_ts_iS_s(scheme_checked_vector_set, FSRC_OTHER) +define_ts_iS_s(scheme_checked_string_ref, FSRC_OTHER) +define_ts_iS_s(scheme_checked_string_set, FSRC_OTHER) +define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_OTHER) +define_ts_iS_s(scheme_checked_byte_string_set, FSRC_OTHER) +define_ts_iS_s(scheme_checked_syntax_e, FSRC_OTHER) +define_ts_iS_s(scheme_extract_checked_procedure, FSRC_OTHER) +define_ts_S_s(apply_checked_fail, FSRC_OTHER) +define_ts_iSi_s(scheme_build_list_offset, FSRC_OTHER) +define_ts_siS_v(wrong_argument_count, FSRC_OTHER) #else # define ts__scheme_apply_multi_from_native _scheme_apply_multi_from_native # define ts__scheme_apply_from_native _scheme_apply_from_native diff --git a/src/mzscheme/src/jit_ts_def.c b/src/mzscheme/src/jit_ts_def.c index d606a61223..9dfc76623b 100644 --- a/src/mzscheme/src/jit_ts_def.c +++ b/src/mzscheme/src/jit_ts_def.c @@ -1,220 +1,200 @@ -#define define_ts_siS_s(id) \ +#define define_ts_siS_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_siS_s(id, g7, g8, g9); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_siS_s("[" #id "]", src_type, id, g7, g8, g9); \ + else \ return id(g7, g8, g9); \ END_XFORM_SKIP; \ } -#define define_ts_iSs_s(id) \ +#define define_ts_iSs_s(id, src_type) \ static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_iSs_s(id, g10, g11, g12); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iSs_s("[" #id "]", src_type, id, g10, g11, g12); \ + else \ return id(g10, g11, g12); \ END_XFORM_SKIP; \ } -#define define_ts_s_s(id) \ +#define define_ts_s_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_s_s(id, g13); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_s_s("[" #id "]", src_type, id, g13); \ + else \ return id(g13); \ END_XFORM_SKIP; \ } -#define define_ts_n_s(id) \ +#define define_ts_n_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_n_s(id, g14); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_n_s("[" #id "]", src_type, id, g14); \ + else \ return id(g14); \ END_XFORM_SKIP; \ } -#define define_ts__s(id) \ +#define define_ts__s(id, src_type) \ static Scheme_Object* ts_ ## id() \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall__s(id, ); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall__s("[" #id "]", src_type, id, ); \ + else \ return id(); \ END_XFORM_SKIP; \ } -#define define_ts_ss_s(id) \ +#define define_ts_ss_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_ss_s(id, g15, g16); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_ss_s("[" #id "]", src_type, id, g15, g16); \ + else \ return id(g15, g16); \ END_XFORM_SKIP; \ } -#define define_ts_ss_m(id) \ +#define define_ts_ss_m(id, src_type) \ static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_ss_m(id, g17, g18); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_ss_m("[" #id "]", src_type, id, g17, g18); \ + else \ return id(g17, g18); \ END_XFORM_SKIP; \ } -#define define_ts_Sl_s(id) \ +#define define_ts_Sl_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_Sl_s(id, g19, g20); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_Sl_s("[" #id "]", src_type, id, g19, g20); \ + else \ return id(g19, g20); \ END_XFORM_SKIP; \ } -#define define_ts_l_s(id) \ +#define define_ts_l_s(id, src_type) \ static Scheme_Object* ts_ ## id(long g21) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_l_s(id, g21); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_l_s("[" #id "]", src_type, id, g21); \ + else \ return id(g21); \ END_XFORM_SKIP; \ } -#define define_ts_bsi_v(id) \ +#define define_ts_bsi_v(id, src_type) \ static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - scheme_rtcall_bsi_v(id, g22, g23, g24); \ - } else \ + if (scheme_use_rtcall) \ + scheme_rtcall_bsi_v("[" #id "]", src_type, id, g22, g23, g24); \ + else \ id(g22, g23, g24); \ END_XFORM_SKIP; \ } -#define define_ts_iiS_v(id) \ +#define define_ts_iiS_v(id, src_type) \ static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - scheme_rtcall_iiS_v(id, g25, g26, g27); \ - } else \ + if (scheme_use_rtcall) \ + scheme_rtcall_iiS_v("[" #id "]", src_type, id, g25, g26, g27); \ + else \ id(g25, g26, g27); \ END_XFORM_SKIP; \ } -#define define_ts_ss_v(id) \ +#define define_ts_ss_v(id, src_type) \ static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - scheme_rtcall_ss_v(id, g28, g29); \ - } else \ + if (scheme_use_rtcall) \ + scheme_rtcall_ss_v("[" #id "]", src_type, id, g28, g29); \ + else \ id(g28, g29); \ END_XFORM_SKIP; \ } -#define define_ts_b_v(id) \ +#define define_ts_b_v(id, src_type) \ static void ts_ ## id(Scheme_Bucket* g30) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - scheme_rtcall_b_v(id, g30); \ - } else \ + if (scheme_use_rtcall) \ + scheme_rtcall_b_v("[" #id "]", src_type, id, g30); \ + else \ id(g30); \ END_XFORM_SKIP; \ } -#define define_ts_sl_s(id) \ +#define define_ts_sl_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_sl_s(id, g31, g32); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_sl_s("[" #id "]", src_type, id, g31, g32); \ + else \ return id(g31, g32); \ END_XFORM_SKIP; \ } -#define define_ts_iS_s(id) \ +#define define_ts_iS_s(id, src_type) \ static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_iS_s(id, g33, g34); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iS_s("[" #id "]", src_type, id, g33, g34); \ + else \ return id(g33, g34); \ END_XFORM_SKIP; \ } -#define define_ts_S_s(id) \ +#define define_ts_S_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_S_s(id, g35); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_S_s("[" #id "]", src_type, id, g35); \ + else \ return id(g35); \ END_XFORM_SKIP; \ } -#define define_ts_s_v(id) \ +#define define_ts_s_v(id, src_type) \ static void ts_ ## id(Scheme_Object* g36) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - scheme_rtcall_s_v(id, g36); \ - } else \ + if (scheme_use_rtcall) \ + scheme_rtcall_s_v("[" #id "]", src_type, id, g36); \ + else \ id(g36); \ END_XFORM_SKIP; \ } -#define define_ts_iSi_s(id) \ +#define define_ts_iSi_s(id, src_type) \ static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_iSi_s(id, g37, g38, g39); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_iSi_s("[" #id "]", src_type, id, g37, g38, g39); \ + else \ return id(g37, g38, g39); \ END_XFORM_SKIP; \ } -#define define_ts_siS_v(id) \ +#define define_ts_siS_v(id, src_type) \ static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - scheme_rtcall_siS_v(id, g40, g41, g42); \ - } else \ + if (scheme_use_rtcall) \ + scheme_rtcall_siS_v("[" #id "]", src_type, id, g40, g41, g42); \ + else \ id(g40, g41, g42); \ END_XFORM_SKIP; \ } -#define define_ts_z_p(id) \ +#define define_ts_z_p(id, src_type) \ static void* ts_ ## id(size_t g43) \ { \ START_XFORM_SKIP; \ - if (scheme_use_rtcall) { \ - LOG_PRIM_START(id); \ - return scheme_rtcall_z_p(id, g43); \ - } else \ + if (scheme_use_rtcall) \ + return scheme_rtcall_z_p("[" #id "]", src_type, id, g43); \ + else \ return id(g43); \ END_XFORM_SKIP; \ } diff --git a/src/mzscheme/src/jit_ts_future_glue.c b/src/mzscheme/src/jit_ts_future_glue.c index 1d152a76b3..cd02973459 100644 --- a/src/mzscheme/src/jit_ts_future_glue.c +++ b/src/mzscheme/src/jit_ts_future_glue.c @@ -1,12 +1,17 @@ - Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g44, int g45, Scheme_Object** g46) + Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g44, int g45, Scheme_Object** g46) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_siS_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g44; future->arg_i1 = g45; future->arg_S2 = g46; @@ -18,15 +23,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49) + Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_iSs_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_i0 = g47; future->arg_S1 = g48; future->arg_s2 = g49; @@ -38,15 +48,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g50) + Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g50) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_s_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g50; future_do_runtimecall((void*)f, 0); future = current_ft; @@ -56,15 +71,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g51) + Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g51) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_n_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_n0 = g51; future_do_runtimecall((void*)f, 0); future = current_ft; @@ -74,15 +94,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall__s(prim__s f ) + Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG__s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future_do_runtimecall((void*)f, 0); future = current_ft; @@ -92,15 +117,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53) + Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_ss_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g52; future->arg_s1 = g53; future_do_runtimecall((void*)f, 0); @@ -111,15 +141,20 @@ return retval; END_XFORM_SKIP; } - MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55) + MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55) { START_XFORM_SKIP; future_t *future; + double tm; MZ_MARK_STACK_TYPE retval; future = current_ft; future->prim_protocol = SIG_ss_m; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g54; future->arg_s1 = g55; future_do_runtimecall((void*)f, 0); @@ -130,15 +165,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g56, long g57) + Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g56, long g57) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_Sl_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_S0 = g56; future->arg_l1 = g57; future_do_runtimecall((void*)f, 0); @@ -149,15 +189,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g58) + Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g58) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_l_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_l0 = g58; future_do_runtimecall((void*)f, 0); future = current_ft; @@ -167,15 +212,20 @@ return retval; END_XFORM_SKIP; } - void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61) + void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61) { START_XFORM_SKIP; future_t *future; + double tm; future = current_ft; future->prim_protocol = SIG_bsi_v; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_b0 = g59; future->arg_s1 = g60; future->arg_i2 = g61; @@ -187,15 +237,20 @@ END_XFORM_SKIP; } - void scheme_rtcall_iiS_v(prim_iiS_v f, int g62, int g63, Scheme_Object** g64) + void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g62, int g63, Scheme_Object** g64) { START_XFORM_SKIP; future_t *future; + double tm; future = current_ft; future->prim_protocol = SIG_iiS_v; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_i0 = g62; future->arg_i1 = g63; future->arg_S2 = g64; @@ -207,15 +262,20 @@ END_XFORM_SKIP; } - void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g65, Scheme_Object* g66) + void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g65, Scheme_Object* g66) { START_XFORM_SKIP; future_t *future; + double tm; future = current_ft; future->prim_protocol = SIG_ss_v; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g65; future->arg_s1 = g66; future_do_runtimecall((void*)f, 0); @@ -226,15 +286,20 @@ END_XFORM_SKIP; } - void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g67) + void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g67) { START_XFORM_SKIP; future_t *future; + double tm; future = current_ft; future->prim_protocol = SIG_b_v; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_b0 = g67; future_do_runtimecall((void*)f, 0); future = current_ft; @@ -244,15 +309,20 @@ END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g68, long g69) + Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g68, long g69) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_sl_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g68; future->arg_l1 = g69; future_do_runtimecall((void*)f, 0); @@ -263,15 +333,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g70, Scheme_Object** g71) + Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g70, Scheme_Object** g71) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_iS_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_i0 = g70; future->arg_S1 = g71; future_do_runtimecall((void*)f, 0); @@ -282,15 +357,20 @@ return retval; END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g72) + Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g72) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_S_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_S0 = g72; future_do_runtimecall((void*)f, 0); future = current_ft; @@ -300,15 +380,20 @@ return retval; END_XFORM_SKIP; } - void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g73) + void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g73) { START_XFORM_SKIP; future_t *future; + double tm; future = current_ft; future->prim_protocol = SIG_s_v; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g73; future_do_runtimecall((void*)f, 0); future = current_ft; @@ -318,15 +403,20 @@ END_XFORM_SKIP; } - Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g74, Scheme_Object** g75, int g76) + Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g74, Scheme_Object** g75, int g76) { START_XFORM_SKIP; future_t *future; + double tm; Scheme_Object* retval; future = current_ft; future->prim_protocol = SIG_iSi_s; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_i0 = g74; future->arg_S1 = g75; future->arg_i2 = g76; @@ -338,15 +428,20 @@ return retval; END_XFORM_SKIP; } - void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79) + void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79) { START_XFORM_SKIP; future_t *future; + double tm; future = current_ft; future->prim_protocol = SIG_siS_v; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_s0 = g77; future->arg_i1 = g78; future->arg_S2 = g79; @@ -358,15 +453,20 @@ END_XFORM_SKIP; } - void* scheme_rtcall_z_p(prim_z_p f, size_t g80) + void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g80) { START_XFORM_SKIP; future_t *future; + double tm; void* retval; future = current_ft; future->prim_protocol = SIG_z_p; future->prim_func = f; + tm = scheme_get_inexact_milliseconds(); + future->time_of_request = tm; + future->source_of_request = who; + future->source_type = src_type; future->arg_z0 = g80; future_do_runtimecall((void*)f, 0); future = current_ft; diff --git a/src/mzscheme/src/jit_ts_protos.h b/src/mzscheme/src/jit_ts_protos.h index 136bfdad9c..0d980befd4 100644 --- a/src/mzscheme/src/jit_ts_protos.h +++ b/src/mzscheme/src/jit_ts_protos.h @@ -1,60 +1,60 @@ #define SIG_siS_s 5 typedef Scheme_Object* (*prim_siS_s)(Scheme_Object*, int, Scheme_Object**); -Scheme_Object* scheme_rtcall_siS_s(prim_siS_s f, Scheme_Object* g118, int g119, Scheme_Object** g120); +Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g118, int g119, Scheme_Object** g120); #define SIG_iSs_s 6 typedef Scheme_Object* (*prim_iSs_s)(int, Scheme_Object**, Scheme_Object*); -Scheme_Object* scheme_rtcall_iSs_s(prim_iSs_s f, int g121, Scheme_Object** g122, Scheme_Object* g123); +Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g121, Scheme_Object** g122, Scheme_Object* g123); #define SIG_s_s 7 typedef Scheme_Object* (*prim_s_s)(Scheme_Object*); -Scheme_Object* scheme_rtcall_s_s(prim_s_s f, Scheme_Object* g124); +Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g124); #define SIG_n_s 8 typedef Scheme_Object* (*prim_n_s)(Scheme_Native_Closure_Data*); -Scheme_Object* scheme_rtcall_n_s(prim_n_s f, Scheme_Native_Closure_Data* g125); +Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g125); #define SIG__s 9 typedef Scheme_Object* (*prim__s)(); -Scheme_Object* scheme_rtcall__s(prim__s f ); +Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ); #define SIG_ss_s 10 typedef Scheme_Object* (*prim_ss_s)(Scheme_Object*, Scheme_Object*); -Scheme_Object* scheme_rtcall_ss_s(prim_ss_s f, Scheme_Object* g126, Scheme_Object* g127); +Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g126, Scheme_Object* g127); #define SIG_ss_m 11 typedef MZ_MARK_STACK_TYPE (*prim_ss_m)(Scheme_Object*, Scheme_Object*); -MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(prim_ss_m f, Scheme_Object* g128, Scheme_Object* g129); +MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g128, Scheme_Object* g129); #define SIG_Sl_s 12 typedef Scheme_Object* (*prim_Sl_s)(Scheme_Object**, long); -Scheme_Object* scheme_rtcall_Sl_s(prim_Sl_s f, Scheme_Object** g130, long g131); +Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g130, long g131); #define SIG_l_s 13 typedef Scheme_Object* (*prim_l_s)(long); -Scheme_Object* scheme_rtcall_l_s(prim_l_s f, long g132); +Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g132); #define SIG_bsi_v 14 typedef void (*prim_bsi_v)(Scheme_Bucket*, Scheme_Object*, int); -void scheme_rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g133, Scheme_Object* g134, int g135); +void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g133, Scheme_Object* g134, int g135); #define SIG_iiS_v 15 typedef void (*prim_iiS_v)(int, int, Scheme_Object**); -void scheme_rtcall_iiS_v(prim_iiS_v f, int g136, int g137, Scheme_Object** g138); +void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g136, int g137, Scheme_Object** g138); #define SIG_ss_v 16 typedef void (*prim_ss_v)(Scheme_Object*, Scheme_Object*); -void scheme_rtcall_ss_v(prim_ss_v f, Scheme_Object* g139, Scheme_Object* g140); +void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g139, Scheme_Object* g140); #define SIG_b_v 17 typedef void (*prim_b_v)(Scheme_Bucket*); -void scheme_rtcall_b_v(prim_b_v f, Scheme_Bucket* g141); +void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g141); #define SIG_sl_s 18 typedef Scheme_Object* (*prim_sl_s)(Scheme_Object*, long); -Scheme_Object* scheme_rtcall_sl_s(prim_sl_s f, Scheme_Object* g142, long g143); +Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g142, long g143); #define SIG_iS_s 19 typedef Scheme_Object* (*prim_iS_s)(int, Scheme_Object**); -Scheme_Object* scheme_rtcall_iS_s(prim_iS_s f, int g144, Scheme_Object** g145); +Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g144, Scheme_Object** g145); #define SIG_S_s 20 typedef Scheme_Object* (*prim_S_s)(Scheme_Object**); -Scheme_Object* scheme_rtcall_S_s(prim_S_s f, Scheme_Object** g146); +Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g146); #define SIG_s_v 21 typedef void (*prim_s_v)(Scheme_Object*); -void scheme_rtcall_s_v(prim_s_v f, Scheme_Object* g147); +void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g147); #define SIG_iSi_s 22 typedef Scheme_Object* (*prim_iSi_s)(int, Scheme_Object**, int); -Scheme_Object* scheme_rtcall_iSi_s(prim_iSi_s f, int g148, Scheme_Object** g149, int g150); +Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g148, Scheme_Object** g149, int g150); #define SIG_siS_v 23 typedef void (*prim_siS_v)(Scheme_Object*, int, Scheme_Object**); -void scheme_rtcall_siS_v(prim_siS_v f, Scheme_Object* g151, int g152, Scheme_Object** g153); +void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g151, int g152, Scheme_Object** g153); #define SIG_z_p 24 typedef void* (*prim_z_p)(size_t); -void* scheme_rtcall_z_p(prim_z_p f, size_t g154); +void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g154); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index d89cd69b12..c7579f2353 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2422,6 +2422,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count); #define SCHEME_OUT_OF_CONTEXT_LOCAL 8192 Scheme_Hash_Table *scheme_map_constants_to_globals(void); +const char *scheme_look_for_primitive(void *code); Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); From d2e5807811e9e9b9159d574d635d73aca8f6284b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 06:30:55 +0000 Subject: [PATCH 14/92] fix some synchronization problems in futures svn: r16916 --- src/mzscheme/src/future.c | 62 ++++++++++++++++++--------------------- src/mzscheme/src/jit.c | 3 ++ 2 files changed, 31 insertions(+), 34 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index a2754c27cb..bbd7887991 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -78,7 +78,6 @@ static pthread_cond_t g_future_pending_cv = PTHREAD_COND_INITIALIZER; THREAD_LOCAL_DECL(static pthread_cond_t worker_can_continue_cv); -static pthread_mutex_t gc_ok_m = PTHREAD_MUTEX_INITIALIZER; static pthread_cond_t gc_ok_c = PTHREAD_COND_INITIALIZER; static pthread_cond_t gc_done_c = PTHREAD_COND_INITIALIZER; static int gc_not_ok, wait_for_gc; @@ -99,8 +98,8 @@ static void register_traversers(void); #endif extern void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv); -static void start_gc_not_ok(int with_lock); -static void end_gc_not_ok(future_t *ft, int with_lock); +static void start_gc_not_ok(); +static void end_gc_not_ok(future_t *ft); static void future_do_runtimecall(void *func, int is_atomic); @@ -338,18 +337,14 @@ void futures_init(void) g_num_avail_threads = THREAD_POOL_SIZE; } -static void start_gc_not_ok(int with_lock) +static void start_gc_not_ok() { - if (with_lock) - pthread_mutex_lock(&gc_ok_m); - while (wait_for_gc) { - pthread_cond_wait(&gc_done_c, &gc_ok_m); + pthread_cond_wait(&gc_done_c, &g_future_queue_mutex); } gc_not_ok++; - if (with_lock) - pthread_mutex_unlock(&gc_ok_m); + #ifdef MZ_PRECISE_GC if (worker_gc_counter != *gc_counter_ptr) { GC_gen0_alloc_page_ptr = 0; /* forces future to ask for memory */ @@ -358,7 +353,7 @@ static void start_gc_not_ok(int with_lock) #endif } -static void end_gc_not_ok(future_t *ft, int with_lock) +static void end_gc_not_ok(future_t *ft) { if (ft) { scheme_set_runstack_limits(ft->runstack_start, @@ -369,21 +364,17 @@ static void end_gc_not_ok(future_t *ft, int with_lock) /* FIXME: clear scheme_current_thread->ku.multiple.array ? */ - if (with_lock) - pthread_mutex_lock(&gc_ok_m); --gc_not_ok; pthread_cond_signal(&gc_ok_c); - if (with_lock) - pthread_mutex_unlock(&gc_ok_m); } void scheme_future_block_until_gc() { int i; - pthread_mutex_lock(&gc_ok_m); + pthread_mutex_lock(&g_future_queue_mutex); wait_for_gc = 1; - pthread_mutex_unlock(&gc_ok_m); + pthread_mutex_unlock(&g_future_queue_mutex); for (i = 0; i < THREAD_POOL_SIZE; i++) { if (g_fuel_pointers[i] != NULL) @@ -395,11 +386,11 @@ void scheme_future_block_until_gc() } asm("mfence"); - pthread_mutex_lock(&gc_ok_m); + pthread_mutex_lock(&g_future_queue_mutex); while (gc_not_ok) { - pthread_cond_wait(&gc_ok_c, &gc_ok_m); + pthread_cond_wait(&gc_ok_c, &g_future_queue_mutex); } - pthread_mutex_unlock(&gc_ok_m); + pthread_mutex_unlock(&g_future_queue_mutex); } void scheme_future_continue_after_gc() @@ -416,19 +407,21 @@ void scheme_future_continue_after_gc() } - pthread_mutex_lock(&gc_ok_m); + pthread_mutex_lock(&g_future_queue_mutex); wait_for_gc = 0; pthread_cond_broadcast(&gc_done_c); - pthread_mutex_unlock(&gc_ok_m); + pthread_mutex_unlock(&g_future_queue_mutex); } void scheme_future_gc_pause() /* Called in future thread */ { - pthread_mutex_lock(&gc_ok_m); - end_gc_not_ok(current_ft, 0); - start_gc_not_ok(0); /* waits until wait_for_gc is 0 */ - pthread_mutex_unlock(&gc_ok_m); + future_t *future = current_ft; + future->runstack = MZ_RUNSTACK; + pthread_mutex_lock(&g_future_queue_mutex); + end_gc_not_ok(future); + start_gc_not_ok(); /* waits until wait_for_gc is 0 */ + pthread_mutex_unlock(&g_future_queue_mutex); } /**********************************************************************/ @@ -712,13 +705,13 @@ void *worker_thread_future_loop(void *arg) sema_signal(&ready_sema); wait_for_work: - start_gc_not_ok(1); pthread_mutex_lock(&g_future_queue_mutex); + start_gc_not_ok(); while (!(ft = get_pending_future())) { - end_gc_not_ok(NULL, 1); + end_gc_not_ok(NULL); pthread_cond_wait(&g_future_pending_cv, &g_future_queue_mutex); - start_gc_not_ok(1); + start_gc_not_ok(); } LOG("Got a signal that a future is pending..."); @@ -781,9 +774,9 @@ void *worker_thread_future_loop(void *arg) dequeue_future(ft); scheme_signal_received_at(g_signal_handle); - pthread_mutex_unlock(&g_future_queue_mutex); - end_gc_not_ok(NULL, 1); + end_gc_not_ok(NULL); + pthread_mutex_unlock(&g_future_queue_mutex); goto wait_for_work; @@ -866,9 +859,9 @@ void future_do_runtimecall(void *func, //Wait for the signal that the RT call is finished future->can_continue_cv = &worker_can_continue_cv; - end_gc_not_ok(future, 1); + end_gc_not_ok(future); pthread_cond_wait(&worker_can_continue_cv, &g_future_queue_mutex); - start_gc_not_ok(1); + start_gc_not_ok(); //Fetch the future instance again, in case the GC has moved the pointer future = current_ft; @@ -990,7 +983,8 @@ static void do_invoke_rtcall(future_t *future) src = future->source_of_request; if (future->source_type == FSRC_RATOR) { int len; - src = scheme_get_proc_name(future->arg_s0, &len, 1); + if (SCHEME_PROCP(future->arg_s0)) + src = scheme_get_proc_name(future->arg_s0, &len, 1); } else if (future->source_type == FSRC_PRIM) { const char *src2; src2 = scheme_look_for_primitive(future->prim_func); diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index a944f94a8d..168a8385ae 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2246,6 +2246,8 @@ static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, GC_CAN_IGNORE jit_insn *refslow = 0, *refpause; int i; + mz_rs_sync(); + /* expose gc_reg to GC */ mz_tl_sti_p(tl_jit_future_storage, gc_reg, JIT_R1); @@ -2265,6 +2267,7 @@ static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, register back. */ if (i == 1) { mz_patch_branch(refpause); + JIT_UPDATE_THREAD_RSPTR_FOR_BRANCH_IF_NEEDED(); jit_prepare(0); mz_finish(scheme_future_gc_pause); } From 3ccb9082dc02273f6a7214676f65a2dc0e4e1cb2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 20 Nov 2009 08:35:43 +0000 Subject: [PATCH 15/92] stupid typo svn: r16917 --- collects/scribblings/main/private/search.js | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js index cb01f2cf39..999009634a 100644 --- a/collects/scribblings/main/private/search.js +++ b/collects/scribblings/main/private/search.js @@ -343,7 +343,7 @@ function UrlToManual(url) { // "L:schem" (only module names that match `schem') function CompileTerm(term) { - var op = ((term.search(/^[LMT]:/) == 0) && term.substring(0,1)); + var op = ((term.search(/^[NLMT]:/) == 0) && term.substring(0,1)); if (op) term = term.substring(2); term = term.toLowerCase(); switch(op) { From 684debc749aa77b9cb6f69b5c03e059fc46fe012 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 20 Nov 2009 08:50:35 +0000 Subject: [PATCH 16/92] Welcome to a new PLT day. svn: r16918 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index cbabd25673..a01f4bcab8 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19nov2009") +#lang scheme/base (provide stamp) (define stamp "20nov2009") From 314faa66904375b234466ddbeeb28c1e3ca0f359 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 13:00:31 +0000 Subject: [PATCH 17/92] count future allocation toward GC trigger svn: r16919 --- src/mzscheme/gc2/newgc.c | 6 ++++++ src/mzscheme/src/error.c | 8 +++++++- src/mzscheme/src/future.c | 4 +++- src/mzscheme/src/future.h | 1 + 4 files changed, 17 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 63c8163c91..679875c40a 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -726,6 +726,12 @@ void *GC_make_jit_nursery_page() { NewGC *gc = GC_get_GC(); mpage *new_mpage; + if((gc->gen0.current_size + THREAD_LOCAL_PAGE_SIZE) >= gc->gen0.max_size) { + if (!gc->dumping_avoid_collection) + garbage_collect(gc, 0); + } + gc->gen0.current_size += THREAD_LOCAL_PAGE_SIZE; + { new_mpage = gen0_create_new_nursery_mpage(gc, THREAD_LOCAL_PAGE_SIZE); diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 0ba8526b9a..dd0e2ea92f 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -177,6 +177,7 @@ Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config) %c = unicode char %d = int %ld = long int + %lx = long int %o = int, octal %f = double %% = percent @@ -333,9 +334,14 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch case 'l': { long d; + int as_hex; + as_hex = (msg[j] == 'x'); j++; d = ints[ip++]; - sprintf(buf, "%ld", d); + if (as_hex) + sprintf(buf, "%lx", d); + else + sprintf(buf, "%ld", d); t = buf; tlen = strlen(t); } diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index bbd7887991..83db07dc8c 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -721,6 +721,7 @@ void *worker_thread_future_loop(void *arg) pthread_mutex_unlock(&g_future_queue_mutex); ft->threadid = pthread_self(); + ft->thread_short_id = id; //Decrement the number of available pool threads g_num_avail_threads--; @@ -992,7 +993,8 @@ static void do_invoke_rtcall(future_t *future) } scheme_log(scheme_main_logger, SCHEME_LOG_DEBUG, 0, - "future: waiting for runtime at %f: %s", + "future: %d waiting for runtime at %f: %s", + (long)future->thread_short_id, future->time_of_request, src); } diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 0d51b00c69..638a158eae 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -52,6 +52,7 @@ typedef struct future_t { int id; pthread_t threadid; + int thread_short_id; int status; int work_completed; pthread_cond_t *can_continue_cv; From 1991cde5a7db0c117f018966500574b941c830d7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 13:59:46 +0000 Subject: [PATCH 18/92] fix handling of future atomic runtime requests svn: r16920 --- src/mzscheme/src/future.c | 29 +++++++++++++++++++---------- src/mzscheme/src/future.h | 2 ++ 2 files changed, 21 insertions(+), 10 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 83db07dc8c..8b15acc3ac 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -799,15 +799,18 @@ void scheme_check_future_work() ft = g_future_waiting_atomic; if (ft) { g_future_waiting_atomic = ft->next_waiting_atomic; + ft->next_waiting_atomic = NULL; + ft->waiting_atomic = 0; } pthread_mutex_unlock(&g_future_queue_mutex); - if (ft && ft->rt_prim && ft->rt_prim_is_atomic) { - invoke_rtcall(ft); + if (ft) { + if (ft->rt_prim && ft->rt_prim_is_atomic) { + invoke_rtcall(ft); + } } else break; } - } //Returns 0 if the call isn't actually executed by this function, @@ -849,8 +852,11 @@ void future_do_runtimecall(void *func, future->rt_prim_is_atomic = is_atomic; if (is_atomic) { - future->next_waiting_atomic = g_future_waiting_atomic; - g_future_waiting_atomic = future; + if (!future->waiting_atomic) { + future->next_waiting_atomic = g_future_waiting_atomic; + g_future_waiting_atomic = future; + future->waiting_atomic = 1; + } } //Update the future's status to waiting @@ -861,12 +867,13 @@ void future_do_runtimecall(void *func, //Wait for the signal that the RT call is finished future->can_continue_cv = &worker_can_continue_cv; end_gc_not_ok(future); - pthread_cond_wait(&worker_can_continue_cv, &g_future_queue_mutex); + while (future->can_continue_cv) { + pthread_cond_wait(&worker_can_continue_cv, &g_future_queue_mutex); + //Fetch the future instance again, in case the GC has moved the pointer + future = current_ft; + } start_gc_not_ok(); - //Fetch the future instance again, in case the GC has moved the pointer - future = current_ft; - pthread_mutex_unlock(&g_future_queue_mutex); if (future->no_retval) { @@ -907,7 +914,7 @@ void *scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, void (*f)()) while (1) { future = current_ft; - future->time_of_request = scheme_get_inexact_milliseconds(); + future->time_of_request = 0; /* takes too long?: scheme_get_inexact_milliseconds(); */ future->source_of_request = who; future->source_type = src_type; @@ -1029,6 +1036,7 @@ static void do_invoke_rtcall(future_t *future) //Signal the waiting worker thread that it //can continue running machine code pthread_cond_signal(future->can_continue_cv); + future->can_continue_cv= NULL; pthread_mutex_unlock(&g_future_queue_mutex); } @@ -1045,6 +1053,7 @@ static void invoke_rtcall(future_t * volatile future) //Signal the waiting worker thread that it //can continue running machine code pthread_cond_signal(future->can_continue_cv); + future->can_continue_cv = NULL; pthread_mutex_unlock(&g_future_queue_mutex); scheme_longjmp(*savebuf, 1); } else { diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 638a158eae..6fb9893ffa 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -105,6 +105,8 @@ typedef struct future_t { Scheme_Object *retval; struct future_t *prev; struct future_t *next; + + int waiting_atomic; struct future_t *next_waiting_atomic; } future_t; From c8b2ba9d3fc49749a99aaaf7656fc4e7ae08361e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 14:04:59 +0000 Subject: [PATCH 19/92] future GC lock repair svn: r16921 --- src/mzscheme/src/future.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 8b15acc3ac..08f6e87064 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -866,13 +866,13 @@ void future_do_runtimecall(void *func, //Wait for the signal that the RT call is finished future->can_continue_cv = &worker_can_continue_cv; - end_gc_not_ok(future); while (future->can_continue_cv) { + end_gc_not_ok(future); pthread_cond_wait(&worker_can_continue_cv, &g_future_queue_mutex); + start_gc_not_ok(); //Fetch the future instance again, in case the GC has moved the pointer future = current_ft; } - start_gc_not_ok(); pthread_mutex_unlock(&g_future_queue_mutex); From 9367b1bbad5f9716672803e453b6c1a585a1ec66 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Nov 2009 15:42:05 +0000 Subject: [PATCH 20/92] alternate use of registers by JIT in 32-bit thread-local mode svn: r16923 --- src/mzscheme/src/jit.c | 68 ++++++++++++++++++++++++++++++------------ 1 file changed, 49 insertions(+), 19 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 168a8385ae..41e1e91187 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -312,17 +312,34 @@ END_XFORM_SKIP; # define mz_tl_addr_tmp(tmp_reg, addr) (mz_tl_addr(JIT_R10, addr)) # define mz_tl_addr_untmp(tmp_reg) (void)0 # define mz_tl_tmp_reg(tmp_reg) JIT_R10 +# define _mz_tl_str_p(addr, tmp_reg, reg) jit_str_p(tmp_reg, reg) +# define _mz_tl_str_l(addr, tmp_reg, reg) jit_str_l(tmp_reg, reg) +# define _mz_tl_str_i(addr, tmp_reg, reg) jit_str_i(tmp_reg, reg) # else -# define mz_tl_addr(reg, addr) (mz_get_local_p(reg, JIT_LOCAL4), jit_addi_p(reg, reg, addr)) -# define mz_tl_addr_tmp(tmp_reg, addr) (PUSHQr(tmp_reg), mz_tl_addr(tmp_reg, addr)) -# define mz_tl_addr_untmp(tmp_reg) POPQr(tmp_reg) -# define mz_tl_tmp_reg(tmp_reg) tmp_reg +# define THREAD_LOCAL_USES_JIT_V2 +# ifdef THREAD_LOCAL_USES_JIT_V2 +# define mz_tl_addr(reg, addr) (jit_addi_p(reg, JIT_V2, addr)) +# define mz_tl_addr_tmp(tmp_reg, addr) (void)0 +# define mz_tl_addr_untmp(tmp_reg) 0 +# define mz_tl_tmp_reg(tmp_reg) (void)0 +# define _mz_tl_str_p(addr, tmp_reg, reg) jit_stxi_p(addr, JIT_V2, reg) +# define _mz_tl_str_l(addr, tmp_reg, reg) jit_stxi_l(addr, JIT_V2, reg) +# define _mz_tl_str_i(addr, tmp_reg, reg) jit_stxi_i(addr, JIT_V2, reg) +# else +# define mz_tl_addr(reg, addr) (mz_get_local_p(reg, JIT_LOCAL4), jit_addi_p(reg, reg, addr)) +# define mz_tl_addr_tmp(tmp_reg, addr) (PUSHQr(tmp_reg), mz_tl_addr(tmp_reg, addr)) +# define mz_tl_addr_untmp(tmp_reg) POPQr(tmp_reg) +# define mz_tl_tmp_reg(tmp_reg) tmp_reg +# define _mz_tl_str_p(addr, tmp_reg, reg) jit_str_p(tmp_reg, reg) +# define _mz_tl_str_l(addr, tmp_reg, reg) jit_str_l(tmp_reg, reg) +# define _mz_tl_str_i(addr, tmp_reg, reg) jit_str_i(tmp_reg, reg) +# endif # endif /* A given tmp_reg doesn't have to be unused; it just has to be distinct from other arguments. */ -# define mz_tl_sti_p(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), jit_str_p(mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) -# define mz_tl_sti_l(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), jit_str_l(mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) -# define mz_tl_sti_i(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), jit_str_i(mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) +# define mz_tl_sti_p(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), _mz_tl_str_p(addr, mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) +# define mz_tl_sti_l(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), _mz_tl_str_l(addr, mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) +# define mz_tl_sti_i(addr, reg, tmp_reg) (mz_tl_addr_tmp(tmp_reg, addr), _mz_tl_str_i(addr, mz_tl_tmp_reg(tmp_reg), reg), mz_tl_addr_untmp(tmp_reg)) # define mz_tl_ldi_p(reg, addr) (mz_tl_addr(reg, addr), jit_ldr_p(reg, reg)) # define mz_tl_ldi_l(reg, addr) (mz_tl_addr(reg, addr), jit_ldr_l(reg, reg)) # define mz_tl_ldi_i(reg, addr) (mz_tl_addr(reg, addr), jit_ldr_i(reg, reg)) @@ -780,11 +797,18 @@ static Scheme_Object *apply_checked_fail(Scheme_Object **args) /*========================================================================*/ #define JIT_RUNSTACK JIT_V0 -#define JIT_RUNSTACK_BASE JIT_V2 -#define JIT_RUNSTACK_BASE_OR_ALT(alt) JIT_RUNSTACK_BASE -#define mz_ld_runstack_base_alt(JIT_R2) /* empty */ -#define mz_st_runstack_base_alt(JIT_R2) /* empty */ +#ifndef THREAD_LOCAL_USES_JIT_V2 +# define JIT_RUNSTACK_BASE JIT_V2 +# define JIT_RUNSTACK_BASE_OR_ALT(alt) JIT_RUNSTACK_BASE +# define mz_ld_runstack_base_alt(reg) /* empty */ +# define mz_st_runstack_base_alt(reg) /* empty */ +#else +# define JIT_RUNSTACK_BASE_OR_ALT(alt) alt +# define JIT_RUNSTACK_BASE_LOCAL JIT_LOCAL4 +# define mz_ld_runstack_base_alt(reg) mz_get_local_p(reg, JIT_RUNSTACK_BASE_LOCAL) +# define mz_st_runstack_base_alt(reg) mz_set_local_p(reg, JIT_RUNSTACK_BASE_LOCAL) +#endif #ifdef MZ_USE_JIT_PPC # define JIT_STACK 1 @@ -1302,13 +1326,19 @@ static void _jit_prolog_again(mz_jit_state *jitter, int n, int ret_addr_reg) # define mz_repush_threadlocal() mz_set_local_p(JIT_R14, JIT_LOCAL4) # else # define mz_pop_threadlocal() /* empty */ +# ifdef THREAD_LOCAL_USES_JIT_V2 +# define _mz_install_threadlocal(reg) jit_movr_p(JIT_V2, reg) +# define mz_repush_threadlocal() /* empty */ +# else +# define _mz_install_threadlocal(reg) mz_set_local_p(reg, JIT_LOCAL4) +# define mz_repush_threadlocal() (PUSHQr(JIT_R0), jit_ldr_p(JIT_R0, _EBP), \ + jit_ldxi_p(JIT_R0, JIT_R0, JIT_LOCAL4), \ + jit_stxi_p(JIT_LOCAL4, _EBP, JIT_R0), \ + POPQr(JIT_R0)) +# endif # define mz_push_threadlocal() (PUSHQr(JIT_R0), PUSHQr(JIT_R1), PUSHQr(JIT_R2), PUSHQr(JIT_R2), \ - mz_get_threadlocal(), jit_retval(JIT_R0), mz_set_local_p(JIT_R0, JIT_LOCAL4), \ + mz_get_threadlocal(), jit_retval(JIT_R0), _mz_install_threadlocal(JIT_R0), \ POPQr(JIT_R2), POPQr(JIT_R2), POPQr(JIT_R1), POPQr(JIT_R0)) -# define mz_repush_threadlocal() (PUSHQr(JIT_R0), jit_ldr_p(JIT_R0, _EBP), \ - jit_ldxi_p(JIT_R0, JIT_R0, JIT_LOCAL4), \ - jit_stxi_p(JIT_LOCAL4, _EBP, JIT_R0), \ - POPQr(JIT_R0)) # endif #else # define mz_pop_threadlocal() /* empty */ @@ -2451,7 +2481,7 @@ static int generate_tail_call(mz_jit_state *jitter, int num_rands, int direct_na /* Need to shuffle argument lists. Since we can pass only three arguments, use static variables for the others. */ mz_ld_runstack_base_alt(JIT_R1); - mz_tl_sti_p(tl_fixup_runstack_base, JIT_RUNSTACK_BASE_OR_ALT(JIT_R0), JIT_R1); + mz_tl_sti_p(tl_fixup_runstack_base, JIT_RUNSTACK_BASE_OR_ALT(JIT_R1), JIT_R0); mz_get_local_p(JIT_R1, JIT_LOCAL2); mz_tl_sti_l(tl_fixup_already_in_place, JIT_R1, JIT_R0); } @@ -7841,7 +7871,7 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_ rest args, because we'll have to copy anyway. */ if (!has_rest && num_params) { jit_lshi_l(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R1, JIT_LOG_WORD_SIZE); - jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R2, JIT_RUNSTACK_BASE); + jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R2, JIT_RUNSTACK_BASE_OR_ALT(JIT_V1)); #ifndef JIT_RUNSTACK_BASE mz_set_local_p(JIT_V1, JIT_RUNSTACK_BASE_LOCAL); #endif @@ -8280,7 +8310,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Set runstack base to end of arguments on runstack: */ jit_movr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_R1); jit_lshi_ul(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_LOG_WORD_SIZE); - jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK_BASE, JIT_RUNSTACK); + jit_addr_p(JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK_BASE_OR_ALT(JIT_V1), JIT_RUNSTACK); mz_st_runstack_base_alt(JIT_V1); /* Extract function and jump: */ jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Native_Closure *)0x0)->code); From 074450e2688d563dcc0ffe7d071fd36a29ab41e0 Mon Sep 17 00:00:00 2001 From: James Swaine Date: Fri, 20 Nov 2009 16:41:07 +0000 Subject: [PATCH 21/92] fixed futures (processor-count) on OS X (was previously always returning 1) svn: r16924 --- src/mzscheme/src/future.c | 23 ++++++----------------- 1 file changed, 6 insertions(+), 17 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 08f6e87064..c73134a218 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -612,6 +612,7 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) #ifdef linux #include #elif OS_X +#include #include #elif WINDOWS #include @@ -625,24 +626,12 @@ Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) #ifdef linux cpucount = sysconf(_SC_NPROCESSORS_ONLN); #elif OS_X - int mib[4]; - size_t len; + size_t size = sizeof(cpucount) ; - /* set the mib for hw.ncpu */ - mib[0] = CTL_HW; - mib[1] = HW_AVAILCPU; // alternatively, try HW_NCPU; - - /* get the number of CPUs from the system */ - sysctl(mib, 2, &cpucount, &len, NULL, 0); - if (cpucount < 1) - { - mib[1] = HW_NCPU; - sysctl(mib, 2, &cpucount, &len, NULL, 0); - if(cpucount < 1) - { - cpucount = 1; - } - } + if (sysctlbyname("hw.ncpu", &cpucount, &size, NULL, 0)) + { + cpucount = 1; + } #elif WINDOWS SYSTEM_INFO sysinfo; GetSystemInfo(&sysinfo); From 34380bbd1003ed03eb927e48f6f10e66da24fe2c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 20 Nov 2009 19:09:39 +0000 Subject: [PATCH 22/92] macro-debugger/syntax-browser: misc code cleanups added module for making images svn: r16925 --- .../macro-debugger/syntax-browser/display.ss | 73 +++++++------- .../macro-debugger/syntax-browser/image.ss | 96 +++++++++++++++++++ .../syntax-browser/interfaces.ss | 1 + .../macro-debugger/syntax-browser/prefs.ss | 25 +++-- .../syntax-browser/pretty-helper.ss | 26 ++--- .../syntax-browser/pretty-printer.ss | 33 +++---- 6 files changed, 177 insertions(+), 77 deletions(-) create mode 100644 collects/macro-debugger/syntax-browser/image.ss diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index 2de3c18e93..173419929e 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -28,66 +28,33 @@ ;; FIXME: assumes text never moves ;; print-syntax-to-editor : syntax text controller<%> config number number -;; -> display<%> +;; -> display<%> (define (print-syntax-to-editor stx text controller config columns insertion-point) (begin-with-definitions - (define **entry (now)) (define output-port (open-output-string/count-lines)) (define range (pretty-print-syntax stx output-port (send: controller controller<%> get-primary-partition) - (send: config config<%> get-colors) + (length (send: config config<%> get-colors)) (send: config config<%> get-suffix-option) columns)) - (define **range (now)) (define output-string (get-output-string output-port)) (define output-length (sub1 (string-length output-string))) ;; skip final newline (fixup-parentheses output-string range) - (define **fixup (now)) + (send text begin-edit-sequence #f) + (send text insert output-length output-string insertion-point) (define display (new display% (text text) (controller controller) (config config) (range range) - (base-style (standard-font text config)) (start-position insertion-point) (end-position (+ insertion-point output-length)))) - (send text begin-edit-sequence #f) - (define **editing (now)) - (send text insert output-length output-string insertion-point) - (define **inserted (now)) - (add-clickbacks text range controller insertion-point) - (define **clickbacks (now)) (send display initialize) - (define **colorize (now)) (send text end-edit-sequence) - (define **finished (now)) - (when TIME-PRINTING? - (eprintf "** pretty-print: ~s\n" (- **range **entry)) - (eprintf "** fixup, begin-edit-sequence: ~s\n" (- **editing **range)) - (eprintf "** > insert: ~s\n" (- **inserted **editing)) - (eprintf "** > clickback: ~s\n" (- **clickbacks **inserted)) - (eprintf "** > colorize: ~s\n" (- **colorize **clickbacks)) - (eprintf "** finish: ~s\n" (- **finished **colorize)) - (eprintf "** total: ~s\n" (- **finished **entry)) - (eprintf "\n")) display)) -;; add-clickbacks : text% range% controller<%> number -> void -(define (add-clickbacks text range controller insertion-point) - (for ([range (send: range range<%> all-ranges)]) - (let ([stx (range-obj range)] - [start (range-start range)] - [end (range-end range)]) - (send text set-clickback (+ insertion-point start) (+ insertion-point end) - (lambda (_1 _2 _3) - (send: controller selection-manager<%> - set-selected-syntax stx)))))) - -(define (standard-font text config) - (code-style text (send: config config<%> get-syntax-font-size))) - ;; display% (define display% (class* object% (display<%>) @@ -95,18 +62,48 @@ [config config<%>] [range range<%>]) (init-field text - base-style start-position end-position) + (define base-style + (code-style text (send: config config<%> get-syntax-font-size))) + (define extra-styles (make-hasheq)) ;; initialize : -> void (define/public (initialize) (send text change-style base-style start-position end-position #f) (apply-primary-partition-styles) + (add-clickbacks) (refresh)) + ;; add-clickbacks : -> void + (define/private (add-clickbacks) + (define (the-clickback editor start end) + (send: controller selection-manager<%> set-selected-syntax + (clickback->stx + (- start start-position) (- end start-position)))) + (for ([range (send: range range<%> all-ranges)]) + (let ([stx (range-obj range)] + [start (range-start range)] + [end (range-end range)]) + (send text set-clickback (+ start-position start) (+ start-position end) + the-clickback)))) + + ;; clickback->stx : num num -> syntax + ;; FIXME: use vectors for treerange-subs and do binary search to narrow? + (define/private (clickback->stx start end) + (let ([treeranges (send: range range<%> get-treeranges)]) + (let loop* ([treeranges treeranges]) + (for/or ([tr treeranges]) + (cond [(and (= (treerange-start tr) start) + (= (treerange-end tr) end)) + (treerange-obj tr)] + [(and (<= (treerange-start tr) start) + (<= end (treerange-end tr))) + (loop* (treerange-subs tr))] + [else #f]))))) + ;; refresh : -> void ;; Clears all highlighting and reapplies all non-foreground styles. (define/public (refresh) diff --git a/collects/macro-debugger/syntax-browser/image.ss b/collects/macro-debugger/syntax-browser/image.ss new file mode 100644 index 0000000000..d8151c5fdb --- /dev/null +++ b/collects/macro-debugger/syntax-browser/image.ss @@ -0,0 +1,96 @@ +#lang scheme/base +(require scheme/contract + scheme/class + scheme/gui + framework + "prefs.ss" + "controller.ss" + "display.ss") + +#| + +Code for generating images that look like the contents of a syntax +browser, with the same pretty-printing, mark-based coloring, +suffixing, etc. + +TODO: tacked arrows + +|# + +(provide/contract + [print-syntax-columns + (parameter/c (or/c exact-positive-integer? 'infinity))] + [print-syntax-to-png + (->* (syntax? path-string?) + (#:columns (or/c exact-positive-integer? 'infinity)) + any)] + [print-syntax-to-bitmap + (->* (syntax?) + (#:columns (or/c exact-positive-integer? 'infinity)) + (is-a?/c bitmap%))] + [print-syntax-to-eps + (->* (syntax? path-string?) + (#:columns (or/c exact-positive-integer? 'infinity)) + any)]) + +;; print-syntax-columns : (parameter-of (U number 'infinity)) +(define print-syntax-columns (make-parameter 40)) + +(define standard-text% (editor:standard-style-list-mixin text%)) + +;; print-syntax-to-png : syntax path -> void +(define (print-syntax-to-png stx file + #:columns [columns (print-syntax-columns)]) + (let ([bmp (print-syntax-to-bitmap stx columns)]) + (send bmp save-file file 'png)) + (void)) + +;; print-syntax-to-bitmap : syntax -> (is-a?/c bitmap%) +(define (print-syntax-to-bitmap stx + #:columns [columns (print-syntax-columns)]) + (define t (prepare-editor stx columns)) + (define f (new frame% [label "dummy"])) + (define ec (new editor-canvas% (editor t) (parent f))) + (define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) + (define char-width + (let* ([sl (send t get-style-list)] + [style (send sl find-named-style "Standard")] + [font (send style get-font)]) + (send dc set-font font) + (send dc get-char-width))) + (let ([ew (box 0.0)] + [eh (box 0.0)]) + (send t set-min-width (* columns char-width)) + (send t get-extent ew eh) + (let* ([w (inexact->exact (unbox ew))] + [h (inexact->exact (unbox eh))] + [bmp (make-object bitmap% w (+ 1 h))] + [ps (new ps-setup%)]) + (send dc set-bitmap bmp) + (send dc set-background (make-object color% "White")) + (send dc clear) + (send ps set-margin 0 0) + (send ps set-editor-margin 0 0) + (parameterize ((current-ps-setup ps)) + (send t print-to-dc dc 1)) + bmp))) + +;; print-syntax-to-eps : syntax path -> void +(define (print-syntax-to-eps stx file + #:columns [columns (print-syntax-columns)]) + (define t (prepare-editor stx columns)) + (define ps-setup (new ps-setup%)) + (send ps-setup set-mode 'file) + (send ps-setup set-file file) + (send ps-setup set-scaling 1 1) + (parameterize ((current-ps-setup ps-setup)) + (send t print #f #f 'postscript #f #f #t))) + +(define (prepare-editor stx columns) + (define t (new standard-text%)) + (define sl (send t get-style-list)) + (send t change-style (send sl find-named-style "Standard")) + (print-syntax-to-editor stx t + (new controller%) (new syntax-prefs/readonly%) + columns (send t last-position)) + t) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index 5b72ce7eb5..d6bc811761 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -124,6 +124,7 @@ (define-struct range (obj start end)) ;; A TreeRange is (make-treerange syntax nat nat (listof TreeRange)) +;; where subs are disjoint, in order, and all contained within [start, end] (define-struct treerange (obj start end subs)) ;; syntax-prefs<%> diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss index 9f570c57ef..81d1f338ad 100644 --- a/collects/macro-debugger/syntax-browser/prefs.ss +++ b/collects/macro-debugger/syntax-browser/prefs.ss @@ -29,17 +29,26 @@ (define-notify syntax-font-size (new notify-box% (value #f))) ;; colors : (listof string) - (define-notify colors - (new notify-box% - (value '("black" "red" "blue" - "mediumforestgreen" "darkgreen" - "darkred" - "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue" - "indigo" "purple" - "orange" "salmon" "darkgoldenrod" "olive")))) + (define-notify colors + (new notify-box% (value the-colors))) (super-new))) +(define alt-colors + '("black" + "red" "blue" "forestgreen" "purple" "brown" + "firebrick" "darkblue" "seagreen" "violetred" "chocolate" + "darkred" "cornflowerblue" "darkgreen" "indigo" "sandybrown" + "orange" "cadetblue" "olive" "mediumpurple" "goldenrod")) + +(define the-colors + '("black" "red" "blue" + "mediumforestgreen" "darkgreen" + "darkred" + "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue" + "indigo" "purple" + "orange" "salmon" "darkgoldenrod" "olive")) + (define syntax-prefs-base% (class* prefs-base% (config<%>) (init readonly?) diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index 73b22466e9..456eff080e 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -14,9 +14,9 @@ ;; Solution: Rather than map stx to (syntax-e stx), in the cases where ;; (syntax-e stx) is confusable, map it to a different, unique, value. -;; - stx is identifier : map it to an uninterned symbol w/ same rep -;; (Symbols are useful: see pretty-print's style table) -;; - else : map it to a syntax-dummy object +;; Use syntax-dummy, and extend pretty-print-remap-stylable to look inside. + +;; Old solution: same, except map identifiers to uninterned symbols instead ;; NOTE: Nulls are only wrapped when *not* list-terminators. ;; If they were always wrapped, the pretty-printer would screw up @@ -35,6 +35,7 @@ (pretty-print datum port))) (define-struct syntax-dummy (val)) +(define-struct (id-syntax-dummy syntax-dummy) (remap)) ;; A SuffixOption is one of ;; - 'never -- never @@ -58,16 +59,20 @@ ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) (define (table stx partition limit suffixopt) (define (make-identifier-proxy id) + (define sym (syntax-e id)) (case suffixopt - ((never) (unintern (syntax-e id))) + ((never) + (make-id-syntax-dummy sym sym)) ((always) (let ([n (send: partition partition<%> get-partition id)]) - (if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n)))) + (if (zero? n) + (make-id-syntax-dummy sym sym) + (make-id-syntax-dummy (suffix sym n) sym)))) ((over-limit) (let ([n (send: partition partition<%> get-partition id)]) (if (<= n limit) - (unintern (syntax-e id)) - (suffix (syntax-e id) n)))))) + (make-id-syntax-dummy sym sym) + (make-id-syntax-dummy (suffix sym n) sym)))))) (let/ec escape (let ([flat=>stx (make-hasheq)] @@ -111,7 +116,7 @@ (refold (map loop fields))) obj))] [(symbol? obj) - (unintern obj)] + (make-id-syntax-dummy obj obj)] [(null? obj) (make-syntax-dummy obj)] [(boolean? obj) @@ -169,8 +174,5 @@ '(quote quasiquote unquote unquote-splicing syntax)) ;; FIXME: quasisyntax unsyntax unsyntax-splicing -(define (unintern sym) - (string->uninterned-symbol (symbol->string sym))) - (define (suffix sym n) - (string->uninterned-symbol (format "~a:~a" sym n))) + (string->symbol (format "~a:~a" sym n))) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index 12953907a6..f0aa609545 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -1,6 +1,3 @@ - -;; FIXME: Need to disable printing of structs with custom-write property - #lang scheme/base (require scheme/list scheme/class @@ -10,15 +7,14 @@ "interfaces.ss") (provide pretty-print-syntax) -;; pretty-print-syntax : -;; syntax port partition (listof string) SuffixOption number -;; -> range% +;; FIXME: Need to disable printing of structs with custom-write property + +;; pretty-print-syntax : syntax port partition number SuffixOption number +;; -> range% (define (pretty-print-syntax stx port primary-partition colors suffix-option columns) (define range-builder (new range-builder%)) (define-values (datum ht:flat=>stx ht:stx=>flat) - (syntax->datum/tables stx primary-partition - (length colors) - suffix-option)) + (syntax->datum/tables stx primary-partition colors suffix-option)) (define identifier-list (filter identifier? (hash-map ht:stx=>flat (lambda (k v) k)))) (define (flat=>stx obj) @@ -40,13 +36,6 @@ [end (current-position)]) (when (and start stx) (send range-builder add-range stx (cons start end))))) - (define (pp-extend-style-table identifier-list) - (let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)] - [like-syms (map syntax-e identifier-list)]) - (pretty-print-extend-style-table (pp-better-style-table) - syms - like-syms))) - (unless (syntax? stx) (raise-type-error 'pretty-print-syntax "syntax" stx)) @@ -55,7 +44,8 @@ [pretty-print-post-print-hook pp-post-hook] [pretty-print-size-hook pp-size-hook] [pretty-print-print-hook pp-print-hook] - [pretty-print-current-style-table (pp-extend-style-table identifier-list)] + [pretty-print-remap-stylable pp-remap-stylable] + [pretty-print-current-style-table (pp-better-style-table)] [pretty-print-columns columns]) (pretty-print/defaults datum port) (new range% @@ -79,9 +69,13 @@ (string-length (get-output-string ostring)))] [else #f])) +(define (pp-remap-stylable obj) + (and (id-syntax-dummy? obj) (id-syntax-dummy-remap obj))) + (define (pp-better-style-table) (basic-style-list) - #; ;; Messes up formatting too much :( + #| + ;; Messes up formatting too much :( (let* ([pref (pref:tabify)] [table (car pref)] [begin-rx (cadr pref)] @@ -91,7 +85,8 @@ (pretty-print-extend-style-table (basic-style-list) (map car style-list) - (map cdr style-list))))) + (map cdr style-list)))) + |#) (define (basic-style-list) (pretty-print-extend-style-table From f540fc8f00c369c7338845e03c61b3aa823d2890 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 20 Nov 2009 19:36:24 +0000 Subject: [PATCH 23/92] macro-debugger: fixed binder discovery for lambda Please propagate this change to the release branch. svn: r16926 --- collects/macro-debugger/model/reductions.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 3cd9fa8308..6bdf409ec6 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -156,8 +156,8 @@ [(Wrap p:lambda (e1 e2 rs ?1 renames body)) (R [! ?1] [#:pattern (?lambda ?formals . ?body)] - [#:binders #'?formals] [#:rename (?formals . ?body) renames 'rename-lambda] + [#:binders #'?formals] [Block ?body body])] [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) (R [! ?1] From 71eef1bbd840df284b822f2c1eb1f2e939eebbe7 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 20 Nov 2009 20:45:45 +0000 Subject: [PATCH 24/92] Allow for changing the name on flat contracts via flat-named-contract. svn: r16928 --- collects/scheme/contract/private/guts.ss | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index e6e1980217..96e85aac05 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -361,10 +361,16 @@ (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) (define (flat-named-contract name predicate) - (unless (and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate)) - (make-predicate-contract name predicate)) + (cond + [(and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (make-predicate-contract name predicate)] + [(flat-contract? predicate) + (make-predicate-contract name (flat-contract-predicate predicate))] + [else + (error 'flat-named-contract + "expected a flat contract or procedure of arity 1 as second argument, got ~e" + predicate)])) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) (define (build-compound-type-name . fs) From 2a7664eba873087b19f1a6a5dd3657385fac705d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 20 Nov 2009 21:35:26 +0000 Subject: [PATCH 25/92] Fix up docs for flat-named-contract. svn: r16929 --- collects/scribblings/reference/contracts.scrbl | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 8d315d675e..25566f9a8e 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -61,16 +61,19 @@ Constructs a @tech{flat contract} from @scheme[predicate]. A value satisfies the contract if the predicate returns a true value.} -@defproc[(flat-named-contract [type-name any/c][predicate (any/c . -> . any)]) +@defproc[(flat-named-contract [type-name any/c] [predicate (or/c flat-contract? (any/c . -> . any))]) flat-contract?]{ -Like @scheme[flat-contract], but the first argument must be the +On predicates like @scheme[flat-contract], but the first argument must be the (quoted) name of a contract used for error reporting. For example, @schemeblock[(flat-named-contract 'odd-integer (lambda (x) (and (integer? x) (odd? x))))] turns the predicate into a contract with the name @tt{odd-integer}. + +On flat contracts, the new flat contract is the same as the old except for +the name. } @defthing[any/c flat-contract?]{ From 7b6eb65d798ff81974970a7e0014c2fc64a16b99 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 20 Nov 2009 22:43:01 +0000 Subject: [PATCH 26/92] vector-copy now works for empty vectors svn: r16930 --- collects/scheme/vector.ss | 36 +++++++++++++++++++++++------------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/collects/scheme/vector.ss b/collects/scheme/vector.ss index 9af85d0f7e..945126cf45 100644 --- a/collects/scheme/vector.ss +++ b/collects/scheme/vector.ss @@ -20,19 +20,29 @@ (unless (exact-nonnegative-integer? start) (raise-type-error 'vector-copy "non-negative exact integer" 1 start)) (let ([len (vector-length v)]) - (unless (and (<= 0 start) (< start len)) - (raise-mismatch-error - 'vector-copy - (format "start index ~e out of range [~e, ~e] for vector ~e" - start 0 len v) - v)) - (unless (and (<= start end) (<= end len)) - (raise-mismatch-error - 'vector-copy - (format "end index ~e out of range [~e, ~e] for vector ~e" - end start len v) - v)) - (vector-copy* v start end))) + (cond + [(= len 0) + (unless (and (= start 0) + (= end 0)) + (raise-mismatch-error + 'vector-copy + (format "start index and end index must both be 0 for empty vectors, got ~e and ~e" + start len))) + (vector)] + [else + (unless (and (<= 0 start) (< start len)) + (raise-mismatch-error + 'vector-copy + (format "start index ~e out of range [~e, ~e] for vector ~e" + start 0 len v) + v)) + (unless (and (<= start end) (<= end len)) + (raise-mismatch-error + 'vector-copy + (format "end index ~e out of range [~e, ~e] for vector ~e" + end start len v) + v)) + (vector-copy* v start end)]))) ;; do vector-map, putting the result in `target' ;; length is passed to save the computation From 47e46efd46c0a999940fea83f72641c1d2ab9804 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Nov 2009 00:15:00 +0000 Subject: [PATCH 27/92] added the various 'for' forms to the square backet default preferences svn: r16932 --- collects/framework/private/main.ss | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index b0e70f24a6..2ab8893eb3 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -76,13 +76,17 @@ '("local") (λ (x) (and (list? x) (andmap string? x)))) (preferences:set-default 'framework:square-bracket:letrec - '("let" - "let*" "let-values" "let*-values" - "let-syntax" "let-struct" "let-syntaxes" - "letrec" - "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values" - "parameterize" - "with-syntax") + (let ([fors '("for" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")]) + (append fors + (map (λ (x) (regexp-replace #rx"for" x "for*")) + fors) + '("let" + "let*" "let-values" "let*-values" + "let-syntax" "let-struct" "let-syntaxes" + "letrec" + "letrec-syntaxes" "letrec-syntaxes+values" "letrec-values" + "parameterize" + "with-syntax"))) (λ (x) (and (list? x) (andmap string? x)))) (preferences:set-default 'framework:white-on-black? #f boolean?) From 35b62665aea49a8c471d672ec7b2ba6c077b4b11 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 21 Nov 2009 00:16:08 +0000 Subject: [PATCH 28/92] fix error messages svn: r16933 --- collects/scheme/vector.ss | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/collects/scheme/vector.ss b/collects/scheme/vector.ss index 945126cf45..32582f6e00 100644 --- a/collects/scheme/vector.ss +++ b/collects/scheme/vector.ss @@ -22,25 +22,27 @@ (let ([len (vector-length v)]) (cond [(= len 0) - (unless (and (= start 0) - (= end 0)) - (raise-mismatch-error - 'vector-copy - (format "start index and end index must both be 0 for empty vectors, got ~e and ~e" - start len))) + (unless (= start 0) + (raise-mismatch-error 'vector-copy + "start index must be 0 for empty vector, got " + start)) + (unless (= end 0) + (raise-mismatch-error 'vector-copy + "end index must be 0 for empty vector, got " + end)) (vector)] [else (unless (and (<= 0 start) (< start len)) (raise-mismatch-error 'vector-copy - (format "start index ~e out of range [~e, ~e] for vector ~e" - start 0 len v) + (format "start index ~e out of range [~e, ~e] for vector: " + start 0 len) v)) (unless (and (<= start end) (<= end len)) (raise-mismatch-error 'vector-copy - (format "end index ~e out of range [~e, ~e] for vector ~e" - end start len v) + (format "end index ~e out of range [~e, ~e] for vector: " + end start len) v)) (vector-copy* v start end)]))) @@ -143,7 +145,7 @@ (unless (<= 0 n len) (raise-mismatch-error name - (format "index out of range [~e, ~e] for vector" 0 len) + (format "index out of range [~e, ~e] for vector " 0 len) v)) len)) From 41bf71fa064d6cc9f4c094f531c88dea21e815bf Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Nov 2009 04:05:23 +0000 Subject: [PATCH 29/92] futures minor re-org to prepare for mixing futures and places svn: r16934 --- src/mzscheme/src/future.c | 808 +++++++++++-------------- src/mzscheme/src/future.h | 40 +- src/mzscheme/src/gen-jit-ts.ss | 7 +- src/mzscheme/src/jit.c | 76 ++- src/mzscheme/src/jit_ts_future_glue.c | 140 +++-- src/mzscheme/src/lightning/i386/core.h | 4 + src/mzscheme/src/lightning/ppc/core.h | 2 + src/mzscheme/src/mzmark.c | 4 - src/mzscheme/src/mzmarksrc.c | 2 - 9 files changed, 516 insertions(+), 567 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index c73134a218..32d1f1b70d 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -54,88 +54,71 @@ void scheme_init_futures(Scheme_Env *env) # include "./tests/unit_test.h" #endif -extern void *on_demand_jit_code; +static Scheme_Object *future(int argc, Scheme_Object *argv[]); +static Scheme_Object *touch(int argc, Scheme_Object *argv[]); +static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]); +static void futures_init(void); +static void init_future_thread(struct Scheme_Future_State *fs, int i); #define THREAD_POOL_SIZE 12 #define INITIAL_C_STACK_SIZE 500000 -static pthread_t g_pool_threads[THREAD_POOL_SIZE]; -static int *g_fuel_pointers[THREAD_POOL_SIZE]; -static unsigned long *g_stack_boundary_pointers[THREAD_POOL_SIZE]; -static int *g_need_gc_pointers[THREAD_POOL_SIZE]; -static int g_num_avail_threads = 0; -static unsigned long g_cur_cpu_mask = 1; -static void *g_signal_handle = NULL; -static struct NewGC *g_shared_GC; -static future_t *g_future_queue = NULL; -static future_t *g_future_waiting_atomic = NULL; -static Scheme_Object *g_thread_skeleton; -int g_next_futureid = 0; -pthread_t g_rt_threadid = 0; +typedef struct Scheme_Future_State { + struct Scheme_Future_Thread_State *pool_threads[THREAD_POOL_SIZE]; -static pthread_mutex_t g_future_queue_mutex = PTHREAD_MUTEX_INITIALIZER; -static pthread_cond_t g_future_pending_cv = PTHREAD_COND_INITIALIZER; + void *signal_handle; -THREAD_LOCAL_DECL(static pthread_cond_t worker_can_continue_cv); + int future_queue_count; + future_t *future_queue; + future_t *future_queue_end; + future_t *future_waiting_atomic; + int next_futureid; + + pthread_mutex_t future_mutex; + pthread_cond_t future_pending_cv; + pthread_cond_t gc_ok_c; + pthread_cond_t gc_done_c; + + int gc_not_ok, wait_for_gc; + + int *gc_counter_ptr; + + int future_threads_created; +} Scheme_Future_State; + +typedef struct Scheme_Future_Thread_State { + int id; + pthread_t threadid; + int worker_gc_counter; + pthread_cond_t worker_can_continue_cv; + future_t *current_ft; + long runstack_size; + + volatile int *fuel_pointer; + volatile unsigned long *stack_boundary_pointer; + volatile int *need_gc_pointer; +} Scheme_Future_Thread_State; + +THREAD_LOCAL_DECL(static Scheme_Future_State *scheme_future_state); +THREAD_LOCAL_DECL(void *jit_future_storage[2]); -static pthread_cond_t gc_ok_c = PTHREAD_COND_INITIALIZER; -static pthread_cond_t gc_done_c = PTHREAD_COND_INITIALIZER; -static int gc_not_ok, wait_for_gc; #ifdef MZ_PRECISE_GC THREAD_LOCAL_DECL(extern unsigned long GC_gen0_alloc_page_ptr); #endif -static future_t **g_current_ft; -static Scheme_Object ***g_scheme_current_runstack; -static Scheme_Object ***g_scheme_current_runstack_start; -static void **g_jit_future_storage; -static Scheme_Object **g_current_thread; -static int *gc_counter_ptr; -THREAD_LOCAL_DECL(static int worker_gc_counter); - #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -extern void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv); -static void start_gc_not_ok(); -static void end_gc_not_ok(future_t *ft); +static void start_gc_not_ok(Scheme_Future_State *fs); +static void end_gc_not_ok(Scheme_Future_Thread_State *fts, + Scheme_Future_State *fs, + Scheme_Object **current_rs); -static void future_do_runtimecall(void *func, int is_atomic); - -THREAD_LOCAL_DECL(static future_t *current_ft); - -//Stuff for scheme runstack -//Some of these may mimic defines in thread.c, but are redefined here -//to avoid making any changes to that file for now (moving anything out into common -//headers, etc.) -#ifndef DEFAULT_INIT_STACK_SIZE -#define DEFAULT_INIT_STACK_SIZE 1000 -#endif - -//Functions -#ifndef UNIT_TEST static void *worker_thread_future_loop(void *arg); -static void invoke_rtcall(future_t *future); -static future_t *enqueue_future(future_t *ft);; -static future_t *get_pending_future(void); -static future_t *get_last_future(void); -#else -//Garbage stubs for unit testing -#define START_XFORM_SKIP -#define END_XFORM_SKIP -void scheme_add_global(char *name, int arity, Scheme_Env *env) { } -int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2) { return 1; } -Scheme_Object *future_touch(int futureid) -{ - Scheme_Object *args[1] = { &futureid }; - return touch(1, args); -} -#endif - -void *g_funcargs[5]; -void *func_retval = NULL; - +static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile future); +static future_t *enqueue_future(Scheme_Future_State *fs, future_t *ft);; +static future_t *get_pending_future(Scheme_Future_State *fs); #ifdef MZ_PRECISE_GC # define scheme_future_setjmp(newbuf) scheme_jit_setjmp((newbuf).jb) @@ -145,68 +128,6 @@ void *func_retval = NULL; # define scheme_future_longjmp(newbuf, v) scheme_longjmp(newbuf, v) #endif - -/**********************************************************************/ -/* Helpers for debugging */ -/**********************************************************************/ -#ifdef DEBUG_FUTURES -int g_rtcall_count = 0; - -static Scheme_Object **get_thread_runstack(void) -{ - return MZ_RUNSTACK; -} - - -static Scheme_Object **get_thread_runstack_start(void) -{ - return MZ_RUNSTACK_START; -} - -void dump_state(void) -{ - future_t *f; - pthread_mutex_lock(&g_future_queue_mutex); - printf("\n"); - printf("FUTURES STATE:\n"); - printf("-------------------------------------------------------------\n"); - if (NULL == g_future_queue) - { - printf("No futures currently running. %d thread(s) available in the thread pool.\n\n", g_num_avail_threads); - pthread_mutex_unlock(&g_future_queue_mutex); - return; - } - - for (f = g_future_queue; f != NULL; f = f->next) - { - printf("Future %d [Thread: %p, Runstack start = %p, Runstack = %p]: ", f->id, f->threadid, f->runstack_start, f->runstack); - fflush(stdout); - switch (f->status) - { - case PENDING: - printf("Waiting to be assigned to thread\n"); - break; - case RUNNING: - printf("Executing JIT code\n"); - break; - case WAITING_FOR_PRIM: - printf("Waiting for runtime primitive invocation (prim=%p)\n", (void*)f->rt_prim); - break; - case FINISHED: - printf("Finished work, waiting for cleanup\n"); - break; - } - - fflush(stdout); - printf("%d thread(s) available in the thread pool.\n", g_num_avail_threads); - printf("\n"); - fflush(stdout); - } - - pthread_mutex_unlock(&g_future_queue_mutex); -} -#endif - /**********************************************************************/ /* Semaphore helpers */ /**********************************************************************/ @@ -217,9 +138,6 @@ typedef struct sema_t { pthread_cond_t c; } sema_t; -#define SEMA_INITIALIZER { 0, PTHREAD_MUTEX_INITIALIZER, \ - PTHREAD_COND_INITIALIZER } - static void sema_wait(sema_t *s) { pthread_mutex_lock(&s->m); @@ -238,7 +156,36 @@ static void sema_signal(sema_t *s) pthread_mutex_unlock(&s->m); } -static sema_t ready_sema = SEMA_INITIALIZER; +static void sema_init(sema_t *s) +{ + pthread_mutex_init(&s->m, NULL); + pthread_cond_init(&s->c, NULL); + s->ready = 0; +} + +static void sema_destroy(sema_t *s) +{ + pthread_mutex_destroy(&s->m); + pthread_cond_destroy(&s->c); +} + +/**********************************************************************/ +/* Arguments for a newly created future thread */ +/**********************************************************************/ + +typedef struct future_thread_params_t { + struct sema_t ready_sema; + struct NewGC *shared_GC; + Scheme_Future_State *fs; + Scheme_Future_Thread_State *fts; + Scheme_Thread *thread_skeleton; + Scheme_Object **runstack_start; + + Scheme_Object ***scheme_current_runstack_ptr; + Scheme_Object ***scheme_current_runstack_start_ptr; + Scheme_Thread **current_thread_ptr; + void *jit_future_storage_ptr; +} future_thread_params_t; /**********************************************************************/ /* Plumbing for MzScheme initialization */ @@ -285,143 +232,179 @@ void scheme_init_futures(Scheme_Env *env) scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); - - REGISTER_SO(g_future_queue); - REGISTER_SO(g_future_waiting_atomic); } - -//Setup code here that should be invoked on -//the runtime thread. void futures_init(void) { - int i; - pthread_t threadid; - GC_CAN_IGNORE pthread_attr_t attr; - g_rt_threadid = pthread_self(); - g_signal_handle = scheme_get_signal_handle(); + Scheme_Future_State *fs; + void *hand; + + fs = (Scheme_Future_State *)malloc(sizeof(Scheme_Future_State)); + memset(fs, 0, sizeof(Scheme_Future_State)); + scheme_future_state = fs; + + REGISTER_SO(fs->future_queue); + REGISTER_SO(fs->future_queue_end); + REGISTER_SO(fs->future_waiting_atomic); + + pthread_mutex_init(&fs->future_mutex, NULL); + pthread_cond_init(&fs->future_pending_cv, NULL); + pthread_cond_init(&fs->gc_ok_c, NULL); + pthread_cond_init(&fs->gc_done_c, NULL); + + fs->gc_counter_ptr = &scheme_did_gc_count; + + hand = scheme_get_signal_handle(); + fs->signal_handle = hand; #ifdef MZ_PRECISE_GC register_traversers(); #endif +} + +static void init_future_thread(Scheme_Future_State *fs, int i) +{ + Scheme_Future_Thread_State *fts; + future_thread_params_t params; + pthread_t threadid; + GC_CAN_IGNORE pthread_attr_t attr; //Create the worker thread pool. These threads will //'queue up' and wait for futures to become available pthread_attr_init(&attr); - pthread_attr_setstacksize(&attr, INITIAL_C_STACK_SIZE); - for (i = 0; i < THREAD_POOL_SIZE; i++) - { - /* FIXME: insteda of using global variables, we need to - commuincate though some record. Global variables - won't work with places, since the relevant values - are all place-specific. */ - gc_counter_ptr = &scheme_did_gc_count; - g_shared_GC = GC; + pthread_attr_setstacksize(&attr, INITIAL_C_STACK_SIZE); - /* Make enough of a thread record to deal with multiple values. */ - g_thread_skeleton = (Scheme_Object *)MALLOC_ONE_TAGGED(Scheme_Thread); - g_thread_skeleton->type = scheme_thread_type; + fts = (Scheme_Future_Thread_State *)malloc(sizeof(Scheme_Future_Thread_State)); + memset(fts, 0, sizeof(Scheme_Future_Thread_State)); + fts->id = i; - pthread_create(&threadid, &attr, worker_thread_future_loop, &i); - sema_wait(&ready_sema); - - scheme_register_static(g_current_ft, sizeof(void*)); - scheme_register_static(g_scheme_current_runstack, sizeof(void*)); - scheme_register_static(g_scheme_current_runstack_start, sizeof(void*)); - scheme_register_static(g_jit_future_storage, 2 * sizeof(void*)); - scheme_register_static(g_current_thread, sizeof(void*)); + params.shared_GC = GC; + params.fts = fts; + params.fs = fs; - g_pool_threads[i] = threadid; - } + /* Make enough of a thread record to deal with multiple values. */ + params.thread_skeleton = MALLOC_ONE_TAGGED(Scheme_Thread); + params.thread_skeleton->so.type = scheme_thread_type; - g_num_avail_threads = THREAD_POOL_SIZE; -} - -static void start_gc_not_ok() -{ - while (wait_for_gc) { - pthread_cond_wait(&gc_done_c, &g_future_queue_mutex); + { + Scheme_Object **rs_start, **rs; + long init_runstack_size = 1000; + rs_start = scheme_alloc_runstack(init_runstack_size); + rs = rs_start XFORM_OK_PLUS init_runstack_size; + params.runstack_start = rs_start; + fts->runstack_size = init_runstack_size; } - gc_not_ok++; + sema_init(¶ms.ready_sema); + pthread_create(&threadid, &attr, worker_thread_future_loop, ¶ms); + sema_wait(¶ms.ready_sema); + sema_destroy(¶ms.ready_sema); + + fts->threadid = threadid; + + scheme_register_static(&fts->current_ft, sizeof(void*)); + scheme_register_static(params.scheme_current_runstack_ptr, sizeof(void*)); + scheme_register_static(params.scheme_current_runstack_start_ptr, sizeof(void*)); + scheme_register_static(params.jit_future_storage_ptr, 2 * sizeof(void*)); + scheme_register_static(params.current_thread_ptr, sizeof(void*)); + + fs->pool_threads[i] = fts; +} + +static void start_gc_not_ok(Scheme_Future_State *fs) +{ + while (fs->wait_for_gc) { + pthread_cond_wait(&fs->gc_done_c, &fs->future_mutex); + } + + fs->gc_not_ok++; #ifdef MZ_PRECISE_GC - if (worker_gc_counter != *gc_counter_ptr) { - GC_gen0_alloc_page_ptr = 0; /* forces future to ask for memory */ - worker_gc_counter = *gc_counter_ptr; + { + 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->worker_gc_counter = *fs->gc_counter_ptr; + } } #endif } -static void end_gc_not_ok(future_t *ft) +static void end_gc_not_ok(Scheme_Future_Thread_State *fts, + Scheme_Future_State *fs, + Scheme_Object **current_rs) { - if (ft) { - scheme_set_runstack_limits(ft->runstack_start, - ft->runstack_size, - ft->runstack - ft->runstack_start, - ft->runstack_size); - } + scheme_set_runstack_limits(MZ_RUNSTACK_START, + fts->runstack_size, + (current_rs + ? current_rs XFORM_OK_MINUS MZ_RUNSTACK_START + : fts->runstack_size), + fts->runstack_size); /* FIXME: clear scheme_current_thread->ku.multiple.array ? */ - --gc_not_ok; - pthread_cond_signal(&gc_ok_c); + --fs->gc_not_ok; + pthread_cond_signal(&fs->gc_ok_c); } void scheme_future_block_until_gc() { + Scheme_Future_State *fs = scheme_future_state; int i; - pthread_mutex_lock(&g_future_queue_mutex); - wait_for_gc = 1; - pthread_mutex_unlock(&g_future_queue_mutex); + if (!fs) return; + + pthread_mutex_lock(&fs->future_mutex); + fs->wait_for_gc = 1; + pthread_mutex_unlock(&fs->future_mutex); for (i = 0; i < THREAD_POOL_SIZE; i++) { - if (g_fuel_pointers[i] != NULL) - { - *(g_need_gc_pointers[i]) = 1; - *(g_fuel_pointers[i]) = 0; - *(g_stack_boundary_pointers[i]) += INITIAL_C_STACK_SIZE; - } + if (fs->pool_threads[i]) { + *(fs->pool_threads[i]->need_gc_pointer) = 1; + *(fs->pool_threads[i]->fuel_pointer) = 0; + *(fs->pool_threads[i]->stack_boundary_pointer) += INITIAL_C_STACK_SIZE; + } } asm("mfence"); - pthread_mutex_lock(&g_future_queue_mutex); - while (gc_not_ok) { - pthread_cond_wait(&gc_ok_c, &g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); + while (fs->gc_not_ok) { + pthread_cond_wait(&fs->gc_ok_c, &fs->future_mutex); } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); } void scheme_future_continue_after_gc() { + Scheme_Future_State *fs = scheme_future_state; int i; + if (!fs) return; + for (i = 0; i < THREAD_POOL_SIZE; i++) { - if (g_fuel_pointers[i] != NULL) - { - *(g_need_gc_pointers[i]) = 0; - *(g_fuel_pointers[i]) = 1; - *(g_stack_boundary_pointers[i]) -= INITIAL_C_STACK_SIZE; - } - + if (fs->pool_threads[i]) { + *(fs->pool_threads[i]->need_gc_pointer) = 0; + *(fs->pool_threads[i]->fuel_pointer) = 1; + *(fs->pool_threads[i]->stack_boundary_pointer) -= INITIAL_C_STACK_SIZE; + } } - pthread_mutex_lock(&g_future_queue_mutex); - wait_for_gc = 0; - pthread_cond_broadcast(&gc_done_c); - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); + fs->wait_for_gc = 0; + pthread_cond_broadcast(&fs->gc_done_c); + pthread_mutex_unlock(&fs->future_mutex); } void scheme_future_gc_pause() /* Called in future thread */ { - future_t *future = current_ft; - future->runstack = MZ_RUNSTACK; - pthread_mutex_lock(&g_future_queue_mutex); - end_gc_not_ok(future); - start_gc_not_ok(); /* waits until wait_for_gc is 0 */ - pthread_mutex_unlock(&g_future_queue_mutex); + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + Scheme_Future_State *fs = scheme_future_state; + + pthread_mutex_lock(&fs->future_mutex); + end_gc_not_ok(fts, fs, MZ_RUNSTACK); + start_gc_not_ok(fs); /* waits until wait_for_gc is 0 */ + pthread_mutex_unlock(&fs->future_mutex); } /**********************************************************************/ @@ -431,12 +414,8 @@ void scheme_future_gc_pause() Scheme_Object *future(int argc, Scheme_Object *argv[]) /* Called in runtime thread */ { -#ifdef DEBUG_FUTURES - LOG_THISCALL; -#endif - - int init_runstack_size; - int futureid; + Scheme_Future_State *fs = scheme_future_state; + int futureid, count; future_t *ft; Scheme_Native_Closure *nc; Scheme_Native_Closure_Data *ncd; @@ -445,6 +424,16 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) //Input validation scheme_check_proc_arity("future", 0, 0, argc, argv); + if (fs->future_threads_created < THREAD_POOL_SIZE) { + pthread_mutex_lock(&fs->future_mutex); + count = fs->future_queue_count; + pthread_mutex_unlock(&fs->future_mutex); + if (count >= fs->future_threads_created) { + init_future_thread(fs, fs->future_threads_created); + fs->future_threads_created++; + } + } + nc = (Scheme_Native_Closure*)lambda; ncd = nc->code; @@ -452,45 +441,28 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) ft = MALLOC_ONE_TAGGED(future_t); ft->so.type = scheme_future_type; - futureid = ++g_next_futureid; + futureid = ++fs->next_futureid; ft->id = futureid; ft->orig_lambda = lambda; ft->status = PENDING; - //Allocate a new scheme stack for the future - //init_runstack_size = MZ_RUNSTACK - MZ_RUNSTACK_START; - init_runstack_size = 1000; - -#ifdef DEBUG_FUTURES - printf("Allocating Scheme stack of %d bytes for future %d.\n", init_runstack_size, futureid); -#endif - - { - Scheme_Object **rs_start, **rs; - rs_start = scheme_alloc_runstack(init_runstack_size); - rs = rs_start XFORM_OK_PLUS init_runstack_size; - ft->runstack_start = rs_start; - ft->runstack = rs; - ft->runstack_size = init_runstack_size; - } - //JIT compile the code if not already jitted //Temporarily repoint MZ_RUNSTACK //to the worker thread's runstack - //in case the JIT compiler uses the stack address //when generating code - if (ncd->code == on_demand_jit_code) + if (ncd->code == scheme_on_demand_jit_code) { scheme_on_demand_generate_lambda(nc, 0, NULL); } ft->code = (void*)ncd->code; - pthread_mutex_lock(&g_future_queue_mutex); - enqueue_future(ft); + pthread_mutex_lock(&fs->future_mutex); + enqueue_future(fs, ft); //Signal that a future is pending - pthread_cond_signal(&g_future_pending_cv); - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_cond_signal(&fs->future_pending_cv); + pthread_mutex_unlock(&fs->future_mutex); return (Scheme_Object*)ft; } @@ -499,49 +471,51 @@ Scheme_Object *future(int argc, Scheme_Object *argv[]) int future_ready(Scheme_Object *obj) /* Called in runtime thread by Scheme scheduler */ { + Scheme_Future_State *fs = scheme_future_state; int ret = 0; future_t *ft = (future_t*)obj; - pthread_mutex_lock(&g_future_queue_mutex); - if (ft->work_completed || ft->rt_prim) - { - ret = 1; - } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); + if (ft->work_completed || ft->rt_prim) { + ret = 1; + } + pthread_mutex_unlock(&fs->future_mutex); + return ret; } -static void dequeue_future(future_t *ft) +static void dequeue_future(Scheme_Future_State *fs, future_t *ft) /* called from both future and runtime threads */ { START_XFORM_SKIP; + if (ft->prev == NULL) - { - //Set next to be the head of the queue - g_future_queue = ft->next; - if (g_future_queue != NULL) - g_future_queue->prev = NULL; - } + fs->future_queue = ft->next; else - { - ft->prev->next = ft->next; - if (NULL != ft->next) - ft->next->prev = ft->prev; - } + ft->prev->next = ft->next; + + if (ft->next == NULL) + fs->future_queue_end = ft->prev; + else + ft->next->prev = ft->prev; + + ft->next = NULL; + ft->prev = NULL; + + --fs->future_queue_count; + END_XFORM_SKIP; } - Scheme_Object *touch(int argc, Scheme_Object *argv[]) /* Called in runtime thread */ { + Scheme_Future_State *fs = scheme_future_state; Scheme_Object *retval = NULL; future_t *ft; if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type)) - { - scheme_wrong_type("touch", "future", 0, argc, argv); - } + scheme_wrong_type("touch", "future", 0, argc, argv); ft = (future_t*)argv[0]; @@ -550,29 +524,29 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) dump_state(); #endif - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); if (ft->status == PENDING) { ft->status = RUNNING; - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); retval = _scheme_apply(ft->orig_lambda, 0, NULL); - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); ft->work_completed = 1; ft->retval = retval; ft->status = FINISHED; - dequeue_future(ft); - pthread_mutex_unlock(&g_future_queue_mutex); + dequeue_future(fs, ft); + pthread_mutex_unlock(&fs->future_mutex); return retval; } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); //Spin waiting for primitive calls or a return value from //the worker thread wait_for_rtcall_or_completion: scheme_block_until(future_ready, NULL, (Scheme_Object*)ft, 0); - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); if (ft->work_completed) { retval = ft->retval; @@ -580,25 +554,23 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) LOG("Successfully touched future %d\n", ft->id); // fflush(stdout); - //Increment the number of available pool threads - g_num_avail_threads++; - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); } else if (ft->rt_prim) { //Invoke the primitive and stash the result //Release the lock so other threads can manipulate the queue //while the runtime call executes - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); LOG("Invoking primitive %p on behalf of future %d...", ft->rt_prim, ft->id); - invoke_rtcall(ft); + invoke_rtcall(fs, ft); LOG("done.\n"); goto wait_for_rtcall_or_completion; } else { - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); goto wait_for_rtcall_or_completion; } @@ -651,19 +623,26 @@ void *worker_thread_future_loop(void *arg) is signaled. */ { START_XFORM_SKIP; + /* valid only until signaling */ + future_thread_params_t *params = (future_thread_params_t *)arg; + Scheme_Future_Thread_State *fts = params->fts; + Scheme_Future_State *fs = params->fs; Scheme_Object *v; Scheme_Object* (*jitcode)(Scheme_Object*, int, Scheme_Object**); future_t *ft; - int id = *(int *)arg; mz_jmp_buf newbuf; scheme_init_os_thread(); - GC = g_shared_GC; - scheme_current_thread = g_thread_skeleton; + scheme_future_state = fs; + scheme_future_thread_state = fts; + + GC = params->shared_GC; + scheme_current_thread = params->thread_skeleton; //Set processor affinity - /*pthread_mutex_lock(&g_future_queue_mutex); + /*pthread_mutex_lock(&fs->future_mutex); + static unsigned long cur_cpu_mask = 1; if (pthread_setaffinity_np(pthread_self(), sizeof(g_cur_cpu_mask), &g_cur_cpu_mask)) { printf( @@ -672,60 +651,54 @@ void *worker_thread_future_loop(void *arg) pthread_self()); } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); */ - pthread_cond_init(&worker_can_continue_cv, NULL); + pthread_cond_init(&fts->worker_can_continue_cv, NULL); scheme_use_rtcall = 1; scheme_fuel_counter = 1; scheme_jit_stack_boundary = ((unsigned long)&v) - INITIAL_C_STACK_SIZE; - g_need_gc_pointers[id] = &scheme_future_need_gc_pause; - g_fuel_pointers[id] = &scheme_fuel_counter; - g_stack_boundary_pointers[id] = &scheme_jit_stack_boundary; + fts->need_gc_pointer = &scheme_future_need_gc_pause; + fts->fuel_pointer = &scheme_fuel_counter; + fts->stack_boundary_pointer = &scheme_jit_stack_boundary; - g_current_ft = ¤t_ft; - g_scheme_current_runstack = &scheme_current_runstack; - g_scheme_current_runstack_start = &scheme_current_runstack_start; - g_jit_future_storage = &jit_future_storage[0]; - g_current_thread = &scheme_current_thread; - sema_signal(&ready_sema); + MZ_RUNSTACK_START = params->runstack_start; + MZ_RUNSTACK = MZ_RUNSTACK_START + fts->runstack_size; + + params->scheme_current_runstack_ptr = &scheme_current_runstack; + params->scheme_current_runstack_start_ptr = &scheme_current_runstack_start; + params->current_thread_ptr = &scheme_current_thread; + params->jit_future_storage_ptr = &jit_future_storage[0]; + + sema_signal(¶ms->ready_sema); wait_for_work: - pthread_mutex_lock(&g_future_queue_mutex); - start_gc_not_ok(); - while (!(ft = get_pending_future())) - { - end_gc_not_ok(NULL); - pthread_cond_wait(&g_future_pending_cv, &g_future_queue_mutex); - start_gc_not_ok(); - } + pthread_mutex_lock(&fs->future_mutex); + start_gc_not_ok(fs); + while (!(ft = get_pending_future(fs))) { + end_gc_not_ok(fts, fs, NULL); + pthread_cond_wait(&fs->future_pending_cv, &fs->future_mutex); + start_gc_not_ok(fs); + } LOG("Got a signal that a future is pending..."); //Work is available for this thread ft->status = RUNNING; - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); - ft->threadid = pthread_self(); - ft->thread_short_id = id; - - //Decrement the number of available pool threads - g_num_avail_threads--; - - //Initialize the runstack for this thread - //MZ_RUNSTACK AND MZ_RUNSTACK_START should be thread-local - MZ_RUNSTACK = ft->runstack; - MZ_RUNSTACK_START = ft->runstack_start; + ft->threadid = fts->threadid; + ft->thread_short_id = fts->id; //Set up the JIT compiler for this thread scheme_jit_fill_threadlocal_table(); jitcode = (Scheme_Object* (*)(Scheme_Object*, int, Scheme_Object**))(ft->code); - current_ft = ft; + fts->current_ft = ft; //Run the code //Passing no arguments for now. @@ -749,24 +722,22 @@ void *worker_thread_future_loop(void *arg) LOG("Finished running JIT code at %p.\n", ft->code); // Get future again, since a GC may have occurred - ft = current_ft; + ft = fts->current_ft; //Set the return val in the descriptor - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); ft->work_completed = 1; ft->retval = v; - ft->runstack = NULL; - ft->runstack_start = NULL; - //Update the status ft->status = FINISHED; - dequeue_future(ft); + dequeue_future(fs, ft); - scheme_signal_received_at(g_signal_handle); + scheme_signal_received_at(fs->signal_handle); - end_gc_not_ok(NULL); - pthread_mutex_unlock(&g_future_queue_mutex); + end_gc_not_ok(fts, fs, NULL); + + pthread_mutex_unlock(&fs->future_mutex); goto wait_for_work; @@ -781,21 +752,24 @@ void scheme_check_future_work() and that can be done in any Scheme thread (e.g., get a new page for allocation). */ future_t *ft; + Scheme_Future_State *fs = scheme_future_state; + + if (!fs) return; while (1) { /* Try to get a future waiting on a atomic operation */ - pthread_mutex_lock(&g_future_queue_mutex); - ft = g_future_waiting_atomic; + pthread_mutex_lock(&fs->future_mutex); + ft = fs->future_waiting_atomic; if (ft) { - g_future_waiting_atomic = ft->next_waiting_atomic; + fs->future_waiting_atomic = ft->next_waiting_atomic; ft->next_waiting_atomic = NULL; ft->waiting_atomic = 0; } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); if (ft) { if (ft->rt_prim && ft->rt_prim_is_atomic) { - invoke_rtcall(ft); + invoke_rtcall(fs, ft); } } else break; @@ -806,44 +780,30 @@ void scheme_check_future_work() //i.e. if we are already running on the runtime thread. Otherwise returns //1, and 'retval' is set to point to the return value of the runtime //call invocation. -void future_do_runtimecall(void *func, - int is_atomic) +static void future_do_runtimecall(Scheme_Future_Thread_State *fts, + void *func, + int is_atomic) /* Called in future thread */ { START_XFORM_SKIP; future_t *future; - - //If already running on the main thread - //or no future is involved, do nothing - //and return FALSE - if (pthread_self() == g_rt_threadid) - { - //Should never get here! This check should be done - //by the caller using the macros defined in scheme-futures.h! - return; - } + Scheme_Future_State *fs = scheme_future_state; //Fetch the future descriptor for this thread - future = current_ft; + future = fts->current_ft; //set up the arguments for the runtime call //to be picked up by the main rt thread - //pthread_mutex_lock(&future->mutex); - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); - //Update the stack pointer for this future - //to be in sync with MZ_RUNSTACK - the runtime thread - //will use this value to temporarily swap its stack - //for the worker thread's - future->runstack = MZ_RUNSTACK; future->prim_func = func; future->rt_prim = 1; future->rt_prim_is_atomic = is_atomic; if (is_atomic) { if (!future->waiting_atomic) { - future->next_waiting_atomic = g_future_waiting_atomic; - g_future_waiting_atomic = future; + future->next_waiting_atomic = fs->future_waiting_atomic; + fs->future_waiting_atomic = future; future->waiting_atomic = 1; } } @@ -851,19 +811,19 @@ void future_do_runtimecall(void *func, //Update the future's status to waiting future->status = WAITING_FOR_PRIM; - scheme_signal_received_at(g_signal_handle); + scheme_signal_received_at(fs->signal_handle); //Wait for the signal that the RT call is finished - future->can_continue_cv = &worker_can_continue_cv; + future->can_continue_cv = &fts->worker_can_continue_cv; while (future->can_continue_cv) { - end_gc_not_ok(future); - pthread_cond_wait(&worker_can_continue_cv, &g_future_queue_mutex); - start_gc_not_ok(); + end_gc_not_ok(fts, fs, MZ_RUNSTACK); + pthread_cond_wait(&fts->worker_can_continue_cv, &fs->future_mutex); + start_gc_not_ok(fs); //Fetch the future instance again, in case the GC has moved the pointer - future = current_ft; + future = fts->current_ft; } - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); if (future->no_retval) { future->no_retval = 0; @@ -877,45 +837,52 @@ void future_do_runtimecall(void *func, /**********************************************************************/ /* Functions for primitive invocation */ /**********************************************************************/ -void scheme_rtcall_void_void_3args(const char *who, int src_type, void (*f)()) +void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void_3args_t f) /* Called in future thread */ { START_XFORM_SKIP; - future_t *future = current_ft; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + future_t *future = fts->current_ft; future->prim_protocol = SIG_VOID_VOID_3ARGS; + future->arg_S0 = MZ_RUNSTACK; + future->time_of_request = scheme_get_inexact_milliseconds(); future->source_of_request = who; future->source_type = src_type; - future_do_runtimecall((void*)f, 1); + future_do_runtimecall(fts, (void*)f, 1); + + future->arg_S0 = NULL; END_XFORM_SKIP; } -void *scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, void (*f)()) +unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f) /* Called in future thread */ { START_XFORM_SKIP; future_t *future; - void *retval; + unsigned long retval; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; + Scheme_Future_State *fs = scheme_future_state; while (1) { - future = current_ft; + future = fts->current_ft; future->time_of_request = 0; /* takes too long?: scheme_get_inexact_milliseconds(); */ future->source_of_request = who; future->source_type = src_type; future->prim_protocol = SIG_ALLOC_VOID_PVOID; - future_do_runtimecall((void*)f, 1); + future_do_runtimecall(fts, (void*)f, 1); - future = current_ft; + future = fts->current_ft; retval = future->alloc_retval; - future->alloc_retval = NULL; + future->alloc_retval = 0; - if (*gc_counter_ptr == future->alloc_retval_counter) + if (*fs->gc_counter_ptr == future->alloc_retval_counter) break; } @@ -924,6 +891,7 @@ void *scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, void (*f)()) } static void receive_special_result(future_t *f, Scheme_Object *retval) +/* Called in future thread */ { if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { Scheme_Thread *p = scheme_current_thread; @@ -965,7 +933,7 @@ static void send_special_result(future_t *f, Scheme_Object *retval) //Does the work of actually invoking a primitive on behalf of a //future. This function is always invoked on the main (runtime) //thread. -static void do_invoke_rtcall(future_t *future) +static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future) /* Called in runtime thread */ { #ifdef DEBUG_FUTURES @@ -1001,17 +969,16 @@ static void do_invoke_rtcall(future_t *future) { prim_void_void_3args_t func = (prim_void_void_3args_t)future->prim_func; - func(future->runstack); + func(future->arg_S0); break; } case SIG_ALLOC_VOID_PVOID: { - void *ret; + unsigned long ret; prim_alloc_void_pvoid_t func = (prim_alloc_void_pvoid_t)future->prim_func; ret = func(); future->alloc_retval = ret; - ret = NULL; future->alloc_retval_counter = scheme_did_gc_count; break; } @@ -1021,15 +988,17 @@ static void do_invoke_rtcall(future_t *future) break; } - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); //Signal the waiting worker thread that it //can continue running machine code - pthread_cond_signal(future->can_continue_cv); - future->can_continue_cv= NULL; - pthread_mutex_unlock(&g_future_queue_mutex); + if (future->can_continue_cv) { + pthread_cond_signal(future->can_continue_cv); + future->can_continue_cv= NULL; + } + pthread_mutex_unlock(&fs->future_mutex); } -static void invoke_rtcall(future_t * volatile future) +static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile future) { Scheme_Thread *p = scheme_current_thread; mz_jmp_buf newbuf, * volatile savebuf; @@ -1037,16 +1006,16 @@ static void invoke_rtcall(future_t * volatile future) savebuf = p->error_buf; p->error_buf = &newbuf; if (scheme_setjmp(newbuf)) { - pthread_mutex_lock(&g_future_queue_mutex); + pthread_mutex_lock(&fs->future_mutex); future->no_retval = 1; //Signal the waiting worker thread that it //can continue running machine code pthread_cond_signal(future->can_continue_cv); future->can_continue_cv = NULL; - pthread_mutex_unlock(&g_future_queue_mutex); + pthread_mutex_unlock(&fs->future_mutex); scheme_longjmp(*savebuf, 1); } else { - do_invoke_rtcall(future); + do_invoke_rtcall(fs, future); } p->error_buf = savebuf; } @@ -1056,89 +1025,36 @@ static void invoke_rtcall(future_t * volatile future) /* Helpers for manipulating the futures queue */ /**********************************************************************/ -future_t *enqueue_future(future_t *ft) +future_t *enqueue_future(Scheme_Future_State *fs, future_t *ft) /* Called in runtime thread */ { - future_t *last; - last = get_last_future(); - if (NULL == last) - { - g_future_queue = ft; - return ft; - } - - ft->prev = last; - last->next = ft; - ft->next = NULL; + if (fs->future_queue_end) { + fs->future_queue_end->next = ft; + ft->prev = fs->future_queue_end; + } + fs->future_queue_end = ft; + if (!fs->future_queue) + fs->future_queue = ft; + fs->future_queue_count++; return ft; } - -future_t *get_pending_future(void) +future_t *get_pending_future(Scheme_Future_State *fs) /* Called in future thread */ { START_XFORM_SKIP; future_t *f; - for (f = g_future_queue; f != NULL; f = f->next) - { - if (f->status == PENDING) - return f; - } + + for (f = fs->future_queue; f != NULL; f = f->next) { + if (f->status == PENDING) + return f; + } return NULL; END_XFORM_SKIP; } -future_t *get_last_future(void) -/* Called in runtime thread */ -{ - future_t *ft = g_future_queue; - if (NULL == ft) - { - return ft; - } - - while (ft->next != NULL) - { - ft = ft->next; - } - - return ft; -} - - -void clear_futures(void) -{ - int i; - future_t *f, *tmp; - pthread_mutex_lock(&g_future_queue_mutex); - for (i = 0; i < THREAD_POOL_SIZE; i++) - { - pthread_cancel(g_pool_threads[i]); - } - - pthread_mutex_unlock(&g_future_queue_mutex); - f = get_last_future(); - if (NULL == f) - return; - - while (1) - { - tmp = f->prev; - free(f); - if (tmp == NULL) - { - break; - } - - tmp->next = NULL; - f = tmp; - } - - g_future_queue = NULL; -} - /**********************************************************************/ /* Precise GC */ /**********************************************************************/ diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index 6fb9893ffa..d6f5fc9490 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -23,16 +23,8 @@ int scheme_make_prim_w_arity(prim_t func, char *name, int arg1, int arg2); #include "pthread.h" #include -extern pthread_t g_rt_threadid; -extern Scheme_Object *start_primitive_tracking(int argc, Scheme_Object *argv[]); -extern Scheme_Object *end_primitive_tracking(int argc, Scheme_Object *argv[]); -extern Scheme_Object *future(int argc, Scheme_Object *argv[]); -extern Scheme_Object *touch(int argc, Scheme_Object *argv[]); -extern Scheme_Object *processor_count(int argc, Scheme_Object *argv[]); -extern void futures_init(void); - typedef void (*prim_void_void_3args_t)(Scheme_Object **); -typedef void *(*prim_alloc_void_pvoid_t)(); +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*); @@ -57,9 +49,6 @@ typedef struct future_t { int work_completed; pthread_cond_t *can_continue_cv; - long runstack_size; - Scheme_Object **runstack; - Scheme_Object **runstack_start; Scheme_Object *orig_lambda; void *code; @@ -70,7 +59,7 @@ typedef struct future_t { const char *source_of_request; int source_type; - void *alloc_retval; + unsigned long alloc_retval; int alloc_retval_counter; void *prim_func; @@ -110,24 +99,6 @@ typedef struct future_t { struct future_t *next_waiting_atomic; } future_t; -#ifdef UNIT_TEST -//If unit testing, expose internal functions and vars to -//the test suite -extern future_t *g_future_queue; -extern int g_next_futureid; -extern pthread_t g_rt_threadid; - -extern void *worker_thread_future_loop(void *arg); -extern void *invoke_rtcall(future_t *future); -extern future_t *enqueue_future(void); -extern future_t *get_pending_future(void); -extern future_t *get_my_future(void); -extern future_t *get_future_by_threadid(pthread_t threadid); -extern future_t *get_future(int futureid); -extern future_t *get_last_future(void); -extern void clear_futures(void); -#endif - //Primitive instrumentation stuff //Signature flags for primitive invocations @@ -147,8 +118,8 @@ extern void clear_futures(void); /*GDB_BREAK;*/ \ } -extern void scheme_rtcall_void_void_3args(const char *who, int src_type, void (*f)()); -extern void *scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, void (*f)()); +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); #else @@ -205,6 +176,9 @@ extern void *scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, void #define LOG_RTCALL_ENV_ENV_VOID(a,b) #endif +extern void *scheme_on_demand_jit_code; +extern void scheme_on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv); + void scheme_future_block_until_gc(); void scheme_future_continue_after_gc(); void scheme_check_future_work(); diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss index 7d4928c723..e1d2fd5542 100644 --- a/src/mzscheme/src/gen-jit-ts.ss +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -64,11 +64,12 @@ @|result-type| scheme_rtcall_@|ts|(const char *who, int src_type, prim_@|ts| f@|(if (null? arg-types) "" ",")| @|args|) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @(if (string=? result-type "void") "" @string-append{@|result-type| retval;}) - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_@|ts|; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -81,8 +82,8 @@ [i (in-naturals)]) @string-append{ future->arg_@|(string t)|@|(number->string i)| = @|a|;}) "\n") - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; @(if (string=? result-type "void") "" @string-append{retval = @|fretval|;}) @(if (string=? result-type "void") "" @string-append{@|fretval| = 0;}) @(if (string=? result-type "Scheme_Object*") @string-append{receive_special_result(future, retval);} "") diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 41e1e91187..6af88e813c 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -144,7 +144,7 @@ static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *v static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code; static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code; static void *syntax_e_code; -void *on_demand_jit_code; +void *scheme_on_demand_jit_code; static void *on_demand_jit_arity_code; static void *get_stack_pointer_code; static void *stack_cache_pop_code; @@ -296,6 +296,7 @@ void scheme_jit_fill_threadlocal_table(); # define tl_scheme_jit_stack_boundary tl_delta(scheme_jit_stack_boundary) # define tl_jit_future_storage tl_delta(jit_future_storage) # define tl_scheme_future_need_gc_pause tl_delta(scheme_future_need_gc_pause) +# define tl_scheme_use_rtcall tl_delta(scheme_use_rtcall) #ifdef MZ_XFORM START_XFORM_SKIP; @@ -2194,6 +2195,27 @@ extern int g_print_prims; # define mz_prepare_direct_prim(n) mz_prepare(n) # define mz_finishr_direct_prim(reg, proc) (jit_pusharg_p(reg), (void)mz_finish(proc)) # define mz_direct_only(p) /* skip this arg, so that total count <= 3 args */ +/* Inlines check of scheme_use_rtcall: */ +# define mz_generate_direct_prim(direct_only, first_arg, reg, prim_indirect) \ + { \ + GC_CAN_IGNORE jit_insn *refdirect, *refcont; \ + int argstate; \ + jit_save_argstate(argstate); \ + mz_tl_ldi_i(JIT_R0, tl_scheme_use_rtcall); \ + __START_TINY_JUMPS__(1); \ + refdirect = jit_beqi_i(jit_forward(), JIT_R0, 0); \ + first_arg; \ + mz_finishr_direct_prim(reg, prim_indirect); \ + refcont = jit_jmpi(jit_forward()); \ + CHECK_LIMIT(); \ + mz_patch_branch(refdirect); \ + jit_restore_argstate(argstate); \ + direct_only; \ + first_arg; \ + mz_finishr(reg); \ + mz_patch_ucbranch(refcont); \ + __END_TINY_JUMPS__(1); \ + } static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) { START_XFORM_SKIP; @@ -2239,7 +2261,7 @@ static void ts_on_demand(void) static void *ts_prepare_retry_alloc(void *p, void *p2) { START_XFORM_SKIP; - void *ret; + unsigned long ret; if (scheme_use_rtcall) { jit_future_storage[0] = p; @@ -2265,6 +2287,8 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) # define mz_direct_only(p) p # define ts_on_demand on_demand # define ts_prepare_retry_alloc prepare_retry_alloc +# define mz_generate_direct_prim(direct_only, first_arg, reg, prim_indirect) \ + (mz_direct_only(direct_only), first_arg, mz_finishr_direct_prim(reg, prim_indirect)) #endif static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, @@ -2339,9 +2363,12 @@ static int generate_direct_prim_tail_call(mz_jit_state *jitter, int num_rands) jit_movi_i(JIT_R1, num_rands); mz_prepare_direct_prim(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */ CHECK_LIMIT(); - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_i(JIT_R1); - mz_finishr_direct_prim(JIT_V1, noncm_prim_indirect); + { + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_i(JIT_R1), + JIT_V1, noncm_prim_indirect); + } CHECK_LIMIT(); /* Return: */ mz_pop_threadlocal(); @@ -2544,9 +2571,12 @@ static int generate_direct_prim_non_tail_call(mz_jit_state *jitter, int num_rand jit_movi_i(JIT_R1, num_rands); mz_prepare_direct_prim(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */ CHECK_LIMIT(); - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_i(JIT_R1); - mz_finishr_direct_prim(JIT_V1, noncm_prim_indirect); + { + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_i(JIT_R1), + JIT_V1, noncm_prim_indirect); + } CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -2839,9 +2869,14 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc mz_prepare_direct_prim(3); jit_pusharg_p(JIT_V1); if (num_rands < 0) { jit_movr_p(JIT_V1, JIT_R0); } /* save argc to manually pop runstack */ - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_i(JIT_R2); - mz_finishr_direct_prim(JIT_R1, prim_indirect); + { + __END_SHORT_JUMPS__(1); + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_i(JIT_R2), + JIT_R1, prim_indirect); + __START_SHORT_JUMPS__(1); + } CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -8232,9 +8267,12 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) } JIT_UPDATE_THREAD_RSPTR(); mz_prepare_direct_prim(2); - mz_direct_only(jit_pusharg_p(JIT_RUNSTACK)); - jit_pusharg_p(JIT_R1); - mz_finishr_direct_prim(JIT_R2, noncm_prim_indirect); + { + /* May use JIT_R0 and create local branch: */ + mz_generate_direct_prim(jit_pusharg_p(JIT_RUNSTACK), + jit_pusharg_p(JIT_R1), + JIT_R2, noncm_prim_indirect); + } CHECK_LIMIT(); jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); @@ -8262,7 +8300,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Used as the code stub for a closure whose code is not yet compiled. See generate_function_prolog for the state of registers on entry */ - on_demand_jit_code = jit_get_ip().ptr; + scheme_on_demand_jit_code = jit_get_ip().ptr; jit_prolog(NATIVE_ARG_COUNT); in = jit_arg_p(); jit_getarg_p(JIT_R0, in); /* closure */ @@ -8332,7 +8370,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_pop_locals(); jit_ret(); CHECK_LIMIT(); - register_helper_func(jitter, on_demand_jit_code); + register_helper_func(jitter, scheme_on_demand_jit_code); /* *** app_values_tail_slow_code *** */ /* RELIES ON jit_prolog(NATIVE_ARG_COUNT) FROM ABOVE */ @@ -9556,7 +9594,7 @@ static void on_demand_with_args(Scheme_Object **in_argv) argc = in_argv[1]; argv = (Scheme_Object **)in_argv[2]; - if (((Scheme_Native_Closure *)c)->code->code == on_demand_jit_code) + if (((Scheme_Native_Closure *)c)->code->code == scheme_on_demand_jit_code) scheme_on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv); } @@ -9591,7 +9629,7 @@ Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, in ndata->iso.so.type = scheme_rt_native_code_plus_case; #endif } - ndata->code = on_demand_jit_code; + ndata->code = scheme_on_demand_jit_code; ndata->u.tail_code = on_demand_jit_arity_code; ndata->arity_code = on_demand_jit_arity_code; ndata->u2.orig_code = data; @@ -9861,7 +9899,7 @@ static void generate_case_lambda(Scheme_Case_Lambda *c, Scheme_Native_Closure_Da static int lambda_has_been_jitted(Scheme_Native_Closure_Data *ndata) { - return (ndata->code != on_demand_jit_code); + return (ndata->code != scheme_on_demand_jit_code); } int scheme_native_arity_check(Scheme_Object *closure, int argc) diff --git a/src/mzscheme/src/jit_ts_future_glue.c b/src/mzscheme/src/jit_ts_future_glue.c index cd02973459..3c7177bca9 100644 --- a/src/mzscheme/src/jit_ts_future_glue.c +++ b/src/mzscheme/src/jit_ts_future_glue.c @@ -1,11 +1,12 @@ Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g44, int g45, Scheme_Object** g46) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_siS_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -15,8 +16,8 @@ future->arg_s0 = g44; future->arg_i1 = g45; future->arg_S2 = g46; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -26,11 +27,12 @@ Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_iSs_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -40,8 +42,8 @@ future->arg_i0 = g47; future->arg_S1 = g48; future->arg_s2 = g49; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -51,11 +53,12 @@ Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g50) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_s_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -63,8 +66,8 @@ future->source_of_request = who; future->source_type = src_type; future->arg_s0 = g50; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -74,11 +77,12 @@ Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g51) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_n_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -86,8 +90,8 @@ future->source_of_request = who; future->source_type = src_type; future->arg_n0 = g51; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -97,11 +101,12 @@ Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG__s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -109,8 +114,8 @@ future->source_of_request = who; future->source_type = src_type; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -120,11 +125,12 @@ Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_ss_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -133,8 +139,8 @@ future->source_type = src_type; future->arg_s0 = g52; future->arg_s1 = g53; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -144,11 +150,12 @@ MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; MZ_MARK_STACK_TYPE retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_ss_m; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -157,8 +164,8 @@ future->source_type = src_type; future->arg_s0 = g54; future->arg_s1 = g55; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_m; future->retval_m = 0; @@ -168,11 +175,12 @@ Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g56, long g57) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_Sl_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -181,8 +189,8 @@ future->source_type = src_type; future->arg_S0 = g56; future->arg_l1 = g57; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -192,11 +200,12 @@ Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g58) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_l_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -204,8 +213,8 @@ future->source_of_request = who; future->source_type = src_type; future->arg_l0 = g58; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -215,11 +224,12 @@ void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_bsi_v; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -229,8 +239,8 @@ future->arg_b0 = g59; future->arg_s1 = g60; future->arg_i2 = g61; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; @@ -240,11 +250,12 @@ void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g62, int g63, Scheme_Object** g64) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_iiS_v; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -254,8 +265,8 @@ future->arg_i0 = g62; future->arg_i1 = g63; future->arg_S2 = g64; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; @@ -265,11 +276,12 @@ void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g65, Scheme_Object* g66) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_ss_v; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -278,8 +290,8 @@ future->source_type = src_type; future->arg_s0 = g65; future->arg_s1 = g66; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; @@ -289,11 +301,12 @@ void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g67) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_b_v; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -301,8 +314,8 @@ future->source_of_request = who; future->source_type = src_type; future->arg_b0 = g67; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; @@ -312,11 +325,12 @@ Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g68, long g69) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_sl_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -325,8 +339,8 @@ future->source_type = src_type; future->arg_s0 = g68; future->arg_l1 = g69; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -336,11 +350,12 @@ Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g70, Scheme_Object** g71) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_iS_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -349,8 +364,8 @@ future->source_type = src_type; future->arg_i0 = g70; future->arg_S1 = g71; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -360,11 +375,12 @@ Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g72) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_S_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -372,8 +388,8 @@ future->source_of_request = who; future->source_type = src_type; future->arg_S0 = g72; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -383,11 +399,12 @@ void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g73) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_s_v; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -395,8 +412,8 @@ future->source_of_request = who; future->source_type = src_type; future->arg_s0 = g73; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; @@ -406,11 +423,12 @@ Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g74, Scheme_Object** g75, int g76) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; Scheme_Object* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_iSi_s; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -420,8 +438,8 @@ future->arg_i0 = g74; future->arg_S1 = g75; future->arg_i2 = g76; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; receive_special_result(future, retval); @@ -431,11 +449,12 @@ void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_siS_v; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -445,8 +464,8 @@ future->arg_s0 = g77; future->arg_i1 = g78; future->arg_S2 = g79; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; @@ -456,11 +475,12 @@ void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g80) { START_XFORM_SKIP; + Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; void* retval; - future = current_ft; + future = fts->current_ft; future->prim_protocol = SIG_z_p; future->prim_func = f; tm = scheme_get_inexact_milliseconds(); @@ -468,8 +488,8 @@ future->source_of_request = who; future->source_type = src_type; future->arg_z0 = g80; - future_do_runtimecall((void*)f, 0); - future = current_ft; + future_do_runtimecall(fts, (void*)f, 0); + future = fts->current_ft; retval = future->retval_p; future->retval_p = 0; diff --git a/src/mzscheme/src/lightning/i386/core.h b/src/mzscheme/src/lightning/i386/core.h index f41bb3cd43..e6f72085a4 100644 --- a/src/mzscheme/src/lightning/i386/core.h +++ b/src/mzscheme/src/lightning/i386/core.h @@ -373,6 +373,8 @@ struct jit_local_state { #define jit_prepare_d(nd) (_jitl.argssize += 2 * (nd)) #ifdef JIT_X86_64 # define jit_pusharg_i(rs) (_jitl.argssize++, MOVQrr(rs, JIT_CALLTMPSTART + _jitl.argssize - 1)) +# define jit_save_argstate(curstate) curstate = _jitl.argssize; +# define jit_restore_argstate(curstate) _jitl.argssize = curstate; # define jit_finish(sub) (jit_shift_args(), (void)jit_calli((sub)), jit_restore_locals()) # define jit_normal_finish(sub) jit_calli((sub)) # define jit_reg_is_arg(reg) ((reg == _EDI) || (reg ==_ESI) || (reg == _EDX)) @@ -396,6 +398,8 @@ struct jit_local_state { (MOVQrr(_R12, _ESI), MOVQrr(_R13, _EDI)) #else # define jit_pusharg_i(rs) PUSHLr(rs) +# define jit_save_argstate(curstate) curstate = _jitl.argssize; +# define jit_restore_argstate(curstate) _jitl.argssize = curstate; # define jit_finish(sub) ((void)jit_calli((sub)), ADDLir(sizeof(long) * _jitl.argssize, JIT_SP), _jitl.argssize = 0) # define jit_finishr(reg) (jit_callr((reg)), ADDLir(sizeof(long) * _jitl.argssize, JIT_SP), _jitl.argssize = 0) # define jit_normal_finish(sub) jit_finish(sub) diff --git a/src/mzscheme/src/lightning/ppc/core.h b/src/mzscheme/src/lightning/ppc/core.h index de6f406b3d..534a213651 100644 --- a/src/mzscheme/src/lightning/ppc/core.h +++ b/src/mzscheme/src/lightning/ppc/core.h @@ -246,6 +246,8 @@ struct jit_local_state { #define jit_prolog(n) _jit_prolog(&_jit, (n)) #define jit_pushr_i(rs) STWUrm((rs), -4, 1) #define jit_pusharg_i(rs) (--_jitl.nextarg_puti, MRrr((3 + _jitl.nextarg_putd * 2 + _jitl.nextarg_putf + _jitl.nextarg_puti), (rs))) +#define jit_save_argstate(curstate) (curstate = _jitl.nextarg_puti) +#define jit_restore_argstate(curstate) (_jitl.nextarg_puti = curstate) #define jit_ret() _jit_epilog(&_jit) #define jit_retval_i(rd) MRrr((rd), 3) #define jit_rsbi_i(d, rs, is) jit_chk_ims((is), SUBFICrri((d), (rs), (is)), SUBFCrrr((d), (rs), JIT_AUX)) diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index db5cbca0e4..d93dee46de 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5420,8 +5420,6 @@ static int future_SIZE(void *p) { static int future_MARK(void *p) { future_t *f = (future_t *)p; - gcMARK(f->runstack); - gcMARK(f->runstack_start); gcMARK(f->orig_lambda); gcMARK(f->arg_s0); gcMARK(f->arg_S0); @@ -5445,8 +5443,6 @@ static int future_MARK(void *p) { static int future_FIXUP(void *p) { future_t *f = (future_t *)p; - gcFIXUP(f->runstack); - gcFIXUP(f->runstack_start); gcFIXUP(f->orig_lambda); gcFIXUP(f->arg_s0); gcFIXUP(f->arg_S0); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 47c96e960c..7a29d0fc72 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2223,8 +2223,6 @@ START future; future { mark: future_t *f = (future_t *)p; - gcMARK(f->runstack); - gcMARK(f->runstack_start); gcMARK(f->orig_lambda); gcMARK(f->arg_s0); gcMARK(f->arg_S0); From e7f47a0882754ef7880c5458e9347d9b7ccbec30 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Nov 2009 04:25:01 +0000 Subject: [PATCH 30/92] fix XFORM_SKIP annotation placement that MSVC doesn't like svn: r16936 --- src/mzscheme/src/fun.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index c47c12e119..5dfc190be8 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -7971,10 +7971,12 @@ long scheme_get_milliseconds(void) #endif } +#ifdef MZ_XFORM +START_XFORM_SKIP; +#endif double scheme_get_inexact_milliseconds(void) /* this function can be called from any OS thread */ { - START_XFORM_SKIP; #ifdef USE_MACTIME { UnsignedWide time; @@ -7999,8 +8001,11 @@ double scheme_get_inexact_milliseconds(void) # endif # endif #endif - END_XFORM_SKIP; } +#ifdef MZ_XFORM +END_XFORM_SKIP; +#endif + long scheme_get_process_milliseconds(void) { From e3a23fbde6aa2155243aeb56c5b5df5b3f0fffd3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 21 Nov 2009 08:50:32 +0000 Subject: [PATCH 31/92] Welcome to a new PLT day. svn: r16938 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index a01f4bcab8..d584585719 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20nov2009") +#lang scheme/base (provide stamp) (define stamp "21nov2009") From 9454a471d3c1b46ea1d255cea2ab056cb3a0c438 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 21 Nov 2009 13:21:30 +0000 Subject: [PATCH 32/92] added some vector-copy tests svn: r16940 --- collects/tests/mzscheme/vector.ss | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/collects/tests/mzscheme/vector.ss b/collects/tests/mzscheme/vector.ss index 223477a5e9..90a40244aa 100644 --- a/collects/tests/mzscheme/vector.ss +++ b/collects/tests/mzscheme/vector.ss @@ -119,6 +119,17 @@ (test 2 vector-count even? #(1 2 3 4)) (test 2 vector-count < #(1 2 3 4) #(4 3 2 1))) +;; ---------- vector-copy ---------- + +(let () + (test #() vector-copy #()) + (test #(1 2 3) vector-copy #(1 2 3)) + (test #f immutable? (vector-copy #(1 2 3))) + (let ([v (vector 1 2 3)]) + (test #f eq? v (vector-copy v)))) + + + ;; ---------- vector-arg{min,max} ---------- (let () From 7b05f7587834dcf6a3bea16acb3df96ab32bd861 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Nov 2009 16:16:41 +0000 Subject: [PATCH 33/92] misc fixes to build related to thread-local support svn: r16941 --- src/mred/gc2/Makefile.in | 2 +- src/mzscheme/gc2/gc2.h | 17 +++++++++++------ src/mzscheme/gc2/newgc.c | 18 +++++++++++++++--- src/mzscheme/include/schthread.h | 16 ++++++---------- 4 files changed, 33 insertions(+), 20 deletions(-) diff --git a/src/mred/gc2/Makefile.in b/src/mred/gc2/Makefile.in index 72fd98a870..271d352a1b 100644 --- a/src/mred/gc2/Makefile.in +++ b/src/mred/gc2/Makefile.in @@ -431,7 +431,7 @@ xsrc/wxs_win.cc: $(srcdir)/../wxs/wxs_win.cxx $(XFORMDEP) $(XFORMPRECOMPDEP) xsrc/wxJPEG.cc: $(srcdir)/../../wxcommon/wxJPEG.cxx $(XFORMDEP) $(XFORMPRECOMPDEP) $(XFORMWP) xsrc/wxJPEG.cc $(srcdir)/../../wxcommon/wxJPEG.cxx -GCPREINC = -DSCHEME_THREADLOCAL_H -include $(srcdir)/../../mzscheme/gc2/gc2.h +GCPREINC = -include $(srcdir)/../../mzscheme/gc2/gc2.h POSTFLAGS = $(OPTIONS) @COMPFLAGS@ @PROFFLAGS@ @CFLAGS@ XXPOSTFLAGS = $(OPTIONS) @COMPFLAGS@ @PROFFLAGS@ @CXXFLAGS@ diff --git a/src/mzscheme/gc2/gc2.h b/src/mzscheme/gc2/gc2.h index 8ff30d2c2a..8e7f14b69c 100644 --- a/src/mzscheme/gc2/gc2.h +++ b/src/mzscheme/gc2/gc2.h @@ -2,10 +2,12 @@ #ifndef __mzscheme_gc_2__ #define __mzscheme_gc_2__ -#ifdef INCLUDE_WITHOUT_PATHS -# include "schthread.h" -#else -# include "../include/schthread.h" +#ifndef GC2_JUST_MACROS +# ifdef INCLUDE_WITHOUT_PATHS +# include "schthread.h" +# else +# include "../include/schthread.h" +# endif #endif /***************************************************************************/ @@ -409,9 +411,12 @@ GC2_EXTERN void GC_switch_back_from_master(void *gc); Switches to back to gc from the master GC */ -GC2_EXTERN void *GC_make_jit_nursery_page(); +GC2_EXTERN unsigned long GC_make_jit_nursery_page(); /* - obtains a nursery page from the GC for thread local allocation + Obtains a nursery page from the GC for thread local allocation. + 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. */ diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 679875c40a..6771384a35 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -417,7 +417,7 @@ int GC_is_allocated(void *p) /* struct objhead is defined in gc2_obj.h */ /* Make sure alloction starts out double-word aligned. The header on each allocated object is one word, so to make - the content double-word aligned, we deeper. */ + the content double-word aligned, we may need a prefix. */ #ifdef GC_ALIGN_SIXTEEN # ifdef SIXTY_FOUR_BIT_INTEGERS # define PREFIX_WSIZE 1 @@ -722,7 +722,7 @@ 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 -void *GC_make_jit_nursery_page() { +unsigned long GC_make_jit_nursery_page() { NewGC *gc = GC_get_GC(); mpage *new_mpage; @@ -742,7 +742,19 @@ void *GC_make_jit_nursery_page() { gc->thread_local_pages = new_mpage; } - return (void *)(NUM(new_mpage->addr) + new_mpage->size); + if (!new_mpage->size) { + /* To avoid roundoff problems, the JIT needs the + result to be not a multiple of THREAD_LOCAL_PAGE_SIZE, + so add a prefix if alignment didn't force one. */ +#if defined(GC_ALIGN_SIXTEEN) + new_mpage->size = 16; +#elif defined(GC_ALIGN_EIGHT) + new_mpage->size = 8; +#else + new_mpage->size = WORD_SIZE; +#endif + } + return (NUM(new_mpage->addr) + new_mpage->size); } inline static void gen0_free_jit_nursery_page(NewGC *gc, mpage *page) { diff --git a/src/mzscheme/include/schthread.h b/src/mzscheme/include/schthread.h index e86aad0b49..4408f74ce8 100644 --- a/src/mzscheme/include/schthread.h +++ b/src/mzscheme/include/schthread.h @@ -110,7 +110,6 @@ typedef struct Thread_Local_Variables { struct Scheme_Overflow *offstack_overflow_; struct Scheme_Overflow_Jmp *scheme_overflow_jmp_; void *scheme_overflow_stack_start_; - struct future_t *current_ft_; void **codetab_tree_; int during_set_; Stack_Cache_Elem stack_cache_stack_[STACK_CACHE_SIZE]; @@ -181,7 +180,9 @@ typedef struct Thread_Local_Variables { int swap_no_setjmp_; int thread_swap_count_; int scheme_did_gc_count_; - int worker_gc_counter_; + struct Scheme_Future_State *scheme_future_state_; + struct Scheme_Future_Thread_State *scheme_future_thread_state_; + void *jit_future_storage_[2]; struct Scheme_Object **scheme_current_runstack_start_; struct Scheme_Object **scheme_current_runstack_; MZ_MARK_STACK_TYPE scheme_current_cont_mark_stack_; @@ -212,10 +213,6 @@ typedef struct Thread_Local_Variables { unsigned long current_total_allocation_; struct gmp_tmp_stack gmp_tmp_xxx_; struct gmp_tmp_stack *gmp_tmp_current_; -#if FUTURES_ENABLED - pthread_cond_t worker_can_continue_cv_; - void *jit_future_storage_[2]; -#endif } Thread_Local_Variables; #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) @@ -274,7 +271,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define offstack_overflow XOA (scheme_get_thread_local_variables()->offstack_overflow_) #define scheme_overflow_jmp XOA (scheme_get_thread_local_variables()->scheme_overflow_jmp_) #define scheme_overflow_stack_start XOA (scheme_get_thread_local_variables()->scheme_overflow_stack_start_) -#define current_ft XOA (scheme_get_thread_local_variables()->current_ft_) #define codetab_tree XOA (scheme_get_thread_local_variables()->codetab_tree_) #define during_set XOA (scheme_get_thread_local_variables()->during_set_) #define thread_local_pointers XOA (scheme_get_thread_local_variables()->thread_local_pointers_) @@ -346,7 +342,9 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define swap_no_setjmp XOA (scheme_get_thread_local_variables()->swap_no_setjmp_) #define thread_swap_count XOA (scheme_get_thread_local_variables()->thread_swap_count_) #define scheme_did_gc_count XOA (scheme_get_thread_local_variables()->scheme_did_gc_count_) -#define worker_gc_counter XOA (scheme_get_thread_local_variables()->worker_gc_counter_) +#define scheme_future_state XOA (scheme_get_thread_local_variables()->scheme_future_state_) +#define scheme_future_thread_state XOA (scheme_get_thread_local_variables()->scheme_future_thread_state_) +#define jit_future_storage XOA (scheme_get_thread_local_variables()->jit_future_storage_) #define scheme_current_runstack_start XOA (scheme_get_thread_local_variables()->scheme_current_runstack_start_) #define scheme_current_runstack XOA (scheme_get_thread_local_variables()->scheme_current_runstack_) #define scheme_current_cont_mark_stack XOA (scheme_get_thread_local_variables()->scheme_current_cont_mark_stack_) @@ -377,8 +375,6 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define current_total_allocation XOA (scheme_get_thread_local_variables()->current_total_allocation_) #define gmp_tmp_xxx XOA (scheme_get_thread_local_variables()->gmp_tmp_xxx_) #define gmp_tmp_current XOA (scheme_get_thread_local_variables()->gmp_tmp_current_) -#define worker_can_continue_cv XOA (scheme_get_thread_local_variables()->worker_can_continue_cv_) -#define jit_future_storage XOA (scheme_get_thread_local_variables()->jit_future_storage_) /* **************************************** */ From fbf7f79d8c16046f10a0fcf612ef376d37d1d46d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Nov 2009 16:17:08 +0000 Subject: [PATCH 34/92] fix get-default-print-size n landscape mode svn: r16942 --- collects/mred/private/wxme/editor.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 716743bc38..1c8ec16aaa 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -97,9 +97,9 @@ (set-box! w PAGE-WIDTH) (set-box! h PAGE-HEIGHT) (when (eq? (get-printer-orientation) 'landscape) - (let ([tmp h]) - (set! h w) - (set! w tmp)))) + (let ([tmp (unbox h)]) + (set-box! h (unbox w)) + (set-box! w tmp)))) ;; ---------------------------------------- From 128da973dfe217afbf609e1e27c6e3843ed81f2c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 21 Nov 2009 21:53:06 +0000 Subject: [PATCH 35/92] Truing to use JS `eval' in several ways doesn't seem to be doing anything for speed. So dump all attempts at making things faster this way. Also, it seems that things are responsive enough with any break in the searching "thread", so shorten that time. (And one other random optimization: abort early when an item doesn't match.) svn: r16943 --- collects/scribblings/main/private/search.js | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js index 999009634a..6fe21b2e81 100644 --- a/collects/scribblings/main/private/search.js +++ b/collects/scribblings/main/private/search.js @@ -439,20 +439,21 @@ function Search(data, term, is_pre, K) { var r, min = C_max, max = C_min; for (var j=0; j= C_rexact && min >= C_exact) exacts.push(data[i]); else if (min > C_wordmatch) matches.push(data[i]); else if (min > C_fail) wordmatches.push(data[i]); fuel--; i++; } - if (i Date: Sat, 21 Nov 2009 21:55:34 +0000 Subject: [PATCH 36/92] Added A:{ ... } and O:{ ... } for `and' and `or' queries, and Q:foo for "quoted" things so "}" can be included in these. Not documented at the user level for now, since I'm not sure that this will work fine in general, but it's good enough to reactivate context-sensitive searches. svn: r16944 --- collects/scribblings/main/private/search.js | 60 +++++++++++++++++++-- 1 file changed, 56 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js index 6fe21b2e81..042f404ca0 100644 --- a/collects/scribblings/main/private/search.js +++ b/collects/scribblings/main/private/search.js @@ -342,11 +342,18 @@ function UrlToManual(url) { // "L:scheme" (no exact matches except for the `scheme' module) // "L:schem" (only module names that match `schem') +// Additional "hidden" operators: +// "A:{ foo bar }" -- an `and' query +// "O:{ foo bar }" -- an `or' query +// "Q:foo" -- stands for just "foo", useful for quoting Q:} inside the above +// Note: they're "hidden" because the syntax might change, and it's intended +// mostly for context queries. + function CompileTerm(term) { - var op = ((term.search(/^[NLMT]:/) == 0) && term.substring(0,1)); + var op = ((term.search(/^[NLMTQ]:/) == 0) && term.substring(0,1)); if (op) term = term.substring(2); term = term.toLowerCase(); - switch(op) { + switch (op) { case "N": op = CompileTerm(term); // return C_exact if it's not found, so it doesn't disqualify exact matches @@ -370,6 +377,7 @@ function CompileTerm(term) { else if (x[1].search(/\/index\.html$/) > 0) return C_rexact; else return C_exact; } + /* a case for "Q" is not needed -- same as the default case below */ default: var words = term.split(/\b/); for (var i=0; i= C_max) return r; + } + return r; + }; +} + +function CompileTermsR(terms, nested) { + var term, result = new Array(); + while (terms.length > 0) { + term = terms.pop(); + switch (term) { + case "A:{": result.push(CompileTermsR(terms, CompileAndTerms)); break; + case "O:{": result.push(CompileTermsR(terms, CompileOrTerms)); break; + default: + // "}" has terminates a compound, otherwise it's an ordinary search term + if (nested && (term == "}")) return nested(result); + else result.push(CompileTerm(term)); + } + } + // all compound operators are implicitly terminated at the end + if (nested) return nested(result); + else return result; +} + +function CompileTerms(terms, nested) { + terms.reverse(); + return CompileTermsR(terms, nested) +} + function Id(x) { return x; } @@ -421,8 +474,7 @@ function Search(data, term, is_pre, K) { var t = false; var killer = function() { if (t) clearTimeout(t); }; // term comes with normalized spaces (trimmed, and no double spaces) - var preds = (term=="") ? [] : term.split(/ /); - for (var i=0; i Date: Sat, 21 Nov 2009 22:05:28 +0000 Subject: [PATCH 37/92] Re-enable context searches for the htdp languages, with results that come from the language or the teachpacks. svn: r16945 --- collects/lang/htdp-langs.ss | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index f472763c63..5c099e69fc 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -514,16 +514,13 @@ keywords] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:special:insert-lambda) #f] - #; - ;; FIXME: disable context for now, re-enable when it is possible - ;; to have the context search the teachpack manual too. [(drscheme:help-context-term) (let* ([m (get-module)] [m (and m (pair? m) (pair? (cdr m)) (cadr m))] [m (and m (regexp-match #rx"^(lang/[^/.]+).ss$" m))] [m (and m (cadr m))]) (if m - (format "L:~a" m) + (format "O:{ L:~a T:teachpack }" m) (error 'drscheme:help-context-term "internal error: unexpected module spec")))] [(tests:test-menu tests:dock-menu) #t] From 28f5070d5e3a46e05e87d5463de03b1f38a61251 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Nov 2009 02:22:19 +0000 Subject: [PATCH 38/92] undo accidental commenting svn: r16951 --- collects/tests/run-automated-tests.ss | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index c0e6a22a7c..2f27debe89 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -31,16 +31,16 @@ ;; special flag that means that errors raised by the test suite are ;; ignored, and should only be used by the mzscheme tests.) (define tests - '(;[no-handler load "mzscheme/quiet.ss" (lib "scheme/init")] + '([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")] ;; [require "planet/lang.ss"] [require "typed-scheme/nightly-run.ss"] -; [require "match/plt-match-tests.ss"] - ; ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] + [require "match/plt-match-tests.ss"] + ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] - ; [require "scribble/main.ss"] - ;[require "net/main.ss"] -; [require "file/main.ss"] - ; [require "profile/main.ss"] + [require "scribble/main.ss"] + [require "net/main.ss"] + [require "file/main.ss"] + [require "profile/main.ss"] )) (require scheme/runtime-path) From 79817a2087111af19d1e2f418076a1de2bece5a8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 02:34:40 +0000 Subject: [PATCH 39/92] slimy pthread_getspecifc()-inlining trick to practically eliminate the overhead of futures support under OS X svn: r16952 --- collects/compiler/private/xform.ss | 45 ++++++----- .../mzscheme/benchmarks/common/nucleic2.sch | 2 +- src/mzscheme/include/schthread.h | 27 ++++++- src/mzscheme/main.c | 8 ++ src/mzscheme/src/salloc.c | 78 ++++++++++++++----- 5 files changed, 118 insertions(+), 42 deletions(-) diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index d84cd33860..8ef3191e48 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -585,20 +585,22 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define per-block-push? #t) - (define gc-var-stack-through-table? + (define gc-var-stack-mode (ormap (lambda (e) - (and (pragma? e) - (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e)))) - e-raw)) - (define gc-var-stack-through-thread-local? - (ormap (lambda (e) - (and (tok? e) - (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL))) - e-raw)) - (define gc-var-stack-through-getspecific? - (ormap (lambda (e) - (and (tok? e) - (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC))) + (cond + [(and (pragma? e) + (regexp-match #rx"GC_VARIABLE_STACK_THOUGH_TABLE" (pragma-s e))) + 'table] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL)) + 'thread-local] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC)) + 'getspecific] + [(and (tok? e) + (eq? (tok-n e) 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION)) + 'function] + [else #f])) e-raw)) ;; The code produced by xform uses a number of macros. These macros @@ -608,12 +610,14 @@ (when (and pgc? (not precompiled-header)) ;; Setup GC_variable_stack macro - (printf (cond - [gc-var-stack-through-table? + (printf (case gc-var-stack-mode + [(table) "#define GC_VARIABLE_STACK (scheme_extension_table->GC_variable_stack)~n"] - [gc-var-stack-through-getspecific? + [(getspecific) "#define GC_VARIABLE_STACK (((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key))->GC_variable_stack_)~n"] - [gc-var-stack-through-thread-local? + [(function) + "#define GC_VARIABLE_STACK ((scheme_get_thread_local_variables())->GC_variable_stack_)~n"] + [(thread-local) "#define GC_VARIABLE_STACK ((&scheme_thread_locals)->GC_variable_stack_)~n"] [else "#define GC_VARIABLE_STACK GC_variable_stack~n"])) @@ -1075,8 +1079,7 @@ (set! non-gcing-functions (hash-table-copy (list-ref l 7))) - (set! gc-var-stack-through-thread-local? (list-ref l 8)) - (set! gc-var-stack-through-getspecific? (list-ref l 9)))))) + (set! gc-var-stack-mode (list-ref l 8)))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Pretty-printing output @@ -1611,6 +1614,7 @@ (define (threadlocal-decl? e) (and (pair? e) (or (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC (tok-n (car e))) + (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION (tok-n (car e))) (eq? 'XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL (tok-n (car e)))))) (define (access-modifier? e) @@ -4003,8 +4007,7 @@ (marshall non-pointer-types) (marshall struct-defs) non-gcing-functions - gc-var-stack-through-thread-local? - gc-var-stack-through-getspecific?)]) + (list 'quote gc-var-stack-mode))]) (with-output-to-file (change-suffix file-out #".zo") (lambda () (let ([orig (current-namespace)]) diff --git a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch index 048d6b00b9..24c0b04b7b 100644 --- a/collects/tests/mzscheme/benchmarks/common/nucleic2.sch +++ b/collects/tests/mzscheme/benchmarks/common/nucleic2.sch @@ -3756,4 +3756,4 @@ ; To run program, evaluate: (run) -(time (run)) +(time (let loop ([i 10]) (if (zero? i) 'done (begin (run) (loop (- i 1)))))) diff --git a/src/mzscheme/include/schthread.h b/src/mzscheme/include/schthread.h index 4408f74ce8..7d49a5552a 100644 --- a/src/mzscheme/include/schthread.h +++ b/src/mzscheme/include/schthread.h @@ -25,6 +25,9 @@ # define THREAD_LOCAL __declspec(thread) # elif defined(OS_X) # define IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS +# if defined(__x86_64__) || defined(__i386__) +# define INLINE_GETSPECIFIC_ASSEMBLY_CODE +# endif # else # define THREAD_LOCAL __thread # endif @@ -219,9 +222,29 @@ typedef struct Thread_Local_Variables { /* Using Pthread getspecific() */ # include MZ_EXTERN pthread_key_t scheme_thread_local_key; -# define scheme_get_thread_local_variables() ((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key)) -#ifdef MZ_XFORM +# ifndef INLINE_GETSPECIFIC_ASSEMBLY_CODE +# define scheme_get_thread_local_variables() ((Thread_Local_Variables *)pthread_getspecific(scheme_thread_local_key)) +# ifdef MZ_XFORM XFORM_GC_VARIABLE_STACK_THROUGH_GETSPECIFIC; +# endif +# else +# ifdef MZ_XFORM +START_XFORM_SKIP; +# endif +static inline Thread_Local_Variables *scheme_get_thread_local_variables() __attribute__((used)); +static inline Thread_Local_Variables *scheme_get_thread_local_variables() { + Thread_Local_Variables *x; +# if defined(__x86_64__) + asm volatile("movq %%gs:0x8A0, %0" : "=r"(x)); +# else + asm volatile("movl %%gs:0x468, %0" : "=r"(x)); +# endif + return x; +} +# ifdef MZ_XFORM +END_XFORM_SKIP; +XFORM_GC_VARIABLE_STACK_THROUGH_FUNCTION; +# endif # endif #else /* Using `THREAD_LOCAL' variable: */ diff --git a/src/mzscheme/main.c b/src/mzscheme/main.c index 41c3260aac..7ee244e0cb 100644 --- a/src/mzscheme/main.c +++ b/src/mzscheme/main.c @@ -248,6 +248,10 @@ typedef struct { MAIN_char **argv; } Main_Args; +# ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +# endif + static int main_after_dlls(int argc, MAIN_char **argv) { Main_Args ma; @@ -256,6 +260,10 @@ static int main_after_dlls(int argc, MAIN_char **argv) return scheme_main_stack_setup(1, main_after_stack, &ma); } +# ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +# endif + /************************ main_after_stack *************************/ /* Setup, parse command-line, and go to cont_run */ diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index a492d2f8d7..96f0315564 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -157,20 +157,11 @@ int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char return scheme_main_stack_setup(no_auto_statics, call_with_basic, &d); } -int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) +static int do_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) { void *stack_start; int volatile return_code; -#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS - if (pthread_key_create(&scheme_thread_local_key, NULL)) { - fprintf(stderr, "pthread key create failed"); - abort(); - } -#endif - - scheme_init_os_thread(); - #ifdef USE_THREAD_LOCAL scheme_vars = scheme_get_thread_local_variables(); #endif @@ -187,6 +178,65 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void return return_code; } +#ifdef MZ_PRECISE_GC +START_XFORM_SKIP; +#endif + +int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) +{ +#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS +# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE + /* Our [highly questionable] strategy for inlining pthread_getspecific() is taken from + the Go implementation (see "http://golang.org/src/libcgo/darwin_386.c"). + In brief, we assume that thread-local variables are going to be + accessed via the gs segment register at offset 0x48 (i386) or 0x60 (x86_64), + and we also hardwire the therad-local key 0x108. Here we have to try to get + that particular key and double-check that it worked. */ + pthread_key_t unwanted[16]; + int num_unwanted = 0; +# endif + + while (1) { + if (pthread_key_create(&scheme_thread_local_key, NULL)) { + fprintf(stderr, "pthread key create failed\n"); + abort(); + } +# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE + if (scheme_thread_local_key == 0x108) + break; + else { + if (num_unwanted == 16) { + fprintf(stderr, "pthread key create never produced 0x108 for inline hack\n"); + abort(); + } + unwanted[num_unwanted++] = scheme_thread_local_key; + } +# else + break; +# endif + } + +# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE + pthread_setspecific(scheme_thread_local_key, (void *)0xaced); + if (scheme_get_thread_local_variables() != (Thread_Local_Variables *)0xaced) { + fprintf(stderr, "pthread getspecific inline hack failed\n"); + abort(); + } + while (num_unwanted--) { + pthread_key_delete(unwanted[num_unwanted]); + } +# endif +#endif + + scheme_init_os_thread(); + + return do_main_stack_setup(no_auto_statics, _main, data); +} + +#ifdef MZ_PRECISE_GC +END_XFORM_SKIP; +#endif + void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics) { scheme_set_stack_base(base, no_auto_statics); @@ -243,14 +293,6 @@ void scheme_init_os_thread() vars = (Thread_Local_Variables *)malloc(sizeof(Thread_Local_Variables)); memset(vars, 0, sizeof(Thread_Local_Variables)); pthread_setspecific(scheme_thread_local_key, vars); -# ifdef OS_X - /* A hack that smehow avoids a problem with calling vm_allocate() - later. There must be some deeper bug that I have't found, yet. */ - if (1) { - void *r; - vm_allocate(mach_task_self(), (vm_address_t*)&r, 4096, TRUE); - } -# endif #endif #ifdef OS_X # ifdef MZ_PRECISE_GC From d4cbb3b9a747c6e4214c9e0159c69dbda1c4d902 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 02:58:59 +0000 Subject: [PATCH 40/92] fix future-creation record declaration for 3m svn: r16953 --- src/mzscheme/src/future.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 32d1f1b70d..29912b22a2 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -265,7 +265,7 @@ void futures_init(void) static void init_future_thread(Scheme_Future_State *fs, int i) { Scheme_Future_Thread_State *fts; - future_thread_params_t params; + GC_CAN_IGNORE future_thread_params_t params; pthread_t threadid; GC_CAN_IGNORE pthread_attr_t attr; From d94360ddfcff33f93e357fc12be29fa2dfd11a53 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Nov 2009 08:50:24 +0000 Subject: [PATCH 41/92] Welcome to a new PLT day. svn: r16955 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index d584585719..3f41985dcd 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "21nov2009") +#lang scheme/base (provide stamp) (define stamp "22nov2009") From 8a5c0e854aad199789064d7d0db2bf54793d1ddc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 15:27:07 +0000 Subject: [PATCH 42/92] fix dynext flags for Mac to include -m32 (merge to 4.2.3) svn: r16961 --- collects/dynext/compile-unit.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/dynext/compile-unit.ss b/collects/dynext/compile-unit.ss index ddc8783b7f..164c6baa7a 100644 --- a/collects/dynext/compile-unit.ss +++ b/collects/dynext/compile-unit.ss @@ -73,8 +73,8 @@ (define gcc-compile-flags (append '("-c" "-O2" "-fPIC") (case (string->symbol (path->string (system-library-subpath #f))) - [(ppc-macosx i386-macosx x86_64-macosx) '("-fno-common")] - [(ppc-darwin) '("-fno-common")] + [(i386-macosx i386-darwin) '("-m32" "-fno-common")] + [(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) '("-fno-common")] [(win32\\i386) '("-DAS_MSVC_EXTENSION")] [else null]) gcc-cpp-flags)) From 178d0f8e3495eec963fe1a1184156a3acca73223 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 15:31:18 +0000 Subject: [PATCH 43/92] fix problems with the embedded command-line length (merge to 4.2.3) svn: r16962 --- collects/compiler/embed-unit.ss | 8 +++++--- src/mzscheme/cmdline.inc | 4 +++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/collects/compiler/embed-unit.ss b/collects/compiler/embed-unit.ss index 42e954021b..e0d4f7efa6 100644 --- a/collects/compiler/embed-unit.ss +++ b/collects/compiler/embed-unit.ss @@ -1008,10 +1008,12 @@ mac-mred-collects-path-adjust values) collects-path))) + (define word-size (if (fixnum? (expt 2 32)) 8 4)) (unless (or long-cmdline? - ((apply + (length cmdline) (map (lambda (s) - (bytes-length (string->bytes/utf-8 s))) - cmdline)) . < . 50)) + ((apply + + (map (lambda (s) + (+ word-size (bytes-length (string->bytes/utf-8 s)))) + cmdline)) . < . 60)) (error 'create-embedding-executable "command line too long")) (check-collects-path 'create-embedding-executable collects-path collects-path-bytes) (let ([exe (find-exe mred? variant)]) diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc index 2c4e4dfe1d..9194656ae0 100644 --- a/src/mzscheme/cmdline.inc +++ b/src/mzscheme/cmdline.inc @@ -5,7 +5,9 @@ #define SDESC "Set! works on undefined identifiers" -char *cmdline_exe_hack = "[Replace me for EXE hack ]"; +char *cmdline_exe_hack = + ("[Replace me for EXE hack " + " ]"); #ifdef MZ_PRECISE_GC # define GC_PRECISION_TYPE "3" From 47c66b71eb0bb85552fe8a07f1ccef42927b9899 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 15:43:15 +0000 Subject: [PATCH 44/92] fix pasteboard% 'remove' (merge to 4.2.3) svn: r16963 --- collects/mred/private/wxme/pasteboard.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index b2755831ee..00d84ef3e7 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -770,7 +770,7 @@ (snip-set-admin del-snip #f) (set-snip-flags! del-snip (remove-flag (snip->flags del-snip) CAN-DISOWN)) (unless del - (when (send del-snip get-admin) + (unless (send del-snip get-admin) (set-snip-flags! del-snip (remove-flag (snip->flags del-snip) OWNED)))) (unless s-modified? From 6cce258a7fac2042a2ae5180bc2f4c322377dcec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 19:52:13 +0000 Subject: [PATCH 45/92] update release notes for v4.2.3 (merge to v4.2.3) svn: r16964 --- doc/release-notes/mred/HISTORY.txt | 6 ++++++ doc/release-notes/mzscheme/HISTORY.txt | 5 +++++ 2 files changed, 11 insertions(+) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index cd3c6ea544..4675ac45d7 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,3 +1,9 @@ +Version 4.2.3, November 2009 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 4.2.2, September 2009 Minor bug fixes diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 925bea770d..1c35a4436d 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,8 @@ +Version 4.2.3, November 2009 +Changed _pointer (in scheme/foreign) to mean a pointer that does not + refer to GCable memory; added _gcpointer +Added scheme/vector + Version 4.2.2, September 2009 Added scheme/unsafe/ops Added print-syntax-width From 6395be334796d55b018171552e71c0abfbfd8955 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 20:26:21 +0000 Subject: [PATCH 46/92] work around GL drawing problem that appears in Snow Leopard (merge to 4.2.3) svn: r16966 --- collects/games/jewel/jewel.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/games/jewel/jewel.scm b/collects/games/jewel/jewel.scm index 3caf466e3c..b976b0d3c2 100644 --- a/collects/games/jewel/jewel.scm +++ b/collects/games/jewel/jewel.scm @@ -1431,7 +1431,12 @@ (counter 0) ) - + + ;; This shouldnt do anything, but it fixes drawing in + ;; Snow Leopard. Bug in the game or in Snow Leopard? + (glEnable GL_LIGHT2) + (glDisable GL_LIGHT2) + (glEnable GL_BLEND) (do ((iy 0 (+ iy 1))) ((= iy ey)) (set! x (* (- t) (- (/ ex 2.0) 0.5))) @@ -1461,7 +1466,7 @@ (set! xt nx) (set! yt ny) (set! zt nz) - + (if (and (equal? gamestate 'PLAYING) (= cposx ix) (= cposy iy)) (begin From 78578a3eabe557b608f385c03b975f7b1f647062 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Nov 2009 23:30:21 +0000 Subject: [PATCH 47/92] convert START_XFORM_SKIP...END_XFORM_SKIP mostly to XFORM_SKIP_PROC svn: r16972 --- collects/compiler/private/xform.ss | 81 ++++---- collects/scribblings/inside/memory.scrbl | 11 ++ src/mzscheme/include/scheme.h | 1 + src/mzscheme/src/bignum.c | 10 +- src/mzscheme/src/complex.c | 9 +- src/mzscheme/src/dynext.c | 9 +- src/mzscheme/src/fun.c | 20 +- src/mzscheme/src/future.c | 23 +-- src/mzscheme/src/gen-jit-ts.ss | 6 +- src/mzscheme/src/jit.c | 41 +--- src/mzscheme/src/jit_ts_def.c | 60 ++---- src/mzscheme/src/jit_ts_future_glue.c | 60 ++---- src/mzscheme/src/jit_ts_glue.c | 240 ----------------------- src/mzscheme/src/network.c | 18 +- src/mzscheme/src/numcomp.c | 9 +- src/mzscheme/src/port.c | 120 +++--------- src/mzscheme/src/print.c | 9 +- src/mzscheme/src/rational.c | 10 +- src/mzscheme/src/salloc.c | 28 +-- src/mzscheme/src/setjmpup.c | 5 +- src/mzscheme/src/thread.c | 30 +-- 21 files changed, 165 insertions(+), 635 deletions(-) delete mode 100644 src/mzscheme/src/jit_ts_glue.c diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index 8ef3191e48..190ad51e5c 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -730,6 +730,7 @@ (printf "#define XFORM_END_SKIP /**/~n") (printf "#define XFORM_START_SUSPEND /**/~n") (printf "#define XFORM_END_SUSPEND /**/~n") + (printf "#define XFORM_SKIP_PROC /**/~n") ;; For avoiding warnings: (printf "#define XFORM_OK_PLUS +~n") (printf "#define XFORM_OK_MINUS -~n") @@ -1522,43 +1523,45 @@ null e))))] [(function? e) - (let ([name (register-proto-information e)]) - (when (eq? (tok-n (car e)) '__xform_nongcing__) - (hash-table-put! non-gcing-functions name #t)) - (when show-info? (printf "/* FUNCTION ~a */~n" name)) - (if (or (positive? suspend-xform) - (not pgc?) - (and where - (regexp-match re:h where) - (let loop ([e e][prev #f]) - (cond - [(null? e) #t] - [(and (eq? '|::| (tok-n (car e))) - prev - (eq? (tok-n prev) (tok-n (cadr e)))) - ;; inline constructor: need to convert - #f] - [else (loop (cdr e) (car e))])))) - ;; Not pgc, xform suspended, - ;; or still in headers and probably a simple inlined function - (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))]) - (when palm? - (fprintf map-port "(~aimpl ~s)~n" - (if palm-static? "s" "") - name) - (call-graph name e)) - (append - (if palm-static? - ;; Need to make sure prototype is there for section - (add-segment-label - name - (let loop ([e e]) - (if (braces? (car e)) - (list (make-tok semi #f #f)) - (cons (car e) (loop (cdr e)))))) - null) - e)) - (convert-function e name)))] + (if (skip-function? e) + e + (let ([name (register-proto-information e)]) + (when (eq? (tok-n (car e)) '__xform_nongcing__) + (hash-table-put! non-gcing-functions name #t)) + (when show-info? (printf "/* FUNCTION ~a */~n" name)) + (if (or (positive? suspend-xform) + (not pgc?) + (and where + (regexp-match re:h where) + (let loop ([e e][prev #f]) + (cond + [(null? e) #t] + [(and (eq? '|::| (tok-n (car e))) + prev + (eq? (tok-n prev) (tok-n (cadr e)))) + ;; inline constructor: need to convert + #f] + [else (loop (cdr e) (car e))])))) + ;; Not pgc, xform suspended, + ;; or still in headers and probably a simple inlined function + (let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))]) + (when palm? + (fprintf map-port "(~aimpl ~s)~n" + (if palm-static? "s" "") + name) + (call-graph name e)) + (append + (if palm-static? + ;; Need to make sure prototype is there for section + (add-segment-label + name + (let loop ([e e]) + (if (braces? (car e)) + (list (make-tok semi #f #f)) + (cons (car e) (loop (cdr e)))))) + null) + e)) + (convert-function e name))))] [(var-decl? e) (when show-info? (printf "/* VAR */~n")) (if (and can-drop-vars? @@ -1709,12 +1712,16 @@ (and (braces? v) (let ([v (list-ref e (sub1 ll))]) (or (parens? v) + (eq? (tok-n v) 'XFORM_SKIP_PROC) ;; `const' can appear between the arg parens ;; and the function body; this happens in the ;; OS X headers (and (eq? 'const (tok-n v)) (positive? (sub1 ll)) (parens? (list-ref e (- ll 2)))))))))))) + + (define (skip-function? e) + (ormap (lambda (v) (eq? (tok-n v) 'XFORM_SKIP_PROC)) e)) ;; Recognize a top-level variable declaration: (define (var-decl? e) diff --git a/collects/scribblings/inside/memory.scrbl b/collects/scribblings/inside/memory.scrbl index d5e174b8dc..ff53885768 100644 --- a/collects/scribblings/inside/memory.scrbl +++ b/collects/scribblings/inside/memory.scrbl @@ -550,6 +550,17 @@ The following macros can be used (with care!) to navigate MZ_PRECISE_GC} and @cpp{#endif}; a semi-colon by itself at the top level is not legal in C.} +@item{@cppdef{XFORM_SKIP_PROC}: annotate a function so that its body + is skipped in the same way as bracketing it with + @cpp{XFORM_START_SKIP} and @cpp{XFORM_END_SKIP}. + + Example: + + @verbatim[#:indent 2]{ + int foo(int c, ...) XFORM_END_SKIP { + } + }} + @item{@cppdef{XFORM_HIDE_EXPR}: a macro that takes wraps an expression to disable processing of the expression. diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 909b573f31..891b1c4caa 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1658,6 +1658,7 @@ extern void *scheme_malloc_envunbox(size_t); # define XFORM_END_SKIP /**/ # define XFORM_START_SUSPEND /**/ # define XFORM_END_SUSPEND /**/ +# define XFORM_SKIP_PROC /**/ # define XFORM_START_TRUST_ARITH /**/ # define XFORM_END_TRUST_ARITH /**/ # define XFORM_CAN_IGNORE /**/ diff --git a/src/mzscheme/src/bignum.c b/src/mzscheme/src/bignum.c index be985853a6..d2fb94dbd3 100644 --- a/src/mzscheme/src/bignum.c +++ b/src/mzscheme/src/bignum.c @@ -174,14 +174,10 @@ void scheme_clear_bignum_cache(void) void scheme_clear_bignum_cache(void) { } #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - - #define xor(a, b) (!(a) ^ !(b)) Scheme_Object *scheme_make_small_bignum(long v, Small_Bignum *o) + XFORM_SKIP_PROC { bigdig bv; @@ -208,10 +204,6 @@ Scheme_Object *scheme_make_small_bignum(long v, Small_Bignum *o) return (Scheme_Object *) mzALIAS o; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - Scheme_Object *scheme_make_bignum(long v) { Small_Bignum *r; diff --git a/src/mzscheme/src/complex.c b/src/mzscheme/src/complex.c index 0a74a59410..5eb359e88b 100644 --- a/src/mzscheme/src/complex.c +++ b/src/mzscheme/src/complex.c @@ -56,11 +56,8 @@ Scheme_Object *scheme_real_to_complex(const Scheme_Object *n) return make_complex(n, zero, 0); } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Object *scheme_make_small_complex(const Scheme_Object *n, Small_Complex *s) + XFORM_SKIP_PROC { s->so.type = scheme_complex_type; s->r = (Scheme_Object *)n; @@ -69,10 +66,6 @@ Scheme_Object *scheme_make_small_complex(const Scheme_Object *n, Small_Complex * return (Scheme_Object *)s; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - int scheme_is_complex_exact(const Scheme_Object *o) { Scheme_Complex *c = (Scheme_Complex *)o; diff --git a/src/mzscheme/src/dynext.c b/src/mzscheme/src/dynext.c index e38417d32c..5cb994113b 100644 --- a/src/mzscheme/src/dynext.c +++ b/src/mzscheme/src/dynext.c @@ -463,19 +463,12 @@ static Scheme_Object *do_load_extension(const char *filename, #endif } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_register_extension_global(void *ptr, long size) + XFORM_SKIP_PROC { GC_add_roots((char *)ptr, (char *)(((char *)ptr) + size + 1)); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static Scheme_Object *load_extension(int argc, Scheme_Object **argv) { return scheme_load_with_clrd(argc, argv, "load-extension", MZCONFIG_LOAD_EXTENSION_HANDLER); diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 5dfc190be8..6354dbaeb0 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -7945,11 +7945,9 @@ void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_de #define CLOCKS_PER_SEC 1000000 #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - long scheme_get_milliseconds(void) + XFORM_SKIP_PROC +/* this function can be called from any OS thread */ { #ifdef USE_MACTIME return scheme_get_process_milliseconds(); @@ -7971,10 +7969,8 @@ long scheme_get_milliseconds(void) #endif } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif double scheme_get_inexact_milliseconds(void) + XFORM_SKIP_PROC /* this function can be called from any OS thread */ { #ifdef USE_MACTIME @@ -8002,12 +7998,9 @@ double scheme_get_inexact_milliseconds(void) # endif #endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - long scheme_get_process_milliseconds(void) + XFORM_SKIP_PROC { #ifdef USER_TIME_IS_CLOCK return scheme_get_milliseconds(); @@ -8051,6 +8044,7 @@ long scheme_get_process_milliseconds(void) } long scheme_get_thread_milliseconds(Scheme_Object *thrd) + XFORM_SKIP_PROC { Scheme_Thread *t = thrd ? (Scheme_Thread *)thrd : scheme_current_thread; @@ -8063,10 +8057,6 @@ long scheme_get_thread_milliseconds(Scheme_Object *thrd) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - long scheme_get_seconds(void) { #ifdef USE_MACTIME diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 29912b22a2..1e99450f02 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -485,10 +485,9 @@ int future_ready(Scheme_Object *obj) } static void dequeue_future(Scheme_Future_State *fs, future_t *ft) + XFORM_SKIP_PROC /* called from both future and runtime threads */ { - START_XFORM_SKIP; - if (ft->prev == NULL) fs->future_queue = ft->next; else @@ -503,8 +502,6 @@ static void dequeue_future(Scheme_Future_State *fs, future_t *ft) ft->prev = NULL; --fs->future_queue_count; - - END_XFORM_SKIP; } Scheme_Object *touch(int argc, Scheme_Object *argv[]) @@ -619,10 +616,10 @@ Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) //executing futures. This function will never terminate //(until the process dies). void *worker_thread_future_loop(void *arg) + XFORM_SKIP_PROC /* Called in future thread; runtime thread is blocked until ready_sema is signaled. */ { - START_XFORM_SKIP; /* valid only until signaling */ future_thread_params_t *params = (future_thread_params_t *)arg; Scheme_Future_Thread_State *fts = params->fts; @@ -742,7 +739,6 @@ void *worker_thread_future_loop(void *arg) goto wait_for_work; return NULL; - END_XFORM_SKIP; } void scheme_check_future_work() @@ -783,9 +779,9 @@ void scheme_check_future_work() static void future_do_runtimecall(Scheme_Future_Thread_State *fts, void *func, int is_atomic) + XFORM_SKIP_PROC /* Called in future thread */ { - START_XFORM_SKIP; future_t *future; Scheme_Future_State *fs = scheme_future_state; @@ -829,8 +825,6 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts, future->no_retval = 0; scheme_future_longjmp(*scheme_current_thread->error_buf, 1); } - - END_XFORM_SKIP; } @@ -838,9 +832,9 @@ static void future_do_runtimecall(Scheme_Future_Thread_State *fts, /* 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 /* Called in future thread */ { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future = fts->current_ft; @@ -855,14 +849,12 @@ void scheme_rtcall_void_void_3args(const char *who, int src_type, prim_void_void future_do_runtimecall(fts, (void*)f, 1); future->arg_S0 = NULL; - - END_XFORM_SKIP; } unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim_alloc_void_pvoid_t f) + XFORM_SKIP_PROC /* Called in future thread */ { - START_XFORM_SKIP; future_t *future; unsigned long retval; Scheme_Future_Thread_State *fts = scheme_future_thread_state; @@ -887,10 +879,10 @@ unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim } return retval; - END_XFORM_SKIP; } static void receive_special_result(future_t *f, Scheme_Object *retval) + XFORM_SKIP_PROC /* Called in future thread */ { if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { @@ -1041,9 +1033,9 @@ future_t *enqueue_future(Scheme_Future_State *fs, future_t *ft) } future_t *get_pending_future(Scheme_Future_State *fs) + XFORM_SKIP_PROC /* Called in future thread */ { - START_XFORM_SKIP; future_t *f; for (f = fs->future_queue; f != NULL; f = f->next) { @@ -1052,7 +1044,6 @@ future_t *get_pending_future(Scheme_Future_State *fs) } return NULL; - END_XFORM_SKIP; } /**********************************************************************/ diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss index e1d2fd5542..e6a2f7eec9 100644 --- a/src/mzscheme/src/gen-jit-ts.ss +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -41,13 +41,12 @@ (for-each display @list{#define define_ts_@|ts|(id, src_type) \ static @|result-type| ts_ ## id(@|args|) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ @|return| scheme_rtcall_@|t|("[" #id "]", src_type, id, @(string-join arg-names ", ")); \ else \ @|return| id(@(string-join arg-names ", ")); \ - END_XFORM_SKIP; \ }}) (newline)) @@ -62,8 +61,8 @@ display @list{ @|result-type| scheme_rtcall_@|ts|(const char *who, int src_type, prim_@|ts| f@|(if (null? arg-types) "" ",")| @|args|) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -88,7 +87,6 @@ @(if (string=? result-type "void") "" @string-append{@|fretval| = 0;}) @(if (string=? result-type "Scheme_Object*") @string-append{receive_special_result(future, retval);} "") @(if (string=? result-type "void") "" "return retval;") - END_XFORM_SKIP; } }) (newline)) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 6af88e813c..507b136694 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -298,13 +298,7 @@ void scheme_jit_fill_threadlocal_table(); # define tl_scheme_future_need_gc_pause tl_delta(scheme_future_need_gc_pause) # define tl_scheme_use_rtcall tl_delta(scheme_use_rtcall) -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif -static void *get_threadlocal_table() { return &BOTTOM_VARIABLE; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif +static void *get_threadlocal_table() XFORM_SKIP_PROC { return &BOTTOM_VARIABLE; } # ifdef JIT_X86_64 # define JIT_R10 JIT_R(10) @@ -2216,10 +2210,9 @@ extern int g_print_prims; mz_patch_ucbranch(refcont); \ __END_TINY_JUMPS__(1); \ } -static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) +static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) + XFORM_SKIP_PROC { - START_XFORM_SKIP; - if (scheme_use_rtcall) return scheme_rtcall_iS_s("[prim_indirect]", FSRC_PRIM, @@ -2228,39 +2221,31 @@ static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) MZ_RUNSTACK); else return proc(argc, MZ_RUNSTACK); - - END_XFORM_SKIP; } -static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self) +static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self) + XFORM_SKIP_PROC { - START_XFORM_SKIP; - if (scheme_use_rtcall) return scheme_rtcall_iSs_s("[prim_indirect]", FSRC_PRIM, proc, argc, MZ_RUNSTACK, self); else return proc(argc, MZ_RUNSTACK, self); - - END_XFORM_SKIP; } /* Various specific 'futurized' versions of primitives that may be invoked directly from JIT code and are not considered thread-safe (are not invoked via apply_multi_from_native, etc.) */ -static void ts_on_demand(void) +static void ts_on_demand(void) XFORM_SKIP_PROC { - START_XFORM_SKIP; if (scheme_use_rtcall) { scheme_rtcall_void_void_3args("[jit_on_demand]", FSRC_OTHER, on_demand_with_args); } else on_demand(); - END_XFORM_SKIP; } #ifdef MZ_PRECISE_GC -static void *ts_prepare_retry_alloc(void *p, void *p2) +static void *ts_prepare_retry_alloc(void *p, void *p2) XFORM_SKIP_PROC { - START_XFORM_SKIP; unsigned long ret; if (scheme_use_rtcall) { @@ -2277,7 +2262,6 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) ret = prepare_retry_alloc(p, p2); return ret; - END_XFORM_SKIP; } #endif #else @@ -10316,11 +10300,8 @@ void scheme_dump_stack_trace(void) } #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_flush_stack_cache() + XFORM_SKIP_PROC { void **p; @@ -10332,6 +10313,7 @@ void scheme_flush_stack_cache() } void scheme_jit_longjmp(mz_jit_jmp_buf b, int v) + XFORM_SKIP_PROC { unsigned long limit; void **p; @@ -10350,16 +10332,13 @@ void scheme_jit_longjmp(mz_jit_jmp_buf b, int v) } void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b) + XFORM_SKIP_PROC { void *p; p = &p; b->stack_frame = (unsigned long)p; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void scheme_clean_native_symtab(void) { #ifndef MZ_PRECISE_GC diff --git a/src/mzscheme/src/jit_ts_def.c b/src/mzscheme/src/jit_ts_def.c index 9dfc76623b..2f09ee2d9f 100644 --- a/src/mzscheme/src/jit_ts_def.c +++ b/src/mzscheme/src/jit_ts_def.c @@ -1,200 +1,180 @@ #define define_ts_siS_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g7, int g8, Scheme_Object** g9) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_siS_s("[" #id "]", src_type, id, g7, g8, g9); \ else \ return id(g7, g8, g9); \ - END_XFORM_SKIP; \ } #define define_ts_iSs_s(id, src_type) \ static Scheme_Object* ts_ ## id(int g10, Scheme_Object** g11, Scheme_Object* g12) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_iSs_s("[" #id "]", src_type, id, g10, g11, g12); \ else \ return id(g10, g11, g12); \ - END_XFORM_SKIP; \ } #define define_ts_s_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g13) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_s_s("[" #id "]", src_type, id, g13); \ else \ return id(g13); \ - END_XFORM_SKIP; \ } #define define_ts_n_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Native_Closure_Data* g14) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_n_s("[" #id "]", src_type, id, g14); \ else \ return id(g14); \ - END_XFORM_SKIP; \ } #define define_ts__s(id, src_type) \ static Scheme_Object* ts_ ## id() \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall__s("[" #id "]", src_type, id, ); \ else \ return id(); \ - END_XFORM_SKIP; \ } #define define_ts_ss_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g15, Scheme_Object* g16) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_ss_s("[" #id "]", src_type, id, g15, g16); \ else \ return id(g15, g16); \ - END_XFORM_SKIP; \ } #define define_ts_ss_m(id, src_type) \ static MZ_MARK_STACK_TYPE ts_ ## id(Scheme_Object* g17, Scheme_Object* g18) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_ss_m("[" #id "]", src_type, id, g17, g18); \ else \ return id(g17, g18); \ - END_XFORM_SKIP; \ } #define define_ts_Sl_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object** g19, long g20) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_Sl_s("[" #id "]", src_type, id, g19, g20); \ else \ return id(g19, g20); \ - END_XFORM_SKIP; \ } #define define_ts_l_s(id, src_type) \ static Scheme_Object* ts_ ## id(long g21) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_l_s("[" #id "]", src_type, id, g21); \ else \ return id(g21); \ - END_XFORM_SKIP; \ } #define define_ts_bsi_v(id, src_type) \ static void ts_ ## id(Scheme_Bucket* g22, Scheme_Object* g23, int g24) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ scheme_rtcall_bsi_v("[" #id "]", src_type, id, g22, g23, g24); \ else \ id(g22, g23, g24); \ - END_XFORM_SKIP; \ } #define define_ts_iiS_v(id, src_type) \ static void ts_ ## id(int g25, int g26, Scheme_Object** g27) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ scheme_rtcall_iiS_v("[" #id "]", src_type, id, g25, g26, g27); \ else \ id(g25, g26, g27); \ - END_XFORM_SKIP; \ } #define define_ts_ss_v(id, src_type) \ static void ts_ ## id(Scheme_Object* g28, Scheme_Object* g29) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ scheme_rtcall_ss_v("[" #id "]", src_type, id, g28, g29); \ else \ id(g28, g29); \ - END_XFORM_SKIP; \ } #define define_ts_b_v(id, src_type) \ static void ts_ ## id(Scheme_Bucket* g30) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ scheme_rtcall_b_v("[" #id "]", src_type, id, g30); \ else \ id(g30); \ - END_XFORM_SKIP; \ } #define define_ts_sl_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object* g31, long g32) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_sl_s("[" #id "]", src_type, id, g31, g32); \ else \ return id(g31, g32); \ - END_XFORM_SKIP; \ } #define define_ts_iS_s(id, src_type) \ static Scheme_Object* ts_ ## id(int g33, Scheme_Object** g34) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_iS_s("[" #id "]", src_type, id, g33, g34); \ else \ return id(g33, g34); \ - END_XFORM_SKIP; \ } #define define_ts_S_s(id, src_type) \ static Scheme_Object* ts_ ## id(Scheme_Object** g35) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_S_s("[" #id "]", src_type, id, g35); \ else \ return id(g35); \ - END_XFORM_SKIP; \ } #define define_ts_s_v(id, src_type) \ static void ts_ ## id(Scheme_Object* g36) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ scheme_rtcall_s_v("[" #id "]", src_type, id, g36); \ else \ id(g36); \ - END_XFORM_SKIP; \ } #define define_ts_iSi_s(id, src_type) \ static Scheme_Object* ts_ ## id(int g37, Scheme_Object** g38, int g39) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_iSi_s("[" #id "]", src_type, id, g37, g38, g39); \ else \ return id(g37, g38, g39); \ - END_XFORM_SKIP; \ } #define define_ts_siS_v(id, src_type) \ static void ts_ ## id(Scheme_Object* g40, int g41, Scheme_Object** g42) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ scheme_rtcall_siS_v("[" #id "]", src_type, id, g40, g41, g42); \ else \ id(g40, g41, g42); \ - END_XFORM_SKIP; \ } #define define_ts_z_p(id, src_type) \ static void* ts_ ## id(size_t g43) \ + XFORM_SKIP_PROC \ { \ - START_XFORM_SKIP; \ if (scheme_use_rtcall) \ return scheme_rtcall_z_p("[" #id "]", src_type, id, g43); \ else \ return id(g43); \ - END_XFORM_SKIP; \ } diff --git a/src/mzscheme/src/jit_ts_future_glue.c b/src/mzscheme/src/jit_ts_future_glue.c index 3c7177bca9..0964d32c8e 100644 --- a/src/mzscheme/src/jit_ts_future_glue.c +++ b/src/mzscheme/src/jit_ts_future_glue.c @@ -1,6 +1,6 @@ Scheme_Object* scheme_rtcall_siS_s(const char *who, int src_type, prim_siS_s f, Scheme_Object* g44, int g45, Scheme_Object** g46) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -22,11 +22,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -48,11 +47,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g50) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -72,11 +70,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g51) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -96,11 +93,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -120,11 +116,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -145,11 +140,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -170,11 +164,10 @@ future->retval_m = 0; return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_Sl_s(const char *who, int src_type, prim_Sl_s f, Scheme_Object** g56, long g57) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -195,11 +188,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g58) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -219,11 +211,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -245,11 +236,10 @@ - END_XFORM_SKIP; } void scheme_rtcall_iiS_v(const char *who, int src_type, prim_iiS_v f, int g62, int g63, Scheme_Object** g64) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -271,11 +261,10 @@ - END_XFORM_SKIP; } void scheme_rtcall_ss_v(const char *who, int src_type, prim_ss_v f, Scheme_Object* g65, Scheme_Object* g66) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -296,11 +285,10 @@ - END_XFORM_SKIP; } void scheme_rtcall_b_v(const char *who, int src_type, prim_b_v f, Scheme_Bucket* g67) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -320,11 +308,10 @@ - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_sl_s(const char *who, int src_type, prim_sl_s f, Scheme_Object* g68, long g69) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -345,11 +332,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g70, Scheme_Object** g71) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -370,11 +356,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g72) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -394,11 +379,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g73) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -418,11 +402,10 @@ - END_XFORM_SKIP; } Scheme_Object* scheme_rtcall_iSi_s(const char *who, int src_type, prim_iSi_s f, int g74, Scheme_Object** g75, int g76) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -444,11 +427,10 @@ future->retval_s = 0; receive_special_result(future, retval); return retval; - END_XFORM_SKIP; } void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -470,11 +452,10 @@ - END_XFORM_SKIP; } void* scheme_rtcall_z_p(const char *who, int src_type, prim_z_p f, size_t g80) + XFORM_SKIP_PROC { - START_XFORM_SKIP; Scheme_Future_Thread_State *fts = scheme_future_thread_state; future_t *future; double tm; @@ -494,5 +475,4 @@ future->retval_p = 0; return retval; - END_XFORM_SKIP; } diff --git a/src/mzscheme/src/jit_ts_glue.c b/src/mzscheme/src/jit_ts_glue.c deleted file mode 100644 index 8c9bc4b6a1..0000000000 --- a/src/mzscheme/src/jit_ts_glue.c +++ /dev/null @@ -1,240 +0,0 @@ - Scheme_Object* rtcall_siS_s(prim_siS_s f, Scheme_Object* g37, int g38, Scheme_Object** g39) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_s0 = g37; - future->arg_i1 = g38; - future->arg_S2 = g39; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_s_s(prim_s_s f, Scheme_Object* g40) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_s0 = g40; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall__s(prim__s f, ) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_ss_s(prim_ss_s f, Scheme_Object* g41, Scheme_Object* g42) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_s0 = g41; - future->arg_s1 = g42; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_lS_s(prim_lS_s f, long g43, Scheme_Object** g44) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_l0 = g43; - future->arg_S1 = g44; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_l_s(prim_l_s f, long g45) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_l0 = g45; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} void rtcall_bsi_v(prim_bsi_v f, Scheme_Bucket* g46, Scheme_Object* g47, int g48) -{ - START_XFORM_SKIP; - future_t *future; - void retval; - - future = current_ft; - future->arg_b0 = g46; - future->arg_s1 = g47; - future->arg_i2 = g48; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_v; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_s_s(prim_s_s f, Scheme_Object* g49) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_s0 = g49; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} void rtcall_iiS_v(prim_iiS_v f, int g50, int g51, Scheme_Object** g52) -{ - START_XFORM_SKIP; - future_t *future; - void retval; - - future = current_ft; - future->arg_i0 = g50; - future->arg_i1 = g51; - future->arg_S2 = g52; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_v; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} void rtcall_ss_v(prim_ss_v f, Scheme_Object* g53, Scheme_Object* g54) -{ - START_XFORM_SKIP; - future_t *future; - void retval; - - future = current_ft; - future->arg_s0 = g53; - future->arg_s1 = g54; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_v; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} void rtcall_b_v(prim_b_v f, Scheme_Bucket* g55) -{ - START_XFORM_SKIP; - future_t *future; - void retval; - - future = current_ft; - future->arg_b0 = g55; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_v; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_sl_s(prim_sl_s f, Scheme_Object* g56, long g57) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_s0 = g56; - future->arg_l1 = g57; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_iS_s(prim_iS_s f, int g58, Scheme_Object** g59) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_i0 = g58; - future->arg_S1 = g59; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} void rtcall_s_v(prim_s_v f, Scheme_Object* g60) -{ - START_XFORM_SKIP; - future_t *future; - void retval; - - future = current_ft; - future->arg_s0 = g60; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_v; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} Scheme_Object* rtcall_iSi_s(prim_iSi_s f, int g61, Scheme_Object** g62, int g63) -{ - START_XFORM_SKIP; - future_t *future; - Scheme_Object* retval; - - future = current_ft; - future->arg_i0 = g61; - future->arg_S1 = g62; - future->arg_i2 = g63; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_s; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} void rtcall_siS_v(prim_siS_v f, Scheme_Object* g64, int g65, Scheme_Object** g66) -{ - START_XFORM_SKIP; - future_t *future; - void retval; - - future = current_ft; - future->arg_s0 = g64; - future->arg_i1 = g65; - future->arg_S2 = g66; - future_do_runtimecall((void*)f, 0, NULL); - future = current_ft; - retval = future->retval_v; - future->prim_data.retval = NULL; - return retval; - END_XFORM_SKIP; -} \ No newline at end of file diff --git a/src/mzscheme/src/network.c b/src/mzscheme/src/network.c index eaafaec2ac..30205f60f7 100644 --- a/src/mzscheme/src/network.c +++ b/src/mzscheme/src/network.c @@ -338,11 +338,9 @@ static struct protoent *proto; # define mz_gai_strerror gai_strerror #else # define mzAI_PASSIVE 0 -# ifdef MZ_XFORM -START_XFORM_SKIP; -# endif static int mz_getaddrinfo(const char *nodename, const char *servname, const struct mz_addrinfo *hints, struct mz_addrinfo **res) + XFORM_SKIP_PROC { struct hostent *h; @@ -386,17 +384,16 @@ static int mz_getaddrinfo(const char *nodename, const char *servname, return h_errno; } void mz_freeaddrinfo(struct mz_addrinfo *ai) + XFORM_SKIP_PROC { free(ai->ai_addr); free(ai); } const char *mz_gai_strerror(int ecode) + XFORM_SKIP_PROC { return hstrerror(ecode); } -# ifdef MZ_XFORM -END_XFORM_SKIP; -# endif #endif #if defined(USE_WINSOCK_TCP) || defined(PTHREADS_OK_FOR_GHBN) @@ -441,11 +438,8 @@ HANDLE ready_sema; int ready_fd; # endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long getaddrinfo_in_thread(void *data) + XFORM_SKIP_PROC { int ok; struct mz_addrinfo *res, hints; @@ -487,10 +481,6 @@ static long getaddrinfo_in_thread(void *data) return 1; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static void release_ghbn_lock(GHBN_Rec *rec) { ghbn_lock = 0; diff --git a/src/mzscheme/src/numcomp.c b/src/mzscheme/src/numcomp.c index 48744b9129..6e678070d6 100644 --- a/src/mzscheme/src/numcomp.c +++ b/src/mzscheme/src/numcomp.c @@ -150,11 +150,8 @@ void scheme_init_unsafe_numcomp(Scheme_Env *env) /* Prototype needed for 3m conversion: */ static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr); -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr) + XFORM_SKIP_PROC { Scheme_Type t = SCHEME_TYPE(n); if (t == scheme_rational_type) @@ -163,10 +160,6 @@ static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr) return scheme_make_small_bn_rational(n, sr); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - GEN_NARY_COMP(eq, "=", scheme_bin_eq, SCHEME_NUMBERP, "number") GEN_NARY_COMP(lt, "<", scheme_bin_lt, SCHEME_REALP, REAL_NUMBER_STR) GEN_NARY_COMP(gt, ">", scheme_bin_gt, SCHEME_REALP, REAL_NUMBER_STR) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 35bfb7f79e..be14d99b34 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -206,11 +206,8 @@ static int *malloc_refcount() return (int *)malloc(sizeof(int)); } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static int dec_refcount(int *refcount) + XFORM_SKIP_PROC { int rc; @@ -227,10 +224,6 @@ static int dec_refcount(int *refcount) return rc; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #else static int *malloc_refcount() @@ -693,11 +686,8 @@ static int dynamic_fd_size; # define STORED_ACTUAL_FDSET_LIMIT # define FDSET_LIMIT(fd) (*(int *)((char *)fd XFORM_OK_PLUS dynamic_fd_size)) -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void *scheme_alloc_fdset_array(int count, int permanent) + XFORM_SKIP_PROC { /* Note: alloc only at the end, because this function isn't annotated. We skip annotation so that it's @@ -722,10 +712,6 @@ void *scheme_alloc_fdset_array(int count, int permanent) return scheme_malloc_atomic(count * (dynamic_fd_size + sizeof(long))); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void *scheme_init_fdset_array(void *fdarray, int count) { return fdarray; @@ -1184,11 +1170,8 @@ void scheme_remember_subthread(struct Scheme_Thread_Memory *tm, void *t) tm->subhandle = t; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_forget_thread(struct Scheme_Thread_Memory *tm) + XFORM_SKIP_PROC { if (tm->prev) tm->prev->next = tm->next; @@ -1207,11 +1190,13 @@ void scheme_forget_thread(struct Scheme_Thread_Memory *tm) } void scheme_forget_subthread(struct Scheme_Thread_Memory *tm) + XFORM_SKIP_PROC { tm->subhandle = NULL; } void scheme_suspend_remembered_threads(void) + XFORM_SKIP_PROC { Scheme_Thread_Memory *tm, *next, *prev = NULL; int keep; @@ -1249,6 +1234,7 @@ void scheme_suspend_remembered_threads(void) } void scheme_resume_remembered_threads(void) + XFORM_SKIP_PROC { Scheme_Thread_Memory *tm; @@ -1259,10 +1245,6 @@ void scheme_resume_remembered_threads(void) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #endif /*========================================================================*/ @@ -5442,11 +5424,8 @@ make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, i # ifdef WINDOWS_FILE_HANDLES -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long WindowsFDReader(Win_FD_Input_Thread *th) + XFORM_SKIP_PROC { DWORD toget, got; int perma_eof = 0; @@ -5502,6 +5481,7 @@ static long WindowsFDReader(Win_FD_Input_Thread *th) } static void WindowsFDICleanup(Win_FD_Input_Thread *th) + XFORM_SKIP_PROC { int rc; @@ -5516,10 +5496,6 @@ static void WindowsFDICleanup(Win_FD_Input_Thread *th) free(th); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - # endif #endif @@ -6649,11 +6625,8 @@ static void flush_if_output_fds(Scheme_Object *o, Scheme_Close_Custodian_Client #ifdef WINDOWS_FILE_HANDLES -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long WindowsFDWriter(Win_FD_Output_Thread *oth) + XFORM_SKIP_PROC { DWORD towrite, wrote, start; int ok, more_work = 0, err_no; @@ -6717,6 +6690,7 @@ static long WindowsFDWriter(Win_FD_Output_Thread *oth) } static void WindowsFDOCleanup(Win_FD_Output_Thread *oth) + XFORM_SKIP_PROC { int rc; @@ -6732,10 +6706,6 @@ static void WindowsFDOCleanup(Win_FD_Output_Thread *oth) free(oth); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #endif #endif @@ -6827,11 +6797,8 @@ static int MyPipe(int *ph, int near_index) { static int need_to_check_children; -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_block_child_signals(int block) + XFORM_SKIP_PROC { sigset_t sigs; @@ -6844,6 +6811,7 @@ void scheme_block_child_signals(int block) } static void child_done(int ingored) + XFORM_SKIP_PROC { need_to_check_children = 1; scheme_signal_received(); @@ -6853,10 +6821,6 @@ static void child_done(int ingored) # endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static int sigchld_installed = 0; static void init_sigchld(void) @@ -8115,16 +8079,12 @@ void scheme_notify_sleep_progress() /******************** Main sleep function *****************/ /* The simple select() stuff is buried in Windows complexity. */ +static void default_sleep(float v, void *fds) +#ifdef OS_X + XFORM_SKIP_PROC +#endif /* This sleep function is not allowed to allocate in OS X, because it is called in a non-main thread. */ - -#ifdef OS_X -# ifdef MZ_XFORM -START_XFORM_SKIP; -# endif -#endif - -static void default_sleep(float v, void *fds) { /* REMEMBER: don't allocate in this function (at least not GCable memory) for OS X. Not that FD setups are ok, because they use @@ -8359,17 +8319,8 @@ static void default_sleep(float v, void *fds) #endif } -#ifdef OS_X -# ifdef MZ_XFORM -END_XFORM_SKIP; -# endif -#endif - -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - void scheme_signal_received_at(void *h) + XFORM_SKIP_PROC /* Ensure that MzScheme wakes up if asleep. */ { #if defined(FILES_HAVE_FDS) @@ -8387,6 +8338,7 @@ void scheme_signal_received_at(void *h) } void *scheme_get_signal_handle() + XFORM_SKIP_PROC { #if defined(FILES_HAVE_FDS) return &put_external_event_fd; @@ -8400,14 +8352,11 @@ void *scheme_get_signal_handle() } void scheme_signal_received(void) + XFORM_SKIP_PROC { scheme_signal_received_at(scheme_get_signal_handle()); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - int scheme_get_external_event_fd(void) { #if defined(FILES_HAVE_FDS) @@ -8423,11 +8372,8 @@ static HANDLE itimer; static OS_SEMAPHORE_TYPE itimer_semaphore; static long itimer_delay; -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static long ITimer(void) + XFORM_SKIP_PROC { WaitForSingleObject(itimer_semaphore, INFINITE); @@ -8440,10 +8386,6 @@ static long ITimer(void) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static void scheme_start_itimer_thread(long usec) { DWORD id; @@ -8477,11 +8419,8 @@ typedef struct ITimer_Data { THREAD_LOCAL_DECL(static ITimer_Data *itimerdata); -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static void *green_thread_timer(void *data) + XFORM_SKIP_PROC { ITimer_Data *itimer_data; itimer_data = (ITimer_Data *)data; @@ -8510,10 +8449,6 @@ static void *green_thread_timer(void *data) return NULL; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - static void start_green_thread_timer(long usec) { itimerdata->die = 0; @@ -8581,11 +8516,8 @@ static void scheme_start_itimer_thread(long usec) #ifdef USE_ITIMER -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - static void itimer_expired(int ignored) + XFORM_SKIP_PROC { scheme_fuel_counter = 0; scheme_jit_stack_boundary = (unsigned long)-1; @@ -8594,7 +8526,9 @@ static void itimer_expired(int ignored) # endif } -static void kickoff_itimer(long usec) { +static void kickoff_itimer(long usec) + XFORM_SKIP_PROC +{ struct itimerval t; struct itimerval old; static int itimer_handler_installed = 0; @@ -8612,10 +8546,6 @@ static void kickoff_itimer(long usec) { setitimer(ITIMER_PROF, &t, &old); } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #endif void scheme_kickoff_green_thread_time_slice_timer(long usec) { diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index 90c2c3608d..6a960455ea 100644 --- a/src/mzscheme/src/print.c +++ b/src/mzscheme/src/print.c @@ -534,16 +534,13 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht return 0; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - /* The fast cycle-checker plays a dangerous game: it changes type tags. No GCs can occur here, and no thread switches. If the fast version takes to long, we back out to the general case. (We don't even check for stack overflow, so keep the max limit low.) */ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_checker_counter) + XFORM_SKIP_PROC { Scheme_Type t; int cycle = 0; @@ -618,10 +615,6 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec return cycle; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #ifdef DO_STACK_CHECK static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht, int *counter, PrintParams *pp); diff --git a/src/mzscheme/src/rational.c b/src/mzscheme/src/rational.c index 85ea6d30f2..34a0a1db5c 100644 --- a/src/mzscheme/src/rational.c +++ b/src/mzscheme/src/rational.c @@ -56,11 +56,8 @@ Scheme_Object *scheme_integer_to_rational(const Scheme_Object *n) return make_rational(n, one, 0); } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Object *scheme_make_small_rational(long n, Small_Rational *s) + XFORM_SKIP_PROC { s->so.type = scheme_rational_type; s->num = scheme_make_integer(n); @@ -70,6 +67,7 @@ Scheme_Object *scheme_make_small_rational(long n, Small_Rational *s) } Scheme_Object *scheme_make_small_bn_rational(Scheme_Object *n, Small_Rational *s) + XFORM_SKIP_PROC { s->so.type = scheme_rational_type; s->num = n; @@ -78,10 +76,6 @@ Scheme_Object *scheme_make_small_bn_rational(Scheme_Object *n, Small_Rational *s return (Scheme_Object *)s; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - int scheme_is_rational_positive(const Scheme_Object *o) { Scheme_Rational *r = (Scheme_Rational *)o; diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 96f0315564..87e4dc715e 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -178,11 +178,7 @@ static int do_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, vo return return_code; } -#ifdef MZ_PRECISE_GC -START_XFORM_SKIP; -#endif - -int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) +int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data) XFORM_SKIP_PROC { #ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS # ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE @@ -233,10 +229,6 @@ int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void return do_main_stack_setup(no_auto_statics, _main, data); } -#ifdef MZ_PRECISE_GC -END_XFORM_SKIP; -#endif - void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics) { scheme_set_stack_base(base, no_auto_statics); @@ -283,10 +275,7 @@ extern void GC_attach_current_thread_exceptions_to_handler(); # endif #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif -void scheme_init_os_thread() +void scheme_init_os_thread() XFORM_SKIP_PROC { #ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS Thread_Local_Variables *vars; @@ -300,9 +289,6 @@ void scheme_init_os_thread() # endif #endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif /************************************************************************/ /* memory utils */ @@ -577,11 +563,7 @@ void *scheme_malloc_uncollectable(size_t size_in_bytes) } #endif -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - -void scheme_register_static(void *ptr, long size) +void scheme_register_static(void *ptr, long size) XFORM_SKIP_PROC { #if defined(MZ_PRECISE_GC) || defined(USE_SENORA_GC) /* Always register for precise and Senora GC: */ @@ -595,10 +577,6 @@ void scheme_register_static(void *ptr, long size) #endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - #ifdef USE_TAGGED_ALLOCATION struct GC_Set *tagged, *real_tagged, *tagged_atomic, *tagged_eternal, *tagged_uncollectable, *stacks, *envunbox; diff --git a/src/mzscheme/src/setjmpup.c b/src/mzscheme/src/setjmpup.c index 90807ca0d1..f5d8063249 100644 --- a/src/mzscheme/src/setjmpup.c +++ b/src/mzscheme/src/setjmpup.c @@ -221,9 +221,8 @@ THREAD_LOCAL_DECL(static long stack_copy_size_cache[STACK_COPY_CACHE_SIZE]); THREAD_LOCAL_DECL(static int scc_pos); #define SCC_OK_EXTRA_AMT 100 -START_XFORM_SKIP; - void scheme_flush_stack_copy_cache(void) + XFORM_SKIP_PROC { int i; for (i = 0; i < STACK_COPY_CACHE_SIZE; i++) { @@ -232,8 +231,6 @@ void scheme_flush_stack_copy_cache(void) } } -END_XFORM_SKIP; - #endif /**********************************************************************/ diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 96e72532a9..780af68acb 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -1550,14 +1550,11 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F return kill_self; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - typedef void (*Scheme_For_Each_Func)(Scheme_Object *); static void for_each_managed(Scheme_Type type, Scheme_For_Each_Func cf) - /* This function must not allocate. */ + XFORM_SKIP_PROC +/* This function must not allocate. */ { Scheme_Custodian *m; int i; @@ -1600,10 +1597,6 @@ static void for_each_managed(Scheme_Type type, Scheme_For_Each_Func cf) } } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void scheme_close_managed(Scheme_Custodian *m) /* The trick is that we may need to kill the thread that is running us. If so, delay it to the very @@ -2436,11 +2429,8 @@ void *scheme_tls_get(int pos) return p->user_tls[pos]; } -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Object **scheme_alloc_runstack(long len) + XFORM_SKIP_PROC { #ifdef MZ_PRECISE_GC long sz; @@ -2458,6 +2448,7 @@ Scheme_Object **scheme_alloc_runstack(long len) } void scheme_set_runstack_limits(Scheme_Object **rs, long len, long start, long end) + XFORM_SKIP_PROC /* With 3m, we can tell the GC not to scan the unused parts, and we can have the fixup function zero out the unused parts; that avoids writing and scanning pages that could be skipped for a minor @@ -2474,10 +2465,6 @@ void scheme_set_runstack_limits(Scheme_Object **rs, long len, long start, long e #endif } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - /*========================================================================*/ /* thread creation and swapping */ /*========================================================================*/ @@ -6842,11 +6829,8 @@ static Scheme_Object *current_thread_initial_stack_size(int argc, Scheme_Object /* namespaces */ /*========================================================================*/ -#ifdef MZ_XFORM -START_XFORM_SKIP; -#endif - Scheme_Env *scheme_get_env(Scheme_Config *c) + XFORM_SKIP_PROC { Scheme_Object *o; @@ -6857,10 +6841,6 @@ Scheme_Env *scheme_get_env(Scheme_Config *c) return (Scheme_Env *)o; } -#ifdef MZ_XFORM -END_XFORM_SKIP; -#endif - void scheme_add_namespace_option(Scheme_Object *key, void (*f)(Scheme_Env *)) { Scheme_NSO *old = namespace_options; From 0317676d11e236ef0317d7bca910f06587a6f53f Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 23 Nov 2009 00:25:45 +0000 Subject: [PATCH 48/92] history updated, please propagate svn: r16976 --- doc/release-notes/teachpack/HISTORY.txt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index 44eaab26f0..ae902a89c9 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,9 @@ +------------------------------------------------------------------------ +Version 4.2.3 [Sun Nov 22 19:25:01 EST 2009] + +* bug fixes in universe +* 2htdp/image (first draft) + ------------------------------------------------------------------------ Version 4.2.2 [Sat Aug 29 15:44:41 EDT 2009] From ffadf59303802444b1154aa25841c0cf05011111 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 23 Nov 2009 11:21:30 +0000 Subject: [PATCH 49/92] Fix really stupid bug in `convert-explicit'. svn: r16989 --- collects/deinprogramm/convert-explicit.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/deinprogramm/convert-explicit.scm b/collects/deinprogramm/convert-explicit.scm index 41696e73c7..87e54978bd 100644 --- a/collects/deinprogramm/convert-explicit.scm +++ b/collects/deinprogramm/convert-explicit.scm @@ -63,7 +63,7 @@ ((null? v) (make-:empty-list)) ; prevent silly printing of sharing ((pair? v) (make-:list - (let recur ((v v)) + (let list-recur ((v v)) (cond ((null? v) v) @@ -71,7 +71,7 @@ (recur v)) (else (cons (recur (car v)) - (recur (cdr v)))))))) + (list-recur (cdr v)))))))) ((deinprogramm-struct? v) (or (hash-ref hash v #f) (let*-values (((ty skipped?) (struct-info v)) From ff04d114f703624a1c0c9e946d22b648b290715e Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 23 Nov 2009 16:32:04 +0000 Subject: [PATCH 50/92] Fix web-server doc snafu. svn: r16990 --- collects/web-server/scribblings/ctable.scrbl | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/web-server/scribblings/ctable.scrbl b/collects/web-server/scribblings/ctable.scrbl index 0366511a90..e61d9e9b61 100644 --- a/collects/web-server/scribblings/ctable.scrbl +++ b/collects/web-server/scribblings/ctable.scrbl @@ -67,8 +67,11 @@ where a @scheme[host-table-sexpr] is: (mime-types ,path-string?) (password-authentication ,path-string?)))] -In this syntax, the @scheme['messages] paths are relative to the @scheme['configuration-root] directory. -All the paths in @scheme['paths] are relative to @scheme['host-root] (other than @scheme['host-root] obviously.) +In this syntax, the @scheme['messages] paths are relative to the +@scheme['configuration-root] directory. All the paths in +@scheme['paths] except for @scheme['servlet-root] are relative to +@scheme['host-root] (other than @scheme['host-root] obviously.) +The @scheme['servlet-root] path is relative to @scheme['file-root]. Allowable @scheme['log-format]s are those accepted by @scheme[log-format->format]. From e461f42ad31bd79da3f50e51afe1fee7fa612f09 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Nov 2009 16:53:39 +0000 Subject: [PATCH 51/92] svn: r16991 --- collects/scribblings/futures/futures.scrbl | 35 ++++++++++++++++++++++ collects/scribblings/futures/info.ss | 3 ++ 2 files changed, 38 insertions(+) create mode 100644 collects/scribblings/futures/futures.scrbl create mode 100644 collects/scribblings/futures/info.ss diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl new file mode 100644 index 0000000000..81698ffccd --- /dev/null +++ b/collects/scribblings/futures/futures.scrbl @@ -0,0 +1,35 @@ +#lang scribble/doc + +@title{@bold{Futures}: Fine-grained Parallelism} + +@; ---------------------------------------------------------------------- + +@(require scribble/manual + scribble/urls + scribble/struct + scheme/class + (for-label scheme/base + scheme/gui/base + scheme/class + scheme/contract)) + +@; ---------------------------------------------------------------------- + +PLT's future support is only enabled if you pass @tt{--enable-futures} to @tt{configure} when +you build PLT (and that build currently only works with @tt{mzscheme}, not with @tt{mred}). + +@defmodule['#%futures]{} + +@defproc[(future [thunk (-> any)]) future?]{ + Starts running @scheme[thunk] in parallel. +} + +@defproc[(touch [f future?]) any]{ + Returns the value computed in the future @scheme[f], blocking + to let it complete if it hasn't yet completed. +} + +@defproc[(future? [x any/c]) boolean?]{ + Returns @scheme[#t] if @scheme[x] is a future. +} + diff --git a/collects/scribblings/futures/info.ss b/collects/scribblings/futures/info.ss new file mode 100644 index 0000000000..2d6205d396 --- /dev/null +++ b/collects/scribblings/futures/info.ss @@ -0,0 +1,3 @@ +#lang setup/infotab + +(define scribblings '(("futures.scrbl" ()))) From 4d5044d213b6a0823ec845798ced9c425c760490 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Nov 2009 16:57:23 +0000 Subject: [PATCH 52/92] svn: r16993 --- doc/release-notes/redex/HISTORY.txt | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 887b6f2499..db4fa58971 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,3 +1,5 @@ +v4.2.3 + * added support for collecting metafunction coverage, using the 'relation-coverage' parameter. This includes a backwards incompatible change: the parameter's value is now a list of From e97b9c0675943d579898fb8aadde317c91183589 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Nov 2009 16:57:52 +0000 Subject: [PATCH 53/92] svn: r16994 --- doc/release-notes/drscheme/HISTORY.txt | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index 69b9b68c9e..128c46a0fd 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -1,9 +1,15 @@ +------------------------------ + Version 4.2.3 +------------------------------ + + . minor bug fixes + ------------------------------ Version 4.2.2 ------------------------------ . DrScheme now (by default) automatically compiles your source - files, saving them in the compiled/drscheme/ subdirectory. + files, saving them in the compiled/drscheme/ subdirectory. . Syntax coloring now works for languages using the @-reader (ie, Scribble) From 54adde155a338d2820f6e9a2d422fdcdb3951022 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Nov 2009 17:05:09 +0000 Subject: [PATCH 54/92] svn: r16995 --- collects/framework/private/text.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index e12ad06ec6..c531f0bfb3 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -475,7 +475,7 @@ WARNING: printf is rebound in the body of the unit to always [top (rectangle-top rectangle)] [right (if (number? (rectangle-right rectangle)) (rectangle-right rectangle) - view-x)] + (+ view-x view-width))] [bottom (rectangle-bottom rectangle)] [width (max 0 (- right left))] [height (max 0 (- bottom top))]) From 342fb612085b6e294eb9eb166f26617f8a35bde8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 23 Nov 2009 17:20:41 +0000 Subject: [PATCH 55/92] There is a race condition in this code. This doesn't totally fix it, if another process is creating and deleting the directory quickly, but it will help. svn: r16996 --- collects/scheme/file.ss | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/scheme/file.ss b/collects/scheme/file.ss index 624746de0c..6075feccb4 100644 --- a/collects/scheme/file.ss +++ b/collects/scheme/file.ss @@ -65,7 +65,13 @@ (not (directory-exists? base))) (make-directory* base)) (unless (directory-exists? dir) - (make-directory dir)))) + (with-handlers ([exn:fail:filesystem? + (lambda (x) + (unless (and (regexp-match #rx"cannot make directory:.+File exists" + (exn-message x)) + (directory-exists? dir)) + (raise x)))]) + (make-directory dir))))) (define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f]) (with-handlers ([exn:fail:contract? From 9f57ba92f14569bb2f4e6773cda7b80241bf1114 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Nov 2009 17:43:15 +0000 Subject: [PATCH 56/92] minor details in futures docs svn: r16997 --- collects/scribblings/futures/futures.scrbl | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl index 81698ffccd..90fe2c08c9 100644 --- a/collects/scribblings/futures/futures.scrbl +++ b/collects/scribblings/futures/futures.scrbl @@ -7,16 +7,16 @@ @(require scribble/manual scribble/urls scribble/struct - scheme/class (for-label scheme/base - scheme/gui/base - scheme/class - scheme/contract)) + scheme/contract + '#%futures)) @; ---------------------------------------------------------------------- -PLT's future support is only enabled if you pass @tt{--enable-futures} to @tt{configure} when -you build PLT (and that build currently only works with @tt{mzscheme}, not with @tt{mred}). +PLT's future support is only enabled if you pass +@DFlag{enable-futures} to @exec{configure} when you build PLT (and that +build currently only works with @exec{mzscheme}, not with +@exec{mred}). @defmodule['#%futures]{} From 7662ef4bc145ca347a62a3a41d1d1b6fc0ea43e5 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 23 Nov 2009 18:04:15 +0000 Subject: [PATCH 57/92] Eli says it is a bad hack. svn: r16998 --- collects/scheme/file.ss | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/collects/scheme/file.ss b/collects/scheme/file.ss index 6075feccb4..624746de0c 100644 --- a/collects/scheme/file.ss +++ b/collects/scheme/file.ss @@ -65,13 +65,7 @@ (not (directory-exists? base))) (make-directory* base)) (unless (directory-exists? dir) - (with-handlers ([exn:fail:filesystem? - (lambda (x) - (unless (and (regexp-match #rx"cannot make directory:.+File exists" - (exn-message x)) - (directory-exists? dir)) - (raise x)))]) - (make-directory dir))))) + (make-directory dir)))) (define (make-temporary-file [template "mztmp~a"] [copy-from #f] [base-dir #f]) (with-handlers ([exn:fail:contract? From f719aac2be7b43d4fe71d950dc3d5e2c8f80619c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Nov 2009 18:12:23 +0000 Subject: [PATCH 58/92] scheme/future, sequential futures implementation when --enable-futures not specified; doc updates svn: r16999 --- collects/scheme/future.ss | 7 ++ collects/scribblings/futures/futures.scrbl | 18 ++-- src/mzscheme/src/future.c | 108 ++++++++++++++++++--- src/mzscheme/src/mzmark.c | 33 +++++++ src/mzscheme/src/mzmarksrc.c | 16 +++ 5 files changed, 164 insertions(+), 18 deletions(-) create mode 100644 collects/scheme/future.ss diff --git a/collects/scheme/future.ss b/collects/scheme/future.ss new file mode 100644 index 0000000000..4f8a051af2 --- /dev/null +++ b/collects/scheme/future.ss @@ -0,0 +1,7 @@ +#lang scheme/base +(require '#%futures) + +(provide future? + future + touch + processor-count) diff --git a/collects/scribblings/futures/futures.scrbl b/collects/scribblings/futures/futures.scrbl index 90fe2c08c9..3039ff4ff8 100644 --- a/collects/scribblings/futures/futures.scrbl +++ b/collects/scribblings/futures/futures.scrbl @@ -9,16 +9,18 @@ scribble/struct (for-label scheme/base scheme/contract - '#%futures)) + scheme/future)) @; ---------------------------------------------------------------------- -PLT's future support is only enabled if you pass -@DFlag{enable-futures} to @exec{configure} when you build PLT (and that -build currently only works with @exec{mzscheme}, not with -@exec{mred}). +PLT's parallel-future support is only enabled if you pass +@DFlag{enable-futures} to @exec{configure} when you build PLT (and +that build currently only works with @exec{mzscheme}, not with +@exec{mred}). When parallel-future support is not enabled, +@scheme[future] just remembers the given thunk to call sequentially +on a later @scheme[touch]. -@defmodule['#%futures]{} +@defmodule[scheme/future]{} @defproc[(future [thunk (-> any)]) future?]{ Starts running @scheme[thunk] in parallel. @@ -33,3 +35,7 @@ build currently only works with @exec{mzscheme}, not with Returns @scheme[#t] if @scheme[x] is a future. } +@defproc[(processor-count) exact-positive-integer?]{ + Returns the number of processors available on the current system. +} + diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 1e99450f02..175ce81b66 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -6,26 +6,94 @@ //This will be TRUE if primitive tracking has been enabled //by the program +static Scheme_Object *future_p(int argc, Scheme_Object *argv[]) +{ + if (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type)) + return scheme_true; + else + return scheme_false; +} + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + #ifndef FUTURES_ENABLED -/* Futures not enabled, but make a stub module */ +/* Futures not enabled, but make a stub module and implementation */ + +typedef struct future_t { + Scheme_Object so; + Scheme_Object *running_sema; + Scheme_Object *orig_lambda; + Scheme_Object *retval; + int no_retval; +} future_t; static Scheme_Object *future(int argc, Scheme_Object *argv[]) { - scheme_signal_error("future: not enabled"); - return NULL; + future_t *ft; + + scheme_check_proc_arity("future", 0, 0, argc, argv); + + ft = MALLOC_ONE_TAGGED(future_t); + ft->so.type = scheme_future_type; + + ft->orig_lambda = argv[0]; + + return (Scheme_Object *)ft; } static Scheme_Object *touch(int argc, Scheme_Object *argv[]) { - scheme_signal_error("touch: not enabled"); + future_t * volatile ft; + + if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_future_type)) + scheme_wrong_type("touch", "future", 0, argc, argv); + + ft = (future_t *)argv[0]; + + while (1) { + if (ft->retval) return ft->retval; + if (ft->no_retval) + scheme_signal_error("touch: future previously aborted"); + + if (ft->running_sema) { + scheme_wait_sema(ft->running_sema, 0); + scheme_post_sema(ft->running_sema); + } else { + Scheme_Object *sema; + mz_jmp_buf newbuf, * volatile savebuf; + Scheme_Thread *p = scheme_current_thread; + + /* In case another Scheme thread touchs the future. */ + sema = scheme_make_sema(0); + ft->running_sema = sema; + + savebuf = p->error_buf; + p->error_buf = &newbuf; + if (scheme_setjmp(newbuf)) { + ft->no_retval = 1; + scheme_post_sema(ft->running_sema); + scheme_longjmp(*savebuf, 1); + } else { + GC_CAN_IGNORE Scheme_Object *retval, *proc; + proc = ft->orig_lambda; + ft->orig_lambda = NULL; /* don't hold on to proc */ + retval = _scheme_apply(proc, 0, NULL); + ft->retval = retval; + scheme_post_sema(ft->running_sema); + p->error_buf = savebuf; + } + } + } + return NULL; } static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]) { - scheme_signal_error("processor-count: not enabled"); - return NULL; + return scheme_make_integer(1); } # define FUTURE_PRIM_W_ARITY(name, func, a1, a2, env) GLOBAL_PRIM_W_ARITY(name, func, a1, a2, env) @@ -37,12 +105,17 @@ void scheme_init_futures(Scheme_Env *env) newenv = scheme_primitive_module(scheme_intern_symbol("#%futures"), env); + FUTURE_PRIM_W_ARITY("future?", future_p, 1, 1, newenv); FUTURE_PRIM_W_ARITY("future", future, 1, 1, newenv); FUTURE_PRIM_W_ARITY("touch", touch, 1, 1, newenv); FUTURE_PRIM_W_ARITY("processor-count", processor_count, 1, 1, newenv); scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); + +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif } #else @@ -106,10 +179,6 @@ THREAD_LOCAL_DECL(void *jit_future_storage[2]); THREAD_LOCAL_DECL(extern unsigned long GC_gen0_alloc_page_ptr); #endif -#ifdef MZ_PRECISE_GC -static void register_traversers(void); -#endif - static void start_gc_not_ok(Scheme_Future_State *fs); static void end_gc_not_ok(Scheme_Future_Thread_State *fts, Scheme_Future_State *fs, @@ -203,6 +272,16 @@ void scheme_init_futures(Scheme_Env *env) v = scheme_intern_symbol("#%futures"); newenv = scheme_primitive_module(v, env); + scheme_add_global_constant( + "future?", + scheme_make_folding_prim( + future_p, + "future?", + 1, + 1, + 1), + newenv); + scheme_add_global_constant( "future", scheme_make_prim_w_arity( @@ -1000,6 +1079,7 @@ static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile if (scheme_setjmp(newbuf)) { pthread_mutex_lock(&fs->future_mutex); future->no_retval = 1; + future->work_completed = 1; //Signal the waiting worker thread that it //can continue running machine code pthread_cond_signal(future->can_continue_cv); @@ -1046,6 +1126,8 @@ future_t *get_pending_future(Scheme_Future_State *fs) return NULL; } +#endif + /**********************************************************************/ /* Precise GC */ /**********************************************************************/ @@ -1059,11 +1141,13 @@ START_XFORM_SKIP; static void register_traversers(void) { +#ifdef FUTURES_ENABLED GC_REG_TRAV(scheme_future_type, future); +#else + GC_REG_TRAV(scheme_future_type, sequential_future); +#endif } END_XFORM_SKIP; #endif - -#endif diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index d93dee46de..c319f39417 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5413,6 +5413,8 @@ static int native_unclosed_proc_plus_case_FIXUP(void *p) { #ifdef MARKS_FOR_FUTURE_C +#ifdef FUTURES_ENABLED + static int future_SIZE(void *p) { return gcBYTES_TO_WORDS(sizeof(future_t)); @@ -5468,6 +5470,37 @@ static int future_FIXUP(void *p) { #define future_IS_CONST_SIZE 1 +#else + +static int sequential_future_SIZE(void *p) { + return + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +static int sequential_future_MARK(void *p) { + future_t *f = (future_t *)p; + gcMARK(f->orig_lambda); + gcMARK(f->running_sema); + gcMARK(f->retval); + return + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +static int sequential_future_FIXUP(void *p) { + future_t *f = (future_t *)p; + gcFIXUP(f->orig_lambda); + gcFIXUP(f->running_sema); + gcFIXUP(f->retval); + return + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +#define sequential_future_IS_ATOMIC 0 +#define sequential_future_IS_CONST_SIZE 1 + + +#endif + #endif /* FUTURE */ /**********************************************************************/ diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 7a29d0fc72..07c41debb4 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2220,6 +2220,8 @@ END jit; START future; +#ifdef FUTURES_ENABLED + future { mark: future_t *f = (future_t *)p; @@ -2244,6 +2246,20 @@ future { gcBYTES_TO_WORDS(sizeof(future_t)); } +#else + +sequential_future { + mark: + future_t *f = (future_t *)p; + gcMARK(f->orig_lambda); + gcMARK(f->running_sema); + gcMARK(f->retval); + size: + gcBYTES_TO_WORDS(sizeof(future_t)); +} + +#endif + END future; /**********************************************************************/ From a272c479a6d677a025d187bf0fa6cd62280db00d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Nov 2009 18:46:40 +0000 Subject: [PATCH 59/92] First version of a vector-based "half-copying" merge sort, which will end up being more than twice faster than the current version. [Currently works only with 2^n lists, and otherwise broken -- committed to keep the development history in svn.] svn: r17001 --- collects/scheme/private/sort.ss | 237 +++++++++++++++----------------- 1 file changed, 111 insertions(+), 126 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index dcc9546366..d75aae073f 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -4,23 +4,26 @@ (#%provide sort) -;; This is a destructive stable merge-sort, adapted from slib and improved by -;; Eli Barzilay. -;; The original source said: -;; It uses a version of merge-sort invented, to the best of my knowledge, by -;; David H. D. Warren, and first used in the DEC-10 Prolog system. -;; R. A. O'Keefe adapted it to work destructively in Scheme. -;; but it's a plain destructive merge sort, which I optimized further. +#| -;; The source uses macros to optimize some common cases (eg, no `getkey' -;; function, or precompiled versions with inlinable common comparison -;; predicates) -- they are local macros so they're not left in the compiled -;; code. +Based on "Fast mergesort implementation based on half-copying merge algorithm", +Cezary Juszczak, http://kicia.ift.uni.wroc.pl/algorytmy/mergesortpaper.pdf +Written in Scheme by Eli Barzilay. (Note: the reason for the seemingly +redundant pointer arithmetic in that paper is dealing with cases of uneven +number of elements.) + +The source uses macros to optimize some common cases (eg, no `getkey' +function, or precompiled versions with inlinable common comparison +predicates) -- they are local macros so they're not left in the compiled +code. + +Note that there is no error checking on the arguments -- the `sort' function +that this module provide is then wrapped up by a keyworded version in +"scheme/private/list.ss", and that's what everybody sees. The wrapper is +doing these checks. + +|# -;; Note that there is no error checking on the arguments -- the `sort' function -;; that this module provide is then wrapped up by a keyworded version in -;; "scheme/private/list.ss", and that's what everybody sees. The wrapper is -;; doing these checks. (define sort (let () @@ -29,80 +32,57 @@ [(dr (foo . pattern) template) (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) -(define-syntax-rule (sort-internal-body lst *less? n has-getkey? getkey) +(define-syntax-rule (sort-internal-body v * n 3) - (let* (; let* not really needed with mzscheme's l->r eval - [j (quotient n 2)] [a (step j)] [b (step (- n j))]) - (merge-sorted! a b))] - ;; the following two cases are just explicit treatment of sublists - ;; of length 2 and 3, could remove both (and use the above case for - ;; n>1) and it would still work, except a little slower - [(= n 3) (let ([p lst] [p1 (mcdr lst)] [p2 (mcdr (mcdr lst))]) - (let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)]) - (set! lst (mcdr p2)) - (cond [(less? y x) ; y x - (cond [(less? z y) ; z y x - (set-mcar! p z) - (set-mcar! p1 y) - (set-mcar! p2 x)] - [(less? z x) ; y z x - (set-mcar! p y) - (set-mcar! p1 z) - (set-mcar! p2 x)] - [else ; y x z - (set-mcar! p y) - (set-mcar! p1 x)])] - [(less? z x) ; z x y - (set-mcar! p z) - (set-mcar! p1 x) - (set-mcar! p2 y)] - [(less? z y) ; x z y - (set-mcar! p1 z) - (set-mcar! p2 y)]) - (set-mcdr! p2 '()) - p))] - [(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst]) - (set! lst (mcdr (mcdr lst))) - (when (less? y x) - (set-mcar! p y) - (set-mcar! (mcdr p) x)) - (set-mcdr! (mcdr p) '()) - p)] - [(= n 1) (let ([p lst]) - (set! lst (mcdr lst)) - (set-mcdr! p '()) - p)] - [else '()])))) + (define-syntax-rule ( >=) @@ -112,44 +92,47 @@ (define sort-internal (case-lambda - [(less? lst n) - (let ([si (hash-ref sort-internals less? #f)]) + [( decorated-mlist - [mlst (let ([x (car lst)]) (mcons (cons (getkey x) x) null))]) - (let loop ([last mlst] [lst (cdr lst)]) + (let ([vec (make-vector (+ n (/ n 2)))]) + ;; list -> decorated-vector + (let loop ([i 0] [lst lst]) (when (pair? lst) - (let ([new (let ([x (car lst)]) (mcons (cons (getkey x) x) null))]) - (set-mcdr! last new) - (loop new (cdr lst))))) - ;; decorated-mlist -> list - (let loop ([r (sort-internal *less? mlst n car)]) - (if (null? r) r (cons (cdr (mcar r)) (loop (mcdr r))))))] + (let ([x (car lst)]) + (vector-set! vec i (cons (getkey x) x)) + (loop (add1 i) (cdr lst))))) + ;; sort + (sort-internal * list + (let loop ([i n] [r '()]) + (let ([i (sub1 i)]) + (if (< i 0) r (loop i (cons (cdr (vector-ref vec i)) r))))))] ;; trivial cases [(< n 2) lst] ;; check if the list is already sorted (which can be common, eg, ;; directory lists) [(let loop ([last (car lst)] [next (cdr lst)]) (or (null? next) - (and (not (less? (car next) last)) + (and (not ( mlist - [mlst (mcons (car lst) null)]) - (let loop ([last mlst] [lst (cdr lst)]) + (if ( vector + (let loop ([i 0] [lst lst]) (when (pair? lst) - (let ([new (mcons (car lst) null)]) - (set-mcdr! last new) - (loop new (cdr lst))))) - ;; mlist -> list - (let loop ([r (if getkey - (sort-internal *less? mlst n getkey) - (sort-internal *less? mlst n))]) - (if (null? r) r (cons (mcar r) (loop (mcdr r))))))]))) + (vector-set! vec i (car lst)) + (loop (add1 i) (cdr lst)))) + ;; sort + (if getkey + (sort-internal * list + (let loop ([i n] [r '()]) + (let ([i (sub1 i)]) + (if (< i 0) r (loop i (cons (vector-ref vec i) r))))))]))) ;; Finally, this is the provided `sort' value (case-lambda - [(lst less?) (sort-body lst less? #f #f #f)] - [(lst less? getkey) + [(lst Date: Mon, 23 Nov 2009 18:47:32 +0000 Subject: [PATCH 60/92] Combined the two merge functions into one macro, and improved it a little. svn: r17002 --- collects/scheme/private/sort.ss | 37 +++++++++++++-------------------- 1 file changed, 14 insertions(+), 23 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index d75aae073f..3f02404817 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -39,41 +39,32 @@ doing these checks. (define-syntax-rule (ref n) (vector-ref v n)) (define-syntax-rule (set! n x) (vector-set! v n x)) - (define (merge1 A1 A2 B1 B2 C1 C2) - (when (< C1 B1) - (if (< B1 B2) - (if ( Date: Mon, 23 Nov 2009 18:48:06 +0000 Subject: [PATCH 61/92] Further optimizations to `merge'. svn: r17003 --- collects/scheme/private/sort.ss | 35 ++++++++++++++++++--------------- 1 file changed, 19 insertions(+), 16 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index 3f02404817..ef6efc0f6a 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -33,7 +33,7 @@ doing these checks. (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) (define-syntax-rule (sort-internal-body v * Date: Mon, 23 Nov 2009 18:48:46 +0000 Subject: [PATCH 62/92] Works on lists of any size now. svn: r17004 --- collects/scheme/private/sort.ss | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index ef6efc0f6a..990e5dcf52 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -59,17 +59,21 @@ doing these checks. (define (copying-mergesort Alo Ahi Blo Bhi) (unless (= (- Ahi Alo) (- Bhi Blo)) (error "poof!!!")) (cond [(< Alo (sub1 Ahi)) - (let ([Amid (/ (+ Alo Ahi) 2)] [Bmid (/ (+ Blo Bhi) 2)]) - (copying-mergesort Amid Ahi Bmid Bhi) - (copying-mergesort Alo Amid Amid Ahi) - (merge #t Amid Ahi Bmid Bhi Blo Bhi))] + (let ([Amid1 (floor (/ (+ Alo Ahi) 2))] + [Amid2 (ceiling (/ (+ Alo Ahi) 2))] + [Bmid1 (floor (/ (+ Blo Bhi) 2))] + [Bmid2 (ceiling (/ (+ Blo Bhi) 2))]) + (copying-mergesort Amid1 Ahi Bmid1 Bhi) + (copying-mergesort Alo Amid1 Amid2 Ahi) + (merge #t Amid2 Ahi Bmid1 Bhi Blo Bhi))] [(= Alo (sub1 Ahi)) (set! Blo (ref Alo))])) - (let ([Alo 0] [Amid n/2] [Ahi n] [B1lo n] [B1hi (+ n n/2)]) - (copying-mergesort Amid Ahi B1lo B1hi) - (copying-mergesort Alo Amid Amid Ahi) - (merge #f B1lo B1hi Amid Ahi Alo Ahi)))) + (let ([Alo 0] [Amid1 (- n n/2)] [Amid2 n/2] [Ahi n] + [B1lo n] [B1hi (+ n n/2)]) + (copying-mergesort Amid1 Ahi B1lo B1hi) + (copying-mergesort Alo Amid1 Amid2 Ahi) + (merge #f B1lo B1hi Amid2 Ahi Alo Ahi)))) (define sort-internals (make-hasheq)) (define _ @@ -107,7 +111,7 @@ doing these checks. [cache-keys? ;; decorate while converting to a vector, and undecorate when going ;; back, always do this for consistency - (let ([vec (make-vector (+ n (/ n 2)))]) + (let ([vec (make-vector (+ n (ceiling (/ n 2))))]) ;; list -> decorated-vector (let loop ([i 0] [lst lst]) (when (pair? lst) @@ -154,7 +158,7 @@ doing these checks. (if ( vector (let loop ([i 0] [lst lst]) (when (pair? lst) From ab832a3b4d59725d2289eacfdc95fa8731043248 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Nov 2009 18:49:38 +0000 Subject: [PATCH 63/92] Optimize copying-quicksort by passing around only two indexes and the length of the block. svn: r17005 --- collects/scheme/private/sort.ss | 35 +++++++++++++++------------------ 1 file changed, 16 insertions(+), 19 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index 990e5dcf52..d70669d626 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -33,13 +33,13 @@ doing these checks. (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) (define-syntax-rule (sort-internal-body v * . 1) + (let* ([n/2+ (ceiling (/ n 2))] [n/2- (- n n/2+)]) + (let ([Amid1 (+ Alo n/2-)] + [Amid2 (+ Alo n/2+)] + [Bmid1 (+ Blo n/2-)]) + (copying-mergesort Amid1 Bmid1 n/2+) + (copying-mergesort Alo Amid2 n/2-) + (merge #t Amid2 (+ Alo n) Bmid1 (+ Blo n) Blo)))] + [(= 1 n) (set! Blo (ref Alo))])) - (let ([Alo 0] [Amid1 (- n n/2)] [Amid2 n/2] [Ahi n] - [B1lo n] [B1hi (+ n n/2)]) - (copying-mergesort Amid1 Ahi B1lo B1hi) - (copying-mergesort Alo Amid1 Amid2 Ahi) - (merge #f B1lo B1hi Amid2 Ahi Alo Ahi)))) + (let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n]) + (copying-mergesort Amid1 B1lo n/2+) + (copying-mergesort Alo Amid2 n/2-) + (merge #f B1lo (+ B1lo n/2+) Amid2 Ahi Alo)))) (define sort-internals (make-hasheq)) (define _ From ea94f5dea502662d534544462d06e5f0eb2f819f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Nov 2009 18:50:12 +0000 Subject: [PATCH 64/92] Added `copying-insertionsort' for small blocks, some fixes. svn: r17006 --- collects/scheme/private/sort.ss | 39 +++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index d70669d626..9c6a321cda 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -33,7 +33,7 @@ doing these checks. (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) (define-syntax-rule (sort-internal-body v * j Blo) ( . 1) - (let* ([n/2+ (ceiling (/ n 2))] [n/2- (- n n/2+)]) - (let ([Amid1 (+ Alo n/2-)] - [Amid2 (+ Alo n/2+)] - [Bmid1 (+ Blo n/2-)]) - (copying-mergesort Amid1 Bmid1 n/2+) - (copying-mergesort Alo Amid2 n/2-) - (merge #t Amid2 (+ Alo n) Bmid1 (+ Blo n) Blo)))] - [(= 1 n) (set! Blo (ref Alo))])) + ;; n is never 0, smaller values are more frequent + (cond + [(= n 1) (set! Blo (ref Alo))] + [(= n 2) (let ([x (ref Alo)] [y (ref (add1 Alo))]) + (if ( Date: Mon, 23 Nov 2009 18:51:03 +0000 Subject: [PATCH 65/92] Use unsafe operations for dealing with the vectors and indexes. svn: r17007 --- collects/scheme/private/sort.ss | 74 ++++++++++++++++++--------------- 1 file changed, 41 insertions(+), 33 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index 9c6a321cda..68a7e2fa4f 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -24,6 +24,14 @@ doing these checks. |# +(#%require (rename '#%unsafe i+ unsafe-fx+) + (rename '#%unsafe i- unsafe-fx-) + (rename '#%unsafe i= unsafe-fx=) + (rename '#%unsafe i< unsafe-fx<) + (rename '#%unsafe i<= unsafe-fx<=) + (rename '#%unsafe i>> unsafe-fxrshift) + (rename '#%unsafe vref unsafe-vector-ref) + (rename '#%unsafe vset! unsafe-vector-set!)) (define sort (let () @@ -33,11 +41,11 @@ doing these checks. (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) (define-syntax-rule (sort-internal-body v *> n 1)] [n/2+ (i- n n/2-)]) (define-syntax-rule ( j Blo) (> n 1)] [n/2+ (i- n n/2-)]) + (let ([Amid1 (i+ Alo n/2-)] + [Amid2 (i+ Alo n/2+)] + [Bmid1 (i+ Blo n/2-)]) (copying-mergesort Amid1 Bmid1 n/2+) (copying-mergesort Alo Amid2 n/2-) - (merge #t Amid2 (+ Alo n) Bmid1 (+ Blo n) Blo)))])) + (merge #t Amid2 (i+ Alo n) Bmid1 (i+ Blo n) Blo)))])) (let ([Alo 0] [Amid1 n/2-] [Amid2 n/2+] [Ahi n] [B1lo n]) (copying-mergesort Amid1 B1lo n/2+) (unless (zero? n/2-) (copying-mergesort Alo Amid2 n/2-)) - (merge #f B1lo (+ B1lo n/2+) Amid2 Ahi Alo)))) + (merge #f B1lo (i+ B1lo n/2+) Amid2 Ahi Alo)))) (define sort-internals (make-hasheq)) (define _ @@ -102,16 +110,16 @@ doing these checks. (precomp string-ci Date: Mon, 23 Nov 2009 18:53:13 +0000 Subject: [PATCH 66/92] Switch off unsafe operations for now, better to turn it on after the code was used for a while. svn: r17008 --- collects/scheme/private/sort.ss | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/collects/scheme/private/sort.ss b/collects/scheme/private/sort.ss index 68a7e2fa4f..387560366c 100644 --- a/collects/scheme/private/sort.ss +++ b/collects/scheme/private/sort.ss @@ -24,14 +24,16 @@ doing these checks. |# -(#%require (rename '#%unsafe i+ unsafe-fx+) - (rename '#%unsafe i- unsafe-fx-) - (rename '#%unsafe i= unsafe-fx=) - (rename '#%unsafe i< unsafe-fx<) - (rename '#%unsafe i<= unsafe-fx<=) - (rename '#%unsafe i>> unsafe-fxrshift) - (rename '#%unsafe vref unsafe-vector-ref) - (rename '#%unsafe vset! unsafe-vector-set!)) +;; This code works with unsafe operations, but don't use it for a while to +;; catch potential problems. +;; (#%require (rename '#%unsafe i+ unsafe-fx+) +;; (rename '#%unsafe i- unsafe-fx-) +;; (rename '#%unsafe i= unsafe-fx=) +;; (rename '#%unsafe i< unsafe-fx<) +;; (rename '#%unsafe i<= unsafe-fx<=) +;; (rename '#%unsafe i>> unsafe-fxrshift) +;; (rename '#%unsafe vref unsafe-vector-ref) +;; (rename '#%unsafe vset! unsafe-vector-set!)) (define sort (let () @@ -40,6 +42,15 @@ doing these checks. [(dr (foo . pattern) template) (define-syntax foo (syntax-rules () [(_ . pattern) template]))])) +(define-syntax-rule (i+ x y) (+ x y)) +(define-syntax-rule (i- x y) (- x y)) +(define-syntax-rule (i= x y) (= x y)) +(define-syntax-rule (i< x y) (< x y)) +(define-syntax-rule (i<= x y) (<= x y)) +(define-syntax-rule (i>> x y) (arithmetic-shift x (- y))) +(define-syntax-rule (vref v i) (vector-ref v i)) +(define-syntax-rule (vset! v i x) (vector-set! v i x)) + (define-syntax-rule (sort-internal-body v *> n 1)] [n/2+ (i- n n/2-)]) (define-syntax-rule ( Date: Mon, 23 Nov 2009 18:54:28 +0000 Subject: [PATCH 67/92] Welcome to a new PLT day. svn: r17009 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 3f41985dcd..05e586528c 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "22nov2009") +#lang scheme/base (provide stamp) (define stamp "23nov2009") From 15e3644a8593e11ec8e0e80655b8b92845a7c7c2 Mon Sep 17 00:00:00 2001 From: John Clements Date: Mon, 23 Nov 2009 19:26:32 +0000 Subject: [PATCH 68/92] updated for 4.2.3 release svn: r17010 --- doc/release-notes/stepper/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index 618e8881a7..670fa93772 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for v4.2.3: + +Bug fixes, show first step as soon as it appears. + Changes for v4.2.2: Minor bug fixes. From ce693bdb8271034b33319465a5b8fc19453e9282 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Mon, 23 Nov 2009 19:58:27 +0000 Subject: [PATCH 69/92] PLACES putenv fix svn: r17011 --- src/mzscheme/src/string.c | 296 +++++++++++++++++++++++--------------- 1 file changed, 183 insertions(+), 113 deletions(-) diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c index 738982be6b..2408d86da3 100644 --- a/src/mzscheme/src/string.c +++ b/src/mzscheme/src/string.c @@ -383,6 +383,8 @@ scheme_init_string (Scheme_Env *env) platform_3m_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH MZ3M_SUBDIR); REGISTER_SO(putenv_str_table); + putenv_str_table = scheme_make_hash_table(SCHEME_hash_string); + REGISTER_SO(embedding_banner); REGISTER_SO(current_locale_name); @@ -1978,33 +1980,67 @@ int scheme_any_string_has_null(Scheme_Object *o) } } -#ifdef DOS_FILE_SYSTEM -# include -static char *mzGETENV(char *s) -{ - int sz, got; - char *res; - - sz = GetEnvironmentVariable(s, NULL, 0); - if (!sz) - return NULL; - res = scheme_malloc_atomic(sz); - got = GetEnvironmentVariable(s, res, sz); - if (got < sz) - res[got] = 0; - return res; +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) +static char* clone_str_with_gc(char* buffer) { + int length; + char *newbuffer; + length = strlen(buffer); + newbuffer = scheme_malloc_atomic(length+1); + memcpy(newbuffer, buffer, length+1); + return newbuffer; } - -static int mzPUTENV(char *var, char *val, char *together) -{ - return !SetEnvironmentVariable(var, val); -} - -#else -# define mzGETENV getenv -# define mzPUTENV(var, val, s) MSC_IZE(putenv)(s) #endif +#ifndef DOS_FILE_SYSTEM +static void putenv_str_table_put_name(Scheme_Object *name, Scheme_Object *value) { +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + void *original_gc; + Scheme_Object *name_copy; + original_gc = GC_switch_to_master_gc(); + name_copy = clone_str_with_gc(name); + scheme_hash_set(putenv_str_table, name_copy, value); + GC_switch_back_from_master(original_gc); +#else + scheme_hash_set(putenv_str_table, name, value); +#endif +} +#endif + +#ifndef GETENV_FUNCTION +static void putenv_str_table_put_name_value(Scheme_Object *name, Scheme_Object *value) { +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + void *original_gc; + Scheme_Object *name_copy; + Scheme_Object *value_copy; + original_gc = GC_switch_to_master_gc(); + name_copy = clone_str_with_gc(name); + value_copy = clone_str_with_gc(value); + scheme_hash_set(putenv_str_table, name_copy, value_copy); + GC_switch_back_from_master(original_gc); +#else + scheme_hash_set(putenv_str_table, name, value); +#endif +} +#endif + +#if !defined(GETENV_FUNCTION) || defined(MZ_PRECISE_GC) +static Scheme_Object *putenv_str_table_get(Scheme_Object *name) { +#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) + void *original_gc; + Scheme_Object *value; + original_gc = GC_switch_to_master_gc(); + value = scheme_hash_get(putenv_str_table, name); + GC_switch_back_from_master(original_gc); + return value; +#else + return scheme_hash_get(putenv_str_table, name); +#endif +} +#endif + + +static Scheme_Object *sch_bool_getenv(const char* name); + void scheme_init_getenv(void) { @@ -2017,124 +2053,158 @@ scheme_init_getenv(void) scheme_current_thread->error_buf = &newbuf; if (!scheme_setjmp(newbuf)) { while (1) { - Scheme_Object *v = scheme_read(p); - if (SCHEME_EOFP(v)) - break; + Scheme_Object *v = scheme_read(p); + if (SCHEME_EOFP(v)) + break; - if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v)) - && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) { - Scheme_Object *key = SCHEME_CAR(v); - Scheme_Object *val = SCHEME_CADR(v); - if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) { - Scheme_Object *a[2]; - a[0] = key; - a[1] = val; - sch_putenv(2, a); - v = NULL; - } - } + if (SCHEME_PAIRP(v) && SCHEME_PAIRP(SCHEME_CDR(v)) + && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(v)))) { + Scheme_Object *key = SCHEME_CAR(v); + Scheme_Object *val = SCHEME_CADR(v); + if (SCHEME_STRINGP(key) && SCHEME_STRINGP(val)) { + Scheme_Object *a[2]; + a[0] = key; + a[1] = val; + sch_putenv(2, a); + v = NULL; + } + } - if (v) - scheme_signal_error("bad environment specification: %V", v); + if (v) + scheme_signal_error("bad environment specification: %V", v); } } scheme_current_thread->error_buf = savebuf; scheme_close_input_port(p); - - if (scheme_hash_get(putenv_str_table, (Scheme_Object *)"PLTNOMZJIT")) { - scheme_set_startup_use_jit(0); - } - } -#else - if (mzGETENV("PLTNOMZJIT")) { - scheme_set_startup_use_jit(0); } #endif + if (sch_bool_getenv("PLTNOMZJIT")) { + scheme_set_startup_use_jit(0); + } +} + +#ifdef DOS_FILE_SYSTEM +# include +static char *dos_win_getenv(const char *name) { + int value_size; + value_size = GetEnvironmentVariable(s, NULL, 0); + if (value_size) { + char *value; + int got; + value = scheme_malloc_atomic(value_size); + got = GetEnvironmentVariable(name, value, value_size); + if (got < value_size) + value[got] = 0; + return value; + } + return name; +} +#endif + +static Scheme_Object *sch_bool_getenv(const char* name) { + Scheme_Object *rc; + rc = scheme_false; +#ifdef GETENV_FUNCTION +# ifdef DOS_FILE_SYSTEM + if (GetEnvironmentVariable(s, NULL, 0)) rc = scheme_true; +# else + if (getenv(name)) rc = scheme_true; +# endif +#else + if (putenv_str_table_get(name)) rc = scheme_true; +#endif + return rc; } static Scheme_Object *sch_getenv(int argc, Scheme_Object *argv[]) { - char *s; + char *name; + char *value; Scheme_Object *bs; - if (!SCHEME_CHAR_STRINGP(argv[0]) - || scheme_any_string_has_null(argv[0])) + if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0])) scheme_wrong_type("getenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv); bs = scheme_char_string_to_byte_string_locale(argv[0]); + name = SCHEME_BYTE_STR_VAL(bs); #ifdef GETENV_FUNCTION - s = mzGETENV(SCHEME_BYTE_STR_VAL(bs)); +# ifdef DOS_FILE_SYSTEM + value = dos_win_getenv(name); +# else + value = getenv(name); +# endif #else - if (putenv_str_table) { - s = (char *)scheme_hash_get(putenv_str_table, (Scheme_Object *)SCHEME_BYTE_STR_VAL(argv[0])); - /* If found, skip over the `=' in the table: */ - if (s) - s += SCHEME_BYTE_STRTAG_VAL(bs) + 1; - } else - s = NULL; -#endif - - if (s) - return scheme_make_locale_string(s); - - return scheme_false; -} - -static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]) -{ - char *s, *var, *val; - long varlen, vallen; - Scheme_Object *bs; - - if (!SCHEME_CHAR_STRINGP(argv[0]) - || scheme_any_string_has_null(argv[0])) - scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv); - if (!SCHEME_CHAR_STRINGP(argv[1]) - || scheme_any_string_has_null(argv[1])) - scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 1, argc, argv); - - bs = scheme_char_string_to_byte_string_locale(argv[0]); - var = SCHEME_BYTE_STR_VAL(bs); - - bs = scheme_char_string_to_byte_string_locale(argv[1]); - val = SCHEME_BYTE_STR_VAL(bs); - - varlen = strlen(var); - vallen = strlen(val); - - s = (char *)scheme_malloc_atomic(varlen + vallen + 2); - memcpy(s, var, varlen); - memcpy(s + varlen + 1, val, vallen + 1); - s[varlen] = '='; - -#ifdef MZ_PRECISE_GC { - /* Can't put moveable string into array. */ - char *ss; - ss = s; - s = malloc(varlen + vallen + 2); - memcpy(s, ss, varlen + vallen + 2); - - /* Free old, if in table: */ - if (putenv_str_table) { - ss = (char *)scheme_hash_get(putenv_str_table, (Scheme_Object *)var); - if (ss) - free(ss); - } + Scheme_Object *hash_value; + hash_value = putenv_str_table_get(name); + return hash_value ? hash_value : scheme_false; } #endif - if (!putenv_str_table) - putenv_str_table = scheme_make_hash_table(SCHEME_hash_string); + return value ? scheme_make_locale_string(value) : scheme_false; +} - scheme_hash_set(putenv_str_table, (Scheme_Object *)var, (Scheme_Object *)s); +static int sch_unix_putenv(const char *var, const char *val, const long varlen, const long vallen) { + char *buffer; + long total_length; + total_length = varlen + vallen + 2; + +#ifdef MZ_PRECISE_GC + /* Can't put moveable string into array. */ + buffer = malloc(total_length); +#else + buffer = (char *)scheme_malloc_atomic(total_length); +#endif + memcpy(buffer, var, varlen); + buffer[varlen] = '='; + memcpy(buffer + varlen + 1, val, vallen + 1); + +#ifdef MZ_PRECISE_GC + { + /* Free old, if in table: */ + char *oldbuffer; + oldbuffer = (char *)putenv_str_table_get((Scheme_Object *)var); + if (oldbuffer) + free(oldbuffer); + } +#endif + + /* if precise the buffer needs to be remembered so it can be freed */ + /* if not precise the buffer needs to be rooted so it doesn't get collected prematurely */ + putenv_str_table_put_name((Scheme_Object *)var, (Scheme_Object *)buffer); + return putenv(buffer); +} + +static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *varbs; + Scheme_Object *valbs; + char *var; + char *val; + int rc = 0; + + if (!SCHEME_CHAR_STRINGP(argv[0]) || scheme_any_string_has_null(argv[0])) + scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 0, argc, argv); + if (!SCHEME_CHAR_STRINGP(argv[1]) || scheme_any_string_has_null(argv[1])) + scheme_wrong_type("putenv", CHAR_STRING_W_NO_NULLS, 1, argc, argv); + + varbs = scheme_char_string_to_byte_string_locale(argv[0]); + var = SCHEME_BYTE_STR_VAL(varbs); + + valbs = scheme_char_string_to_byte_string_locale(argv[1]); + val = SCHEME_BYTE_STR_VAL(valbs); #ifdef GETENV_FUNCTION - return mzPUTENV(var, val, s) ? scheme_false : scheme_true; +# ifdef DOS_FILE_SYSTEM + rc = !SetEnvironmentVariable(var, val); +# else + rc = sch_unix_putenv(var, val, SCHEME_BYTE_STRLEN_VAL(varbs), SCHEME_BYTE_STRLEN_VAL(valbs)); +# endif #else - return scheme_true; + putenv_str_table_put_name_value(argv[0], argv[1]); #endif + return rc ? scheme_false : scheme_true; } static void machine_details(char *s); From 0257ac515af0ace1a7244c03e1bb897dca005100 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 23 Nov 2009 20:44:47 +0000 Subject: [PATCH 70/92] Make the stepper ignore `check-property'. svn: r17013 --- collects/deinprogramm/DMdA.ss | 4 ++-- collects/stepper/internal-docs.txt | 6 ++++++ collects/stepper/private/annotate.ss | 3 ++- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/collects/deinprogramm/DMdA.ss b/collects/deinprogramm/DMdA.ss index c8d197289e..a70bddc899 100644 --- a/collects/deinprogramm/DMdA.ss +++ b/collects/deinprogramm/DMdA.ss @@ -1006,8 +1006,8 @@ (stepper-syntax-property (check-expect-maker stx #'check-property-error #'?prop '() 'comes-from-check-property) - 'stepper-skip-completely - #t)) + 'stepper-replace + #'#t)) (_ (raise-syntax-error #f "`check-property' erwartet einen einzelnen Operanden" stx)))) diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index fefbd85372..d301d07e7f 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -212,6 +212,12 @@ stepper-skipto/discard : Abstraktion", where procedures are wrapped in a contract-checking context that has no impact on the reduction semantics.) +stepper-replace : + + This is like stepper-skipto/discard, except that it makes the + stepper replace the expression the property is attached to by the + value of the property. + stepper-else : [ #t ] : Initially applied to the 'true' that the cond macro replaces a beginner's 'else' with, it is later transferred diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 0828266121..0ba963bdc5 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -1160,7 +1160,8 @@ (define (annotate/module-top-level exp) - (cond [(stepper-syntax-property exp 'stepper-skip-completely) exp] + (cond [(stepper-syntax-property exp 'stepper-replace)] + [(stepper-syntax-property exp 'stepper-skip-completely) exp] ;; for kathy's test engine: [(syntax-property exp 'test-call) exp] [(stepper-syntax-property exp 'stepper-define-struct-hint) From 958e3418aa06d69b6667e3e7b26a5ced7b0367ff Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 23 Nov 2009 21:21:40 +0000 Subject: [PATCH 71/92] Added caveat in Reference to "7.5 Building New Contract Combinators" and its subsection "7.5.1 Contracts as structs" stating: "Note: The interface in this section is unstable and subject to change." This is in preparation for a new implementation of contract properties. svn: r17014 --- collects/scribblings/reference/contracts.scrbl | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 25566f9a8e..2114c3b961 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -865,6 +865,9 @@ source location information from compiled files. @section{Building New Contract Combinators} +@emph{@bold{Note:} + The interface in this section is unstable and subject to change.} + Contracts are represented internally as functions that accept information about the contract (who is to blame, source locations, etc) and produce projections (in the @@ -1126,6 +1129,9 @@ to build an actual error message.} @subsection{Contracts as structs} +@emph{@bold{Note:} + The interface in this section is unstable and subject to change.} + A contract is an arbitrary struct that has all of the struct properties (see @secref["structprops"] in the reference manual) From 2599cf95f81c4967ea0d767caf4d56d41e8174b9 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Mon, 23 Nov 2009 21:34:29 +0000 Subject: [PATCH 72/92] THREAD_LOCAL Logger svn: r17016 --- src/mzscheme/include/schthread.h | 2 ++ src/mzscheme/src/env.c | 2 ++ src/mzscheme/src/error.c | 41 ++++++++++++++++---------------- src/mzscheme/src/schpriv.h | 5 ++-- src/mzscheme/src/thread.c | 8 +++---- 5 files changed, 30 insertions(+), 28 deletions(-) diff --git a/src/mzscheme/include/schthread.h b/src/mzscheme/include/schthread.h index 7d49a5552a..daa47e1a72 100644 --- a/src/mzscheme/include/schthread.h +++ b/src/mzscheme/include/schthread.h @@ -216,6 +216,7 @@ typedef struct Thread_Local_Variables { unsigned long current_total_allocation_; struct gmp_tmp_stack gmp_tmp_xxx_; struct gmp_tmp_stack *gmp_tmp_current_; + struct Scheme_Logger *scheme_main_logger_; } Thread_Local_Variables; #if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) @@ -398,6 +399,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define current_total_allocation XOA (scheme_get_thread_local_variables()->current_total_allocation_) #define gmp_tmp_xxx XOA (scheme_get_thread_local_variables()->gmp_tmp_xxx_) #define gmp_tmp_current XOA (scheme_get_thread_local_variables()->gmp_tmp_current_) +#define scheme_main_logger XOA (scheme_get_thread_local_variables()->scheme_main_logger_) /* **************************************** */ diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index c98945537b..312af4e013 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -439,6 +439,7 @@ static Scheme_Env *place_instance_init_post_kernel() { } scheme_init_error_escape_proc(NULL); scheme_init_print_buffers_places(); + scheme_init_logger(); scheme_init_eval_places(); scheme_init_regexp_places(); scheme_init_stx_places(); @@ -453,6 +454,7 @@ static Scheme_Env *place_instance_init_post_kernel() { scheme_init_port_config(); scheme_init_port_fun_config(); scheme_init_error_config(); + scheme_init_logger_config(); #ifndef NO_SCHEME_EXNS scheme_init_exn_config(); #endif diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index dd0e2ea92f..5f72cf30ef 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -50,8 +50,7 @@ void (*scheme_console_output)(char *str, long len); static int init_syslog_level = INIT_SYSLOG_LEVEL; static int init_stderr_level = SCHEME_LOG_ERROR; -Scheme_Logger *scheme_main_logger; -static void init_logger_config(); +THREAD_LOCAL_DECL(static Scheme_Logger *scheme_main_logger); /* readonly globals */ const char *scheme_compile_stx_string = "compile"; @@ -589,7 +588,13 @@ void scheme_init_error(Scheme_Env *env) scheme_add_evt(scheme_log_reader_type, (Scheme_Ready_Fun)log_reader_get, NULL, NULL, 1); REGISTER_SO(scheme_def_exit_proc); + REGISTER_SO(default_display_handler); + REGISTER_SO(emergency_display_handler); + scheme_def_exit_proc = scheme_make_prim_w_arity(def_exit_handler_proc, "default-exit-handler", 1, 1); + default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2); + emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2); + REGISTER_SO(def_err_val_proc); def_err_val_proc = scheme_make_prim_w_arity(def_error_value_string_proc, "default-error-value->string-handler", 2, 2); @@ -605,14 +610,6 @@ void scheme_init_error(Scheme_Env *env) info_symbol = scheme_intern_symbol("info"); debug_symbol = scheme_intern_symbol("debug"); - { - REGISTER_SO(scheme_main_logger); - scheme_main_logger = make_a_logger(NULL, NULL); - scheme_main_logger->syslog_level = init_syslog_level; - scheme_main_logger->stderr_level = init_stderr_level; - } - init_logger_config(); - REGISTER_SO(arity_property); { Scheme_Object *guard; @@ -625,27 +622,29 @@ void scheme_init_error(Scheme_Env *env) scheme_init_error_config(); } -static void init_logger_config() +void scheme_init_logger() { - scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger); + REGISTER_SO(scheme_main_logger); + scheme_main_logger = make_a_logger(NULL, NULL); + scheme_main_logger->syslog_level = init_syslog_level; + scheme_main_logger->stderr_level = init_stderr_level; +} + +Scheme_Logger *scheme_get_main_logger() { + return scheme_main_logger; } void scheme_init_error_config(void) { - init_logger_config(); - scheme_set_root_param(MZCONFIG_EXIT_HANDLER, scheme_def_exit_proc); - - REGISTER_SO(default_display_handler); - REGISTER_SO(emergency_display_handler); - - default_display_handler = scheme_make_prim_w_arity(def_error_display_proc, "default-error-display-handler", 2, 2); - emergency_display_handler = scheme_make_prim_w_arity(emergency_error_display_proc, "emergency-error-display-handler", 2, 2); - scheme_set_root_param(MZCONFIG_ERROR_DISPLAY_HANDLER, default_display_handler); scheme_set_root_param(MZCONFIG_ERROR_PRINT_VALUE_HANDLER, def_err_val_proc); } +void scheme_init_logger_config() { + scheme_set_root_param(MZCONFIG_LOGGER, (Scheme_Object *)scheme_main_logger); +} + static void scheme_inescapeable_error(const char *a, const char *b) { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index c7579f2353..ff26738435 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -235,6 +235,9 @@ void scheme_init_fun_places(void); void scheme_init_sema_places(void); void scheme_init_gmp_places(void); void scheme_init_print_global_constants(void); +void scheme_init_logger(void); +Scheme_Logger *scheme_get_main_logger(void); +void scheme_init_logger_config(void); void register_network_evts(); @@ -2944,8 +2947,6 @@ typedef struct Scheme_Log_Reader { Scheme_Object *head, *tail; } Scheme_Log_Reader; -extern Scheme_Logger *scheme_main_logger; - char *scheme_optimize_context_to_string(Scheme_Object *context); void scheme_write_proc_context(Scheme_Object *port, int print_width, diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 780af68acb..86995727bc 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -7408,7 +7408,8 @@ static void done_with_GC() #ifdef MZ_PRECISE_GC static void inform_GC(int major_gc, long pre_used, long post_used) { - if (scheme_main_logger) { + Scheme_Logger *logger = scheme_get_main_logger(); + if (logger) { /* Don't use scheme_log(), because it wants to allocate a buffer based on the max value-print width, and we may not be at a point where parameters are available. */ @@ -7422,10 +7423,7 @@ static void inform_GC(int major_gc, long pre_used, long post_used) end_this_gc_time - start_this_gc_time); buflen = strlen(buf); - scheme_log_message(scheme_main_logger, - SCHEME_LOG_DEBUG, - buf, buflen, - NULL); + scheme_log_message(logger, SCHEME_LOG_DEBUG, buf, buflen, NULL); } } From 66869a13d579244f452dce620d0531bd951b102f Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Mon, 23 Nov 2009 22:13:47 +0000 Subject: [PATCH 73/92] Fixes for new THREAD_LOCAL table svn: r17017 --- src/mzscheme/gc2/newgc.c | 2 -- src/mzscheme/src/env.c | 10 +++++----- src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/stxobj.c | 10 +++++++++- 4 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 6771384a35..bd6eda90c3 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -1865,7 +1865,6 @@ void GC_construct_child_gc() { } static inline void save_globals_to_gc(NewGC *gc) { - gc->saved_mark_stack = mark_stack; gc->saved_GC_variable_stack = GC_variable_stack; gc->saved_GC_gen0_alloc_page_ptr = GC_gen0_alloc_page_ptr; gc->saved_GC_gen0_alloc_page_end = GC_gen0_alloc_page_end; @@ -1873,7 +1872,6 @@ static inline void save_globals_to_gc(NewGC *gc) { } static inline void restore_globals_from_gc(NewGC *gc) { - mark_stack = gc->saved_mark_stack; GC_variable_stack = gc->saved_GC_variable_stack; GC_gen0_alloc_page_ptr = gc->saved_GC_gen0_alloc_page_ptr; GC_gen0_alloc_page_end = gc->saved_GC_gen0_alloc_page_end; diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 312af4e013..8336e4776e 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -144,7 +144,7 @@ int scheme_is_module_begin_env(Scheme_Comp_Env *env); Scheme_Env *scheme_engine_instance_init(); Scheme_Env *scheme_place_instance_init(); static void place_instance_init_pre_kernel(); -static Scheme_Env *place_instance_init_post_kernel(); +static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread); #ifdef MZ_PRECISE_GC static void register_traversers(void); @@ -361,7 +361,7 @@ Scheme_Env *scheme_engine_instance_init() { place_instance_init_pre_kernel(stack_base); make_kernel_env(); scheme_init_parameterization_readonly_globals(); - env = place_instance_init_post_kernel(); + env = place_instance_init_post_kernel(1); return env; } @@ -428,7 +428,7 @@ Scheme_Env *scheme_get_unsafe_env() { return unsafe_env; } -static Scheme_Env *place_instance_init_post_kernel() { +static Scheme_Env *place_instance_init_post_kernel(int initial_main_os_thread) { Scheme_Env *env; /* error handling and buffers */ /* this check prevents initializing orig ports twice for the first initial @@ -442,7 +442,7 @@ static Scheme_Env *place_instance_init_post_kernel() { scheme_init_logger(); scheme_init_eval_places(); scheme_init_regexp_places(); - scheme_init_stx_places(); + scheme_init_stx_places(initial_main_os_thread); scheme_init_sema_places(); scheme_init_gmp_places(); scheme_alloc_global_fdset(); @@ -497,7 +497,7 @@ static Scheme_Env *place_instance_init_post_kernel() { Scheme_Env *scheme_place_instance_init(void *stack_base) { place_instance_init_pre_kernel(stack_base); - return place_instance_init_post_kernel(); + return place_instance_init_post_kernel(0); } void scheme_place_instance_destroy() { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index ff26738435..5c4c3b6989 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -230,7 +230,7 @@ void scheme_init_print_buffers_places(void); void scheme_init_eval_places(void); void scheme_init_port_places(void); void scheme_init_regexp_places(void); -void scheme_init_stx_places(void); +void scheme_init_stx_places(int initial_main_os_thread); void scheme_init_fun_places(void); void scheme_init_sema_places(void); void scheme_init_gmp_places(void); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 76c90aea1e..f50b26835b 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -631,7 +631,7 @@ void scheme_init_stx(Scheme_Env *env) scheme_install_type_reader2(scheme_free_id_info_type, read_free_id_info_prefix); } -void scheme_init_stx_places() { +void scheme_init_stx_places(int initial_main_os_thread) { REGISTER_SO(last_phase_shift); REGISTER_SO(nominal_ipair_cache); REGISTER_SO(quick_hash_table); @@ -639,6 +639,14 @@ void scheme_init_stx_places() { REGISTER_SO(than_id_marks_ht); REGISTER_SO(interned_skip_ribs); REGISTER_SO(unsealed_dependencies); + + if (!initial_main_os_thread) { + REGISTER_SO(mark_id); + REGISTER_SO(current_rib_timestamp); + mark_id = scheme_make_integer(0); + current_rib_timestamp = scheme_make_integer(0); + } + interned_skip_ribs = scheme_make_weak_equal_table(); } From 1dd2109909937385c3783a6e49bb16af09b8f097 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Nov 2009 22:56:28 +0000 Subject: [PATCH 74/92] Scribble HTML renderer: mark internal links with 'extra-internal-attribs' svn: r17018 --- collects/scribble/html-render.ss | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 2932141dc2..fcef56422f 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -43,6 +43,8 @@ ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body) "\n")))) +(define (extra-internal-attribs) null) + (define-runtime-path scribble-css "scribble.css") (define-runtime-path scribble-style-css "scribble-style.css") (define-runtime-path scribble-prefix-html "scribble-prefix.html") @@ -359,7 +361,8 @@ `((a ([href ,(dest->url (resolve-get t ri (car (part-tags t))))] [class ,(if (or (eq? t d) (and show-mine? (memq t toc-chain))) "tocviewselflink" - "tocviewlink")]) + "tocviewlink")] + ,@(extra-internal-attribs)) ,@(render-content (or (part-title-content t) '("???")) d ri))) (format-number (collected-info-number (part-collected-info t ri)) '(nbsp)))) @@ -528,7 +531,8 @@ ,(cond [(part? p) "tocsubseclink"] [any-parts? "tocsubnonseclink"] - [else "tocsublink"])]) + [else "tocsublink"])] + ,@(extra-internal-attribs)) ,@(render-content (if (part? p) (or (part-title-content p) @@ -987,7 +991,8 @@ [else ;; Normal link: (dest->url dest)])) - ,@(attribs)] + ,@(attribs) + ,@(extra-internal-attribs)] ,@(if (empty-content? (element-content e)) (render-content (strip-aux (dest-title dest)) part ri) (render-content (element-content e) part ri)))) From dcf299173667cfc249a30559f92cce4c1a023c10 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Nov 2009 23:00:08 +0000 Subject: [PATCH 75/92] future fixes: continuation barrier in place, handle multiple results from a future svn: r17019 --- src/mzscheme/src/future.c | 106 +++++++++++++++++++++---- src/mzscheme/src/future.h | 2 + src/mzscheme/src/gen-jit-ts.ss | 4 +- src/mzscheme/src/jit.c | 49 ++++++------ src/mzscheme/src/jit_ts.c | 1 - src/mzscheme/src/jit_ts_future_glue.c | 44 +++++++--- src/mzscheme/src/jit_ts_runtime_glue.c | 20 +++++ src/mzscheme/src/mzmark.c | 2 + src/mzscheme/src/mzmarksrc.c | 1 + 9 files changed, 176 insertions(+), 53 deletions(-) diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 175ce81b66..4cd5930ec5 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -1,7 +1,24 @@ +/* + MzScheme + Copyright (c) 2006-2009 PLT Scheme Inc. -#ifndef UNIT_TEST -# include "schpriv.h" -#endif + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. +*/ + +#include "schpriv.h" //This will be TRUE if primitive tracking has been enabled //by the program @@ -27,6 +44,8 @@ typedef struct future_t { Scheme_Object *running_sema; Scheme_Object *orig_lambda; Scheme_Object *retval; + int multiple_count; + Scheme_Object **multiple_array; int no_retval; } future_t; @@ -54,7 +73,14 @@ static Scheme_Object *touch(int argc, Scheme_Object *argv[]) ft = (future_t *)argv[0]; while (1) { - if (ft->retval) return ft->retval; + if (ft->retval) { + if (SAME_OBJ(ft->retval, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; + p->ku.multiple.array = ft->multiple_array; + p->ku.multiple.count = ft->multiple_count; + } + return ft->retval; + } if (ft->no_retval) scheme_signal_error("touch: future previously aborted"); @@ -80,8 +106,13 @@ static Scheme_Object *touch(int argc, Scheme_Object *argv[]) GC_CAN_IGNORE Scheme_Object *retval, *proc; proc = ft->orig_lambda; ft->orig_lambda = NULL; /* don't hold on to proc */ - retval = _scheme_apply(proc, 0, NULL); + retval = scheme_apply_multi(proc, 0, NULL); ft->retval = retval; + if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { + ft->multiple_array = p->ku.multiple.array; + ft->multiple_count = p->ku.multiple.count; + p->ku.multiple.array = NULL; + } scheme_post_sema(ft->running_sema); p->error_buf = savebuf; } @@ -123,9 +154,6 @@ void scheme_init_futures(Scheme_Env *env) #include "future.h" #include #include -#ifdef UNIT_TEST -# include "./tests/unit_test.h" -#endif static Scheme_Object *future(int argc, Scheme_Object *argv[]); static Scheme_Object *touch(int argc, Scheme_Object *argv[]); @@ -188,6 +216,8 @@ static void *worker_thread_future_loop(void *arg); static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile future); static future_t *enqueue_future(Scheme_Future_State *fs, future_t *ft);; static future_t *get_pending_future(Scheme_Future_State *fs); +static void receive_special_result(future_t *f, Scheme_Object *retval, int clear); +static void send_special_result(future_t *f, Scheme_Object *retval); #ifdef MZ_PRECISE_GC # define scheme_future_setjmp(newbuf) scheme_jit_setjmp((newbuf).jb) @@ -605,7 +635,8 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) ft->status = RUNNING; pthread_mutex_unlock(&fs->future_mutex); - retval = _scheme_apply(ft->orig_lambda, 0, NULL); + retval = scheme_apply_multi(ft->orig_lambda, 0, NULL); + send_special_result(ft, retval); pthread_mutex_lock(&fs->future_mutex); ft->work_completed = 1; @@ -614,6 +645,8 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) dequeue_future(fs, ft); pthread_mutex_unlock(&fs->future_mutex); + receive_special_result(ft, retval, 0); + return retval; } pthread_mutex_unlock(&fs->future_mutex); @@ -654,6 +687,8 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) scheme_signal_error("touch: future previously aborted"); } + receive_special_result(ft, retval, 0); + return retval; } @@ -793,18 +828,24 @@ void *worker_thread_future_loop(void *arg) v = NULL; } else { v = jitcode(ft->orig_lambda, 0, NULL); + if (SAME_OBJ(v, SCHEME_TAIL_CALL_WAITING)) { + v = scheme_ts_scheme_force_value_same_mark(v); + } } LOG("Finished running JIT code at %p.\n", ft->code); // Get future again, since a GC may have occurred ft = fts->current_ft; - + //Set the return val in the descriptor pthread_mutex_lock(&fs->future_mutex); ft->work_completed = 1; ft->retval = v; + /* In case of multiple values: */ + send_special_result(ft, v); + //Update the status ft->status = FINISHED; dequeue_future(fs, ft); @@ -960,28 +1001,35 @@ unsigned long scheme_rtcall_alloc_void_pvoid(const char *who, int src_type, prim return retval; } -static void receive_special_result(future_t *f, Scheme_Object *retval) +static void receive_special_result(future_t *f, Scheme_Object *retval, int clear) XFORM_SKIP_PROC -/* Called in future thread */ +/* Called in future or runtime thread */ { if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { Scheme_Thread *p = scheme_current_thread; p->ku.multiple.array = f->multiple_array; p->ku.multiple.count = f->multiple_count; - f->multiple_array = NULL; + if (clear) + f->multiple_array = NULL; } else if (SAME_OBJ(retval, SCHEME_TAIL_CALL_WAITING)) { Scheme_Thread *p = scheme_current_thread; p->ku.apply.tail_rator = f->tail_rator; p->ku.apply.tail_rands = f->tail_rands; p->ku.apply.tail_num_rands = f->num_tail_rands; + if (clear) { + f->tail_rator = NULL; + f->tail_rands = NULL; + } } } #include "jit_ts_future_glue.c" static void send_special_result(future_t *f, Scheme_Object *retval) + XFORM_SKIP_PROC +/* Called in future or runtime thread */ { if (SAME_OBJ(retval, SCHEME_MULTIPLE_VALUES)) { Scheme_Thread *p = scheme_current_thread; @@ -990,6 +1038,7 @@ static void send_special_result(future_t *f, Scheme_Object *retval) f->multiple_count = p->ku.multiple.count; if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) p->values_buffer = NULL; + p->ku.multiple.array = NULL; } else if (SAME_OBJ(retval, SCHEME_TAIL_CALL_WAITING)) { Scheme_Thread *p = scheme_current_thread; @@ -1019,8 +1068,11 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future) src = future->source_of_request; if (future->source_type == FSRC_RATOR) { int len; - if (SCHEME_PROCP(future->arg_s0)) - src = scheme_get_proc_name(future->arg_s0, &len, 1); + if (SCHEME_PROCP(future->arg_s0)) { + const char *src2; + src2 = scheme_get_proc_name(future->arg_s0, &len, 1); + if (src2) src = src2; + } } else if (future->source_type == FSRC_PRIM) { const char *src2; src2 = scheme_look_for_primitive(future->prim_func); @@ -1069,6 +1121,20 @@ static void do_invoke_rtcall(Scheme_Future_State *fs, future_t *future) pthread_mutex_unlock(&fs->future_mutex); } +static void *do_invoke_rtcall_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Future_State *fs = (Scheme_Future_State *)p->ku.k.p1; + future_t *future = (future_t *)p->ku.k.p2; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + do_invoke_rtcall(fs, future); + + return scheme_void; +} + static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile future) { Scheme_Thread *p = scheme_current_thread; @@ -1087,7 +1153,15 @@ static void invoke_rtcall(Scheme_Future_State * volatile fs, future_t * volatile pthread_mutex_unlock(&fs->future_mutex); scheme_longjmp(*savebuf, 1); } else { - do_invoke_rtcall(fs, future); + if (future->rt_prim_is_atomic) { + do_invoke_rtcall(fs, future); + } else { + /* call with continuation barrier. */ + p->ku.k.p1 = fs; + p->ku.k.p2 = future; + + (void)scheme_top_level_do(do_invoke_rtcall_k, 1); + } } p->error_buf = savebuf; } diff --git a/src/mzscheme/src/future.h b/src/mzscheme/src/future.h index d6f5fc9490..a2c8eee44e 100644 --- a/src/mzscheme/src/future.h +++ b/src/mzscheme/src/future.h @@ -108,6 +108,8 @@ typedef struct future_t { # include "jit_ts_protos.h" +extern Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v); + //Helper macros for argument marshaling #ifdef FUTURES_ENABLED diff --git a/src/mzscheme/src/gen-jit-ts.ss b/src/mzscheme/src/gen-jit-ts.ss index e6a2f7eec9..63d896d2fe 100644 --- a/src/mzscheme/src/gen-jit-ts.ss +++ b/src/mzscheme/src/gen-jit-ts.ss @@ -81,11 +81,12 @@ [i (in-naturals)]) @string-append{ future->arg_@|(string t)|@|(number->string i)| = @|a|;}) "\n") + @(if (equal? arg-types '("Scheme_Object*")) @string-append{send_special_result(future, @(car arg-names));} "") future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; @(if (string=? result-type "void") "" @string-append{retval = @|fretval|;}) @(if (string=? result-type "void") "" @string-append{@|fretval| = 0;}) - @(if (string=? result-type "Scheme_Object*") @string-append{receive_special_result(future, retval);} "") + @(if (string=? result-type "Scheme_Object*") @string-append{receive_special_result(future, retval, 1);} "") @(if (string=? result-type "void") "" "return retval;") } }) @@ -104,6 +105,7 @@ { prim_@|ts| f = (prim_@|ts|)future->prim_func; @(if (string=? result-type "void") "" @string-append{@|result-type| retval;}) + @(if (equal? arg-types '("Scheme_Object*")) @string-append{receive_special_result(future, future->arg_s0, 1);} "") @(if (string=? result-type "void") "" "retval = ") f(@(string-join (for/list ([t (in-string (type->arg-string t))] diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 507b136694..86bbf0d048 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -392,28 +392,6 @@ static void *decrement_cache_stack_pos(void *p) THREAD_LOCAL_DECL(static Scheme_Object **fixup_runstack_base); THREAD_LOCAL_DECL(static int fixup_already_in_place); -/* FIXME?: If _scheme_tail_apply_from_native_fixup_args is called from - a future thread, then the wrong thread-local `fixup_runstack_base' - was set. But exercising this code seems to be impossible, maybe - because current bytecode optimizations never produce the case that - _scheme_tail_apply_from_native_fixup_args() was design to support. */ - -static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator, - int argc, - Scheme_Object **argv) -{ - int already = fixup_already_in_place, i; - Scheme_Object **base; - - base = fixup_runstack_base XFORM_OK_MINUS argc XFORM_OK_MINUS already; - - /* Need to shift argc to end of base: */ - for (i = 0; i < argc; i++) { - base[already + i] = argv[i]; - } - - return _scheme_tail_apply_from_native(rator, argc + already, base); -} static Scheme_Object *make_global_ref(Scheme_Object *var) { GC_CAN_IGNORE Scheme_Object *o; @@ -2210,6 +2188,7 @@ extern int g_print_prims; mz_patch_ucbranch(refcont); \ __END_TINY_JUMPS__(1); \ } + static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) XFORM_SKIP_PROC { @@ -2222,6 +2201,7 @@ static Scheme_Object *noncm_prim_indirect(Scheme_Prim proc, int argc) else return proc(argc, MZ_RUNSTACK); } + static Scheme_Object *prim_indirect(Scheme_Primitive_Closure_Proc proc, int argc, Scheme_Object *self) XFORM_SKIP_PROC { @@ -2264,6 +2244,12 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) XFORM_SKIP_PROC return ret; } #endif + +Scheme_Object *scheme_ts_scheme_force_value_same_mark(Scheme_Object *v) +{ + return ts_scheme_force_value_same_mark(v); +} + #else /* futures not enabled */ # define mz_prepare_direct_prim(n) mz_prepare(n) @@ -2275,6 +2261,23 @@ static void *ts_prepare_retry_alloc(void *p, void *p2) XFORM_SKIP_PROC (mz_direct_only(direct_only), first_arg, mz_finishr_direct_prim(reg, prim_indirect)) #endif +static Scheme_Object *_scheme_tail_apply_from_native_fixup_args(Scheme_Object *rator, + int argc, + Scheme_Object **argv) +{ + int already = fixup_already_in_place, i; + Scheme_Object **base; + + base = fixup_runstack_base XFORM_OK_MINUS argc XFORM_OK_MINUS already; + + /* Need to shift argc to end of base: */ + for (i = 0; i < argc; i++) { + base[already + i] = argv[i]; + } + + return ts__scheme_tail_apply_from_native(rator, argc + already, base); +} + static int generate_pause_for_gc_and_retry(mz_jit_state *jitter, int in_short_jumps, int gc_reg, /* must not be JIT_R1 */ @@ -2524,7 +2527,7 @@ static int generate_finish_tail_call(mz_jit_state *jitter, int direct_native) jit_pusharg_i(JIT_R0); jit_pusharg_p(JIT_V1); if (direct_native > 1) { /* => some_args_already_in_place */ - (void)mz_finish(ts__scheme_tail_apply_from_native_fixup_args); + (void)mz_finish(_scheme_tail_apply_from_native_fixup_args); } else { (void)mz_finish(ts__scheme_tail_apply_from_native); } diff --git a/src/mzscheme/src/jit_ts.c b/src/mzscheme/src/jit_ts.c index 1b778e1f7c..a43e0e5827 100644 --- a/src/mzscheme/src/jit_ts.c +++ b/src/mzscheme/src/jit_ts.c @@ -16,7 +16,6 @@ define_ts_siS_s(_scheme_apply_multi_from_native, FSRC_RATOR) define_ts_siS_s(_scheme_apply_from_native, FSRC_RATOR) define_ts_siS_s(_scheme_tail_apply_from_native, FSRC_RATOR) -define_ts_siS_s(_scheme_tail_apply_from_native_fixup_args, FSRC_RATOR) define_ts_s_s(scheme_force_value_same_mark, FSRC_OTHER) define_ts_s_s(scheme_force_one_value_same_mark, FSRC_OTHER) #if defined(INLINE_FP_OPS) && !defined(CAN_INLINE_ALLOC) diff --git a/src/mzscheme/src/jit_ts_future_glue.c b/src/mzscheme/src/jit_ts_future_glue.c index 0964d32c8e..a9cbc3fff5 100644 --- a/src/mzscheme/src/jit_ts_future_glue.c +++ b/src/mzscheme/src/jit_ts_future_glue.c @@ -16,11 +16,12 @@ future->arg_s0 = g44; future->arg_i1 = g45; future->arg_S2 = g46; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall_iSs_s(const char *who, int src_type, prim_iSs_s f, int g47, Scheme_Object** g48, Scheme_Object* g49) @@ -41,11 +42,12 @@ future->arg_i0 = g47; future->arg_S1 = g48; future->arg_s2 = g49; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall_s_s(const char *who, int src_type, prim_s_s f, Scheme_Object* g50) @@ -64,11 +66,12 @@ future->source_of_request = who; future->source_type = src_type; future->arg_s0 = g50; + send_special_result(future, g50); future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall_n_s(const char *who, int src_type, prim_n_s f, Scheme_Native_Closure_Data* g51) @@ -87,11 +90,12 @@ future->source_of_request = who; future->source_type = src_type; future->arg_n0 = g51; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall__s(const char *who, int src_type, prim__s f ) @@ -110,11 +114,12 @@ future->source_of_request = who; future->source_type = src_type; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall_ss_s(const char *who, int src_type, prim_ss_s f, Scheme_Object* g52, Scheme_Object* g53) @@ -134,11 +139,12 @@ future->source_type = src_type; future->arg_s0 = g52; future->arg_s1 = g53; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } MZ_MARK_STACK_TYPE scheme_rtcall_ss_m(const char *who, int src_type, prim_ss_m f, Scheme_Object* g54, Scheme_Object* g55) @@ -158,6 +164,7 @@ future->source_type = src_type; future->arg_s0 = g54; future->arg_s1 = g55; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_m; @@ -182,11 +189,12 @@ future->source_type = src_type; future->arg_S0 = g56; future->arg_l1 = g57; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall_l_s(const char *who, int src_type, prim_l_s f, long g58) @@ -205,11 +213,12 @@ future->source_of_request = who; future->source_type = src_type; future->arg_l0 = g58; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } void scheme_rtcall_bsi_v(const char *who, int src_type, prim_bsi_v f, Scheme_Bucket* g59, Scheme_Object* g60, int g61) @@ -230,6 +239,7 @@ future->arg_b0 = g59; future->arg_s1 = g60; future->arg_i2 = g61; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; @@ -255,6 +265,7 @@ future->arg_i0 = g62; future->arg_i1 = g63; future->arg_S2 = g64; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; @@ -279,6 +290,7 @@ future->source_type = src_type; future->arg_s0 = g65; future->arg_s1 = g66; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; @@ -302,6 +314,7 @@ future->source_of_request = who; future->source_type = src_type; future->arg_b0 = g67; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; @@ -326,11 +339,12 @@ future->source_type = src_type; future->arg_s0 = g68; future->arg_l1 = g69; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall_iS_s(const char *who, int src_type, prim_iS_s f, int g70, Scheme_Object** g71) @@ -350,11 +364,12 @@ future->source_type = src_type; future->arg_i0 = g70; future->arg_S1 = g71; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } Scheme_Object* scheme_rtcall_S_s(const char *who, int src_type, prim_S_s f, Scheme_Object** g72) @@ -373,11 +388,12 @@ future->source_of_request = who; future->source_type = src_type; future->arg_S0 = g72; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } void scheme_rtcall_s_v(const char *who, int src_type, prim_s_v f, Scheme_Object* g73) @@ -396,6 +412,7 @@ future->source_of_request = who; future->source_type = src_type; future->arg_s0 = g73; + send_special_result(future, g73); future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; @@ -421,11 +438,12 @@ future->arg_i0 = g74; future->arg_S1 = g75; future->arg_i2 = g76; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_s; future->retval_s = 0; - receive_special_result(future, retval); + receive_special_result(future, retval, 1); return retval; } void scheme_rtcall_siS_v(const char *who, int src_type, prim_siS_v f, Scheme_Object* g77, int g78, Scheme_Object** g79) @@ -446,6 +464,7 @@ future->arg_s0 = g77; future->arg_i1 = g78; future->arg_S2 = g79; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; @@ -469,6 +488,7 @@ future->source_of_request = who; future->source_type = src_type; future->arg_z0 = g80; + future_do_runtimecall(fts, (void*)f, 0); future = fts->current_ft; retval = future->retval_p; diff --git a/src/mzscheme/src/jit_ts_runtime_glue.c b/src/mzscheme/src/jit_ts_runtime_glue.c index 6fa9143cb1..587134ab03 100644 --- a/src/mzscheme/src/jit_ts_runtime_glue.c +++ b/src/mzscheme/src/jit_ts_runtime_glue.c @@ -2,6 +2,7 @@ case SIG_siS_s: { prim_siS_s f = (prim_siS_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_s0, future->arg_i1, future->arg_S2); future->retval_s = retval; @@ -12,6 +13,7 @@ case SIG_iSs_s: { prim_iSs_s f = (prim_iSs_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_i0, future->arg_S1, future->arg_s2); future->retval_s = retval; @@ -22,6 +24,7 @@ case SIG_s_s: { prim_s_s f = (prim_s_s)future->prim_func; Scheme_Object* retval; + receive_special_result(future, future->arg_s0, 1); retval = f(future->arg_s0); future->retval_s = retval; @@ -32,6 +35,7 @@ case SIG_n_s: { prim_n_s f = (prim_n_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_n0); future->retval_s = retval; @@ -42,6 +46,7 @@ case SIG__s: { prim__s f = (prim__s)future->prim_func; Scheme_Object* retval; + retval = f(); future->retval_s = retval; @@ -52,6 +57,7 @@ case SIG_ss_s: { prim_ss_s f = (prim_ss_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_s0, future->arg_s1); future->retval_s = retval; @@ -62,6 +68,7 @@ case SIG_ss_m: { prim_ss_m f = (prim_ss_m)future->prim_func; MZ_MARK_STACK_TYPE retval; + retval = f(future->arg_s0, future->arg_s1); future->retval_m = retval; @@ -72,6 +79,7 @@ case SIG_Sl_s: { prim_Sl_s f = (prim_Sl_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_S0, future->arg_l1); future->retval_s = retval; @@ -82,6 +90,7 @@ case SIG_l_s: { prim_l_s f = (prim_l_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_l0); future->retval_s = retval; @@ -93,6 +102,7 @@ case SIG_bsi_v: prim_bsi_v f = (prim_bsi_v)future->prim_func; + f(future->arg_b0, future->arg_s1, future->arg_i2); @@ -103,6 +113,7 @@ case SIG_iiS_v: prim_iiS_v f = (prim_iiS_v)future->prim_func; + f(future->arg_i0, future->arg_i1, future->arg_S2); @@ -113,6 +124,7 @@ case SIG_ss_v: prim_ss_v f = (prim_ss_v)future->prim_func; + f(future->arg_s0, future->arg_s1); @@ -123,6 +135,7 @@ case SIG_b_v: prim_b_v f = (prim_b_v)future->prim_func; + f(future->arg_b0); @@ -132,6 +145,7 @@ case SIG_sl_s: { prim_sl_s f = (prim_sl_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_s0, future->arg_l1); future->retval_s = retval; @@ -142,6 +156,7 @@ case SIG_iS_s: { prim_iS_s f = (prim_iS_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_i0, future->arg_S1); future->retval_s = retval; @@ -152,6 +167,7 @@ case SIG_S_s: { prim_S_s f = (prim_S_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_S0); future->retval_s = retval; @@ -162,6 +178,7 @@ case SIG_s_v: { prim_s_v f = (prim_s_v)future->prim_func; + receive_special_result(future, future->arg_s0, 1); f(future->arg_s0); @@ -172,6 +189,7 @@ case SIG_iSi_s: { prim_iSi_s f = (prim_iSi_s)future->prim_func; Scheme_Object* retval; + retval = f(future->arg_i0, future->arg_S1, future->arg_i2); future->retval_s = retval; @@ -183,6 +201,7 @@ case SIG_siS_v: prim_siS_v f = (prim_siS_v)future->prim_func; + f(future->arg_s0, future->arg_i1, future->arg_S2); @@ -192,6 +211,7 @@ case SIG_z_p: { prim_z_p f = (prim_z_p)future->prim_func; void* retval; + retval = f(future->arg_z0); future->retval_p = retval; diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index c319f39417..5ff15d2952 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -5482,6 +5482,7 @@ static int sequential_future_MARK(void *p) { gcMARK(f->orig_lambda); gcMARK(f->running_sema); gcMARK(f->retval); + gcMARK(f->multiple_array); return gcBYTES_TO_WORDS(sizeof(future_t)); } @@ -5491,6 +5492,7 @@ static int sequential_future_FIXUP(void *p) { gcFIXUP(f->orig_lambda); gcFIXUP(f->running_sema); gcFIXUP(f->retval); + gcFIXUP(f->multiple_array); return gcBYTES_TO_WORDS(sizeof(future_t)); } diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 07c41debb4..e850efbb0b 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -2254,6 +2254,7 @@ sequential_future { gcMARK(f->orig_lambda); gcMARK(f->running_sema); gcMARK(f->retval); + gcMARK(f->multiple_array); size: gcBYTES_TO_WORDS(sizeof(future_t)); } From 37a1ada7a2661e38b44a595610f1ada30f8968e7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 02:17:53 +0000 Subject: [PATCH 76/92] add attribute value for internal links svn: r17020 --- collects/scribble/html-render.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index fcef56422f..fcbe10093b 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -43,7 +43,7 @@ ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body) "\n")))) -(define (extra-internal-attribs) null) +(define (extra-internal-attribs) '([pltdoc "x"])) (define-runtime-path scribble-css "scribble.css") (define-runtime-path scribble-style-css "scribble-style.css") From cdf940fedd38a817f6a4ee02a245058942599b60 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 06:45:26 +0000 Subject: [PATCH 77/92] url parameter utilities svn: r17026 --- collects/scribble/scribble-common.js | 36 ++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js index bfd8711f0a..1db79c96cf 100644 --- a/collects/scribble/scribble-common.js +++ b/collects/scribble/scribble-common.js @@ -1,5 +1,7 @@ // Common functionality for PLT documentation pages +// Cookies -------------------------------------------------------------------- + function GetCookie(key, def) { if (document.cookie.length <= 0) return def; var i, cookiestrs = document.cookie.split(/; */); @@ -36,6 +38,38 @@ function GotoPLTRoot(ver, relative) { return false; } +// URL Parameters ------------------------------------------------------------- + +// In the following functions, the `name' argument is assumed to be simple in +// that it doesn't contain anything that isn't plain text in a regexp. (This +// is because I don't know if there's a JS `regexp-quote' thing). Also, the +// output value from the Get functions and the input value to the Set functions +// is not decoded/encoded. Note that `SetArgInURL' mutates the string. + +function GetArgFromString(str, name) { + var rx = new RegExp("(?:^|[;&])"+name+"=([^&;]*)(?:[;&]|$)"); + return rx.test(str) && RegExp.$1; +} + +function SetArgInString(str, name, val) { + if (str.length == 0) return name + "=" + val; + var rx = new RegExp("^((?:|.*[;&])"+name+"=)(?:[^&;]*)([;&].*|)$"); + if (rx.test(str)) return RegExp.$1 + val + RegExp.$2; + else return name + "=" + val + "&" + str; +} + +function GetArgFromURL(url, name) { + if (!url.href.search(/\?([^#]*)(?:#|$)/)) return false; + return GetArgFromString(RegExp.$1, name); +} + +function SetArgInURL(url, name, val) { // note: mutates the string + url.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/); + url.href = RegExp.$1 + "?" + SetArgInString(RegExp.$2,name,val) + RegExp.$3; +} + +// Utilities ------------------------------------------------------------------ + normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/]; function NormalizePath(path) { var tmp, i; @@ -44,6 +78,8 @@ function NormalizePath(path) { return path; } +// Interactions --------------------------------------------------------------- + function DoSearchKey(event, field, ver, top_path) { var val = field.value; if (event && event.keyCode == 13) { From d94903ec535ded18f1e889356c261b792323ff5c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 06:50:02 +0000 Subject: [PATCH 78/92] use escape/unescape on the value strings svn: r17027 --- collects/scribble/scribble-common.js | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js index 1db79c96cf..e530417211 100644 --- a/collects/scribble/scribble-common.js +++ b/collects/scribble/scribble-common.js @@ -42,16 +42,18 @@ function GotoPLTRoot(ver, relative) { // In the following functions, the `name' argument is assumed to be simple in // that it doesn't contain anything that isn't plain text in a regexp. (This -// is because I don't know if there's a JS `regexp-quote' thing). Also, the -// output value from the Get functions and the input value to the Set functions -// is not decoded/encoded. Note that `SetArgInURL' mutates the string. +// is because JS doesn't have a `regexp-quote', easy to hack but not needed +// here). Also, the output value from the Get functions and the input value to +// the Set functions is decoded/encoded. Note that `SetArgInURL' mutates the +// string in the url object. function GetArgFromString(str, name) { var rx = new RegExp("(?:^|[;&])"+name+"=([^&;]*)(?:[;&]|$)"); - return rx.test(str) && RegExp.$1; + return rx.test(str) && unescape(RegExp.$1); } function SetArgInString(str, name, val) { + val = escape(val); if (str.length == 0) return name + "=" + val; var rx = new RegExp("^((?:|.*[;&])"+name+"=)(?:[^&;]*)([;&].*|)$"); if (rx.test(str)) return RegExp.$1 + val + RegExp.$2; From 212eb82314ee76f3cce47b718e71ae51193c6501 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 06:52:40 +0000 Subject: [PATCH 79/92] use the utility function for the query parameter svn: r17028 --- collects/scribblings/main/private/search.js | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js index 042f404ca0..baa8960d01 100644 --- a/collects/scribblings/main/private/search.js +++ b/collects/scribblings/main/private/search.js @@ -226,17 +226,8 @@ function InitializeSearch() { result_links.push(n); AdjustResultsNum(); // get search string - if (location.search.length > 0) { - var paramstrs = location.search.substring(1).split(/[;&]/); - for (var i=0; i Date: Tue, 24 Nov 2009 08:09:20 +0000 Subject: [PATCH 80/92] nicer display for variants svn: r17029 --- collects/setup/setup-unit.ss | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 40be5fab54..0cd6a7f0ca 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -76,9 +76,8 @@ (setup-printf "version" "~a [~a]" (version) (system-type 'gc)) (setup-printf "variants" "~a" - (apply string-append - (map (lambda (s) (format " ~a" s)) - (available-mzscheme-variants)))) + (string-join (map symbol->string (available-mzscheme-variants)) + ", ")) (setup-printf "main collects" "~a" (path->string main-collects-dir)) (setup-printf "collects paths" (if (null? (current-library-collection-paths)) " empty!" "")) From 9cd997af37f17d2f9767d97379b0df262088daa5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 08:25:42 +0000 Subject: [PATCH 81/92] adjust for new link attribute, fix error message svn: r17030 --- collects/scribblings/main/private/make-search.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/main/private/make-search.ss b/collects/scribblings/main/private/make-search.ss index 483d41466e..7b986a6f15 100644 --- a/collects/scribblings/main/private/make-search.ss +++ b/collects/scribblings/main/private/make-search.ss @@ -111,7 +111,7 @@ [e (make-link-element "indexlink" e tag)] [e (send renderer render-content e sec ri)]) (match e ; should always render to a single `a' - [`((a ([href ,href] [class "indexlink"]) . ,body)) + [`((a ([href ,href] [class "indexlink"] [pltdoc ,_]) . ,body)) (cond [(and (part-index-desc? desc) (regexp-match #rx"(?:^|/)([^/]+)/index\\.html$" href)) => (lambda (man) (hash-set! manual-refs (cadr man) idx))]) @@ -121,10 +121,11 @@ (if (regexp-match? #rx"^Provided from: " label) body ;; if this happens, this code should be updated - (error "internal error: unexpected tooltip"))] + (error 'make-script + "internal error: unexpected tooltip"))] [else body])]) (values (compact-url href) (compact-body body)))] - [else (error "unexpected value rendered: ~e" e)]))) + [else (error 'make-script "unexpected value rendered: ~e" e)]))) (define (lib->name lib) (quote-string (let loop ([lib lib]) (match lib From 6d19862ce7735350517c590c1738c1b5937f1c18 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 08:36:42 +0000 Subject: [PATCH 82/92] use some new stuffs svn: r17031 --- collects/setup/setup-unit.ss | 97 +++++++++++++++++------------------- 1 file changed, 45 insertions(+), 52 deletions(-) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 0cd6a7f0ca..af82903506 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -135,16 +135,14 @@ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define x-specific-collections - (apply append - (specific-collections) - (map (lambda (x) - (unpack x - (build-path main-collects-dir 'up) - (lambda (s) (setup-printf #f "~a" s)) - (current-target-directory-getter) - (force-unpacks) - (current-target-plt-directory-getter))) - (archives)))) + (append* (specific-collections) + (for/list ([x (in-list (archives))]) + (unpack x + (build-path main-collects-dir 'up) + (lambda (s) (setup-printf #f "~a" s)) + (current-target-directory-getter) + (force-unpacks) + (current-target-plt-directory-getter))))) ;; specific-planet-dir ::= ;; - (list path[directory] string[owner] string[package-name] (listof string[extra package path]) Nat[maj] Nat[min]), or @@ -853,49 +851,44 @@ kind mzlns))] [(and (or (not mzlls) (= (length mzlns) (length mzlls))) (or (not mzlfs) (= (length mzlns) (length mzlfs)))) - (for-each - (lambda (mzln mzll mzlf) - (let ([p (program-launcher-path mzln)] - [aux (list* `(exe-name . ,mzln) - '(framework-root . #f) - '(dll-dir . #f) - `(relative? . ,(not absolute-installation?)) - (build-aux-from-path - (build-path (cc-path cc) - (path-replace-suffix - (or mzll mzln) - #""))))]) - (unless (up-to-date? p aux) - (setup-printf - "launcher" - "~a~a" - (path->name p #:prefix (format "~a-bin" kind) - #:base (if (equal? kind 'console) - find-console-bin-dir - find-gui-bin-dir)) - (let ([v (current-launcher-variant)]) - (if (eq? v (system-type 'gc)) "" (format " [~a]" v)))) - (make-launcher - (or mzlf - (if (cc-collection cc) - (list "-l-" (string-append - (apply string-append - (map (lambda (s) - (string-append - (if (path? s) - (path->string s) - s) - "/")) - (cc-collection cc))) - mzll)) - (list "-t-" (path->string (build-path (cc-path cc) mzll))))) - p - aux)))) - mzlns - (or mzlls (map (lambda (_) #f) mzlns)) - (or mzlfs (map (lambda (_) #f) mzlns)))] + (for ([mzln (in-list mzlns)] + [mzll (in-list (or mzlls (map (lambda (_) #f) mzlns)))] + [mzlf (in-list (or mzlfs (map (lambda (_) #f) mzlns)))]) + (let ([p (program-launcher-path mzln)] + [aux (list* `(exe-name . ,mzln) + '(framework-root . #f) + '(dll-dir . #f) + `(relative? . ,(not absolute-installation?)) + (build-aux-from-path + (build-path (cc-path cc) + (path-replace-suffix + (or mzll mzln) + #""))))]) + (unless (up-to-date? p aux) + (setup-printf + "launcher" + "~a~a" + (path->name p #:prefix (format "~a-bin" kind) + #:base (if (equal? kind 'console) + find-console-bin-dir + find-gui-bin-dir)) + (let ([v (current-launcher-variant)]) + (if (eq? v (system-type 'gc)) "" (format " [~a]" v)))) + (make-launcher + (or mzlf + (if (cc-collection cc) + (list "-l-" (string-append + (string-append* + (map (lambda (s) (format "~a/" s)) + (cc-collection cc))) + mzll)) + (list "-t-" (path->string (build-path (cc-path cc) mzll))))) + p + aux))))] [else - (let ([fault (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)]) + (let ([fault (if (or (not mzlls) + (= (length mzlns) (length mzlls))) + 'f 'l)]) (setup-printf "WARNING" "~s launcher name list ~s doesn't match ~a list; ~s" From 142d33d67f3e7e67e5c613fbbb81beb842b299ba Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 09:11:09 +0000 Subject: [PATCH 83/92] Make it possible to register multiple onload handlers. (Needed because all pages must have an onload, and the search page needs an additional initialization function.) svn: r17032 --- collects/scribble/html-render.ss | 4 ++-- collects/scribble/scribble-common.js | 17 ++++++++++++++--- collects/scribblings/main/private/search.js | 2 +- 3 files changed, 17 insertions(+), 6 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index fcbe10093b..1e36b257e7 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -611,8 +611,8 @@ (list style-file) style-extra-files)) ,(scribble-js-contents script-file (lookup-path script-file alt-paths))) - (body ((id ,(or (extract-part-body-id d ri) - "scribble-plt-scheme-org"))) + (body ([id ,(or (extract-part-body-id d ri) + "scribble-plt-scheme-org")]) ,@(render-toc-view d ri) (div ([class "maincolumn"]) (div ([class "main"]) diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js index e530417211..4ff914dc00 100644 --- a/collects/scribble/scribble-common.js +++ b/collects/scribble/scribble-common.js @@ -80,6 +80,10 @@ function NormalizePath(path) { return path; } +// `noscript' is problematic in some browsers (always renders as a +// block), use this hack instead (does not always work!) +// document.write(""); + // Interactions --------------------------------------------------------------- function DoSearchKey(event, field, ver, top_path) { @@ -100,6 +104,13 @@ function TocviewToggle(glyph,id) { glyph.innerHTML = expand ? "▼" : "►"; } -// `noscript' is problematic in some browsers (always renders as a -// block), use this hack instead (does not always work!) -// document.write(""); +// Page Init ------------------------------------------------------------------ + +// Note: could make a function that inspects and uses window.onload to chain to +// a previous one, but this file needs to be required first anyway, since it +// contains utilities for all other files. +var on_load_funcs = []; +function AddOnLoad(fun) { on_load_funcs.push(fun); } +window.onload = function() { + for (var i=0; i Date: Tue, 24 Nov 2009 10:13:04 +0000 Subject: [PATCH 84/92] fix JIT stack-chain caching for PPC (merge to 4.2.3) svn: r17033 --- src/mzscheme/src/jit.c | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 86bbf0d048..95859ffeb2 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -1230,7 +1230,7 @@ static void _jit_prolog_again(mz_jit_state *jitter, int n, int ret_addr_reg) since the call (which also pushed), so if the stack was 16-bytes aligned before the call, it is current stack pointer is 1 word (either 4 or 8 bytes) below alignment (need to push 3 or 1 words to - re-align). Also, for a call without a prolog, th stack pointer is + re-align). Also, for a call without a prolog, the stack pointer is 1 word (for the return address) below alignment. */ # define JIT_LOCAL1 -(JIT_WORD_SIZE * 4) # define JIT_LOCAL2 -(JIT_WORD_SIZE * 5) @@ -4586,7 +4586,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj /* watch out for most negative fixnum! */ if (!unsafe_fx) (void)jit_beqi_p(refslow, JIT_R0, (void *)(((long)1 << ((8 * JIT_WORD_SIZE) - 1)) | 0x1)); - jit_movi_p(JIT_R1, scheme_make_integer(0)); + (void)jit_movi_p(JIT_R1, scheme_make_integer(0)); jit_subr_l(JIT_R0, JIT_R1, JIT_R0); jit_ori_l(JIT_R0, JIT_R0, 0x1); __START_INNER_TINY__(branch_short); @@ -8408,6 +8408,10 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) is such a register for PPC. */ stack_cache_pop_code = jit_get_ip().ptr; jit_movr_p(JIT_R0, JIT_RET); +#ifdef MZ_USE_JIT_PPC + jit_subi_p(JIT_SP, JIT_SP, 48); /* includes space maybe used by callee */ + jit_stxi_p(44, JIT_SP, JIT_AUX); +#endif /* Decrement stack_cache_stack_pos (using a function, in case of thread-local vars) and get record pointer. Use jit_normal_finish(), because jit_finish() shuffles @@ -8417,18 +8421,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R0); (void)jit_normal_finish(decrement_cache_stack_pos); jit_retval(JIT_R1); /* = pointer to a stack_cache_stack element */ -#ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_R(3), JIT_AUX); -#endif CHECK_LIMIT(); /* Extract old return address and jump to it */ jit_ldxi_l(JIT_R0, JIT_R1, (int)&((Stack_Cache_Elem *)0x0)->orig_result); - jit_movi_p(JIT_R2, NULL); + (void)jit_movi_p(JIT_R2, NULL); jit_stxi_l((int)&((Stack_Cache_Elem *)0x0)->orig_result, JIT_R1, JIT_R2); jit_ldxi_l(JIT_R2, JIT_R1, (int)&((Stack_Cache_Elem *)0x0)->orig_return_address); jit_movr_p(JIT_RET, JIT_R0); #ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_AUX, JIT_R(3)); + jit_ldxi_p(JIT_AUX, JIT_SP, 44); + jit_addi_p(JIT_SP, JIT_SP, 48); #endif jit_jmpr(JIT_R2); CHECK_LIMIT(); @@ -9158,7 +9160,6 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R0); (void)mz_finish(scheme_module_run_finish); CHECK_LIMIT(); - jit_retval(JIT_R0); mz_pop_locals(); jit_ret(); CHECK_LIMIT(); @@ -9191,7 +9192,6 @@ static int do_generate_more_common(mz_jit_state *jitter, void *_data) jit_pusharg_p(JIT_R0); (void)mz_finish(scheme_module_start_finish); CHECK_LIMIT(); - jit_retval(JIT_R0); mz_pop_locals(); jit_ret(); CHECK_LIMIT(); @@ -10187,7 +10187,7 @@ Scheme_Object *scheme_native_stack_trace(void) on frames where the previous frame had a return address with a name, because an arbitrary frame's return address on the stack might not be used (depending on how the C compiler optimized the - cdode); any frame whose procedure has a name is JITted code, so + code); any frame whose procedure has a name is JITted code, so it will use the return address from the stack. */ if (STK_COMP((unsigned long)halfway, (unsigned long)p) && prev_had_name) { From 825a47dfefde43fb64dc29266c4ed6cdf971f0f9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 12:33:15 +0000 Subject: [PATCH 85/92] A `lang' parameter gets carried through the pages. svn: r17037 --- collects/scribble/scribble-common.js | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js index 4ff914dc00..4695375d4b 100644 --- a/collects/scribble/scribble-common.js +++ b/collects/scribble/scribble-common.js @@ -97,7 +97,7 @@ function DoSearchKey(event, field, ver, top_path) { return true; } -function TocviewToggle(glyph,id) { +function TocviewToggle(glyph, id) { var s = document.getElementById(id).style; var expand = s.display == "none"; s.display = expand ? "block" : "none"; @@ -114,3 +114,19 @@ function AddOnLoad(fun) { on_load_funcs.push(fun); } window.onload = function() { for (var i=0; i Date: Tue, 24 Nov 2009 13:34:12 +0000 Subject: [PATCH 86/92] CSS for the langindicator widget svn: r17038 --- collects/scribble/scribble.css | 32 ++++++++++++++++++++++---------- 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index c610d0dcd5..cb71c09c9d 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -77,14 +77,14 @@ table td { padding: 0.25em 0 0.25em 0; } -.navsettop { - margin-bottom: 1.5em; - border-bottom: 2px solid #e0e0c0; +.navsettop { + margin-bottom: 1.5em; + border-bottom: 2px solid #e0e0c0; } -.navsetbottom { - margin-top: 2em; - border-top: 2px solid #e0e0c0; +.navsetbottom { + margin-top: 2em; + border-top: 2px solid #e0e0c0; } .navleft { @@ -119,6 +119,18 @@ table td { vertical-align: middle; } +#langindicator { + position: fixed; + background-color: #c6f; + color: #000; + font-family: monospace; + font-weight: bold; + padding: 2px 10px; + display: none; + right: 0; + bottom: 0; +} + /* ---------------------------------------- */ /* Version */ @@ -224,11 +236,11 @@ table td { padding-left: 0.8em; } .tocviewsublist { - margin-bottom: 1em; + margin-bottom: 1em; } -.tocviewsublist table, +.tocviewsublist table, .tocviewsublistonly table, -.tocviewsublisttop table, +.tocviewsublisttop table, .tocviewsublistbottom table { font-size: 75%; } @@ -411,4 +423,4 @@ i { .author { display: inline; white-space: nowrap; -} \ No newline at end of file +} From bd1ba85221eaa7a31a72672af3d998e84f8b5f21 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 13:37:04 +0000 Subject: [PATCH 87/92] use the langindicator when there's a lang parameter svn: r17039 --- collects/scribble/scribble-common.js | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/scribble/scribble-common.js b/collects/scribble/scribble-common.js index 4695375d4b..13b1dfa07a 100644 --- a/collects/scribble/scribble-common.js +++ b/collects/scribble/scribble-common.js @@ -127,6 +127,11 @@ function PropagateLangInLink(a) { AddOnLoad(function(){ if (!cur_plt_lang) return; + var indicator = document.getElementById("langindicator"); + if (indicator) { + indicator.innerHTML = cur_plt_lang; + indicator.style.display = "block"; + } var links = document.getElementsByTagName("a"); for (var i=0; i Date: Tue, 24 Nov 2009 13:38:15 +0000 Subject: [PATCH 88/92] add the indicator div svn: r17040 --- collects/scribble/html-render.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 1e36b257e7..246cb59d5b 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -620,7 +620,8 @@ (render-version d ri)) ,@(navigation d ri #t) ,@(render-part d ri) - ,@(navigation d ri #f))))))))))) + ,@(navigation d ri #f))) + (div ([id "langindicator"]) nbsp))))))))) (define/private (part-parent d ri) (collected-info-parent (part-collected-info d ri))) From 7feecb4d2cd43e9407c70beff5a61f3333eebe35 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 14:17:48 +0000 Subject: [PATCH 89/92] Remove `extra-internal-attribs' and just use the value directly. (Renaming it is the same as renaming a variable anyway.) Add the attribute to the navigation links. svn: r17041 --- collects/scribble/html-render.ss | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 246cb59d5b..0acb2aff7b 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -43,8 +43,6 @@ ,@(map (lambda (x) (if (string? x) x (format "~a" x))) body) "\n")))) -(define (extra-internal-attribs) '([pltdoc "x"])) - (define-runtime-path scribble-css "scribble.css") (define-runtime-path scribble-style-css "scribble-style.css") (define-runtime-path scribble-prefix-html "scribble-prefix.html") @@ -362,7 +360,7 @@ [class ,(if (or (eq? t d) (and show-mine? (memq t toc-chain))) "tocviewselflink" "tocviewlink")] - ,@(extra-internal-attribs)) + [pltdoc "x"]) ,@(render-content (or (part-title-content t) '("???")) d ri))) (format-number (collected-info-number (part-collected-info t ri)) '(nbsp)))) @@ -532,7 +530,7 @@ [(part? p) "tocsubseclink"] [any-parts? "tocsubnonseclink"] [else "tocsublink"])] - ,@(extra-internal-attribs)) + [pltdoc "x"]) ,@(render-content (if (part? p) (or (part-title-content p) @@ -710,6 +708,7 @@ (make-target-url url) (make-attributes `([title . ,(if title* (string-append label " to " title*) label)] + [pltdoc . "x"] ,@more))))) (define top-link (titled-url @@ -993,7 +992,7 @@ ;; Normal link: (dest->url dest)])) ,@(attribs) - ,@(extra-internal-attribs)] + [pltdoc "x"]] ,@(if (empty-content? (element-content e)) (render-content (strip-aux (dest-title dest)) part ri) (render-content (element-content e) part ri)))) From 615744073c8e25d7de4e9ad20a5f9c7cb0db2b5e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 14:36:00 +0000 Subject: [PATCH 90/92] thread lang parameter through the main pages too svn: r17042 --- collects/scribblings/main/private/utils.ss | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/main/private/utils.ss b/collects/scribblings/main/private/utils.ss index bdc3b7b585..10010e52ea 100644 --- a/collects/scribblings/main/private/utils.ss +++ b/collects/scribblings/main/private/utils.ss @@ -103,13 +103,18 @@ [(#f) path] [else (error "internal error (main-page)")])) (define (onclick style) - (if (eq? root 'user) - (make-style style - (list (make-attributes - `([onclick - . ,(format "return GotoPLTRoot(\"~a\", \"~a\");" - (version) path)])))) - style)) + (make-style + style + (list (make-attributes + `(,@(if (eq? root 'user) + `([onclick + . ,(format "return GotoPLTRoot(\"~a\", \"~a\");" + (version) path)]) + `()) + ;; note: root=#f means an external link, but in this + ;; case this is the bugs link, so *keep* it and later + ;; use it on the bugs page + [pltdoc . "x"]))))) (define (elt style) (make-toc-element #f null (list (hyperlink dest #:style (onclick style) text)))) From 831bac8ee3b600760e5377d1c6591d3063bab378 Mon Sep 17 00:00:00 2001 From: Kevin Tew Date: Tue, 24 Nov 2009 14:58:40 +0000 Subject: [PATCH 91/92] put/getenv performance fix attempt svn: r17043 --- src/mzscheme/src/string.c | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/src/mzscheme/src/string.c b/src/mzscheme/src/string.c index 2408d86da3..19a0beaed5 100644 --- a/src/mzscheme/src/string.c +++ b/src/mzscheme/src/string.c @@ -383,7 +383,6 @@ scheme_init_string (Scheme_Env *env) platform_3m_path = scheme_make_path(SCHEME_PLATFORM_LIBRARY_SUBPATH MZ3M_SUBDIR); REGISTER_SO(putenv_str_table); - putenv_str_table = scheme_make_hash_table(SCHEME_hash_string); REGISTER_SO(embedding_banner); REGISTER_SO(current_locale_name); @@ -1980,8 +1979,12 @@ int scheme_any_string_has_null(Scheme_Object *o) } } +/***********************************************************************/ +/* Environment Variables */ +/***********************************************************************/ + #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) -static char* clone_str_with_gc(char* buffer) { +static char* clone_str_with_gc(const char* buffer) { int length; char *newbuffer; length = strlen(buffer); @@ -1991,16 +1994,24 @@ static char* clone_str_with_gc(char* buffer) { } #endif +static void create_putenv_str_table_if_needed() { + if (!putenv_str_table) { + putenv_str_table = scheme_make_hash_table(SCHEME_hash_string); + } +} + #ifndef DOS_FILE_SYSTEM static void putenv_str_table_put_name(Scheme_Object *name, Scheme_Object *value) { #if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC) void *original_gc; Scheme_Object *name_copy; original_gc = GC_switch_to_master_gc(); - name_copy = clone_str_with_gc(name); + name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name); + create_putenv_str_table_if_needed(); scheme_hash_set(putenv_str_table, name_copy, value); GC_switch_back_from_master(original_gc); #else + create_putenv_str_table_if_needed(); scheme_hash_set(putenv_str_table, name, value); #endif } @@ -2013,11 +2024,13 @@ static void putenv_str_table_put_name_value(Scheme_Object *name, Scheme_Object * Scheme_Object *name_copy; Scheme_Object *value_copy; original_gc = GC_switch_to_master_gc(); - name_copy = clone_str_with_gc(name); - value_copy = clone_str_with_gc(value); + name_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) name); + value_copy = (Scheme_Object *) clone_str_with_gc((Scheme_Object *) value); + create_putenv_str_table_if_needed(); scheme_hash_set(putenv_str_table, name_copy, value_copy); GC_switch_back_from_master(original_gc); #else + create_putenv_str_table_if_needed(); scheme_hash_set(putenv_str_table, name, value); #endif } @@ -2029,10 +2042,12 @@ static Scheme_Object *putenv_str_table_get(Scheme_Object *name) { void *original_gc; Scheme_Object *value; original_gc = GC_switch_to_master_gc(); + create_putenv_str_table_if_needed(); value = scheme_hash_get(putenv_str_table, name); GC_switch_back_from_master(original_gc); return value; #else + create_putenv_str_table_if_needed(); return scheme_hash_get(putenv_str_table, name); #endif } @@ -2207,6 +2222,10 @@ static Scheme_Object *sch_putenv(int argc, Scheme_Object *argv[]) return rc ? scheme_false : scheme_true; } +/***********************************************************************/ +/* End Environment Variables */ +/***********************************************************************/ + static void machine_details(char *s); static Scheme_Object *system_type(int argc, Scheme_Object *argv[]) From dccc4bcb953885505eafd326923714408bc556e3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Nov 2009 15:13:55 +0000 Subject: [PATCH 92/92] thread lang parameter through search results svn: r17044 --- collects/scribblings/main/private/search.js | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/main/private/search.js b/collects/scribblings/main/private/search.js index 2baa444262..e0aeda00aa 100644 --- a/collects/scribblings/main/private/search.js +++ b/collects/scribblings/main/private/search.js @@ -599,6 +599,7 @@ function UpdateResults() { if (first_search_result < 0 || first_search_result >= search_results.length) first_search_result = 0; + var link_lang = (cur_plt_lang && ("?lang="+escape(cur_plt_lang))); for (var i=0; i'; + var href = UncompactUrl(res[1]); + if (link_lang) { + var hash = href.indexOf("#"); + if (hash >= 0) + href = href.substring(0,hash) + link_lang + href.substring(hash); + else + href = href + link_lang; + } result_links[i].innerHTML = - '' + '' + UncompactHtml(res[2]) + '' + (note || ""); result_links[i].style.backgroundColor = (n < exact_results_num) ? highlight_color : background_color;