diff --git a/CHANGELOG.md b/CHANGELOG.md index 271caee3..a017e4fa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,20 @@ # Changelog -## 0.14 - TBD +## 0.14 - February 11, 2020 + +Cyclone now automatically relocates any stack objects when performing a mutation. This prevents a whole range of race conditions that had previously been possible in multithreaded application code. And since this work is done by the Cyclone runtime no special code needs to be added to your applications. + +Special thanks to Daniel Mendler, whose discussions were the inspiration for these changes. + +Some background: + +There was a long-standing issue where a mutation (via `set-car!`, `vector-set!`, `set!`, etc) could allow a global object on the heap to reference objects on a thread's local stack. This is problematic because threads periodically relocate objects from their stack, and for performance reasons these objects are moved without any coordination between threads. Thus it is critical that objects on the stack are only used by the thread that owns them. + +In the past we provided functions such as `make-shared` that could be called from application code to guarantee safety. However, this approach is error-prone and asks too much of anyone using Cyclone for multithreaded development. The proper solution is for Cyclone to avoid this situation in the first place. + +Other Features + + - Added `CYC_HIGH_RES_TIMERS` to the runtime code to allow logging of timer information for the GC. Note this can be passed to the C compiler via the `-D` option. ## 0.12 - January 17, 2020 diff --git a/Makefile.config b/Makefile.config index 079ca31a..1c180719 100644 --- a/Makefile.config +++ b/Makefile.config @@ -8,6 +8,7 @@ CYC_PROFILING ?= #CYC_PROFILING ?= -g -pg +#CYC_PROFILING ?= -DCYC_HIGH_RES_TIMERS CYC_GCC_OPT_FLAGS ?= -O2 #CYC_GCC_OPT_FLAGS ?= -g diff --git a/examples/threading/sum-mutex.scm b/examples/threading/sum-mutex.scm index 3697ada5..6233f717 100644 --- a/examples/threading/sum-mutex.scm +++ b/examples/threading/sum-mutex.scm @@ -11,7 +11,7 @@ (define (sum-loop n) (mutex-lock! m) - (set! *sum* (make-shared (+ *sum* 1))) + (set! *sum* (+ *sum* 1)) (mutex-unlock! m) ;(swap! *sum* + 1) (if (zero? n) diff --git a/gc.c b/gc.c index 92786e55..abfec252 100644 --- a/gc.c +++ b/gc.c @@ -1144,6 +1144,9 @@ void gc_start_major_collection(gc_thread_data *thd){ void *gc_try_alloc_slow(gc_heap *h_passed, gc_heap *h, int heap_type, size_t size, char *obj, gc_thread_data *thd) { +#ifdef CYC_HIGH_RES_TIMERS +long long tstamp = hrt_get_current(); +#endif gc_heap *h_start = h, *h_prev; void *result = NULL; // Find next heap @@ -1169,8 +1172,15 @@ void *gc_try_alloc_slow(gc_heap *h_passed, gc_heap *h, int heap_type, size_t siz // prev_free_size = h_size; // Full size was cached //} gc_heap *keep = gc_sweep(h, heap_type, thd); // Clean up garbage objects +#ifdef CYC_HIGH_RES_TIMERS +fprintf(stderr, "sweep heap %p \n", h); +hrt_log_delta("gc sweep", tstamp); +#endif h_passed->num_unswept_children--; if (!keep) { +#if GC_DEBUG_TRACE + fprintf(stderr, "heap %p marked for deletion\n", h); +#endif // Heap marked for deletion, remove it and keep searching gc_heap *freed = gc_heap_free(h, h_prev); if (freed) { @@ -1207,6 +1217,9 @@ void *gc_try_alloc_slow(gc_heap *h_passed, gc_heap *h, int heap_type, size_t siz } else { // TODO: else, assign heap full? YES for fixed-size, for REST maybe not?? h->is_full = 1; +#if GC_DEBUG_TRACE + fprintf(stderr, "heap %p is full\n", h); +#endif } } return result; @@ -1262,6 +1275,9 @@ static void *gc_try_alloc_fixed_size(gc_heap * h, int heap_type, size_t size, ch void *gc_try_alloc_slow_fixed_size(gc_heap *h_passed, gc_heap *h, int heap_type, size_t size, char *obj, gc_thread_data *thd) { +#ifdef CYC_HIGH_RES_TIMERS +long long tstamp = hrt_get_current(); +#endif gc_heap *h_start = h, *h_prev; void *result = NULL; // Find next heap @@ -1283,8 +1299,15 @@ void *gc_try_alloc_slow_fixed_size(gc_heap *h_passed, gc_heap *h, int heap_type, } else if (h->is_unswept == 1 && !gc_is_heap_empty(h)) { unsigned int h_size = h->size; gc_heap *keep = gc_sweep_fixed_size(h, heap_type, thd); // Clean up garbage objects +#ifdef CYC_HIGH_RES_TIMERS +fprintf(stderr, "sweep fixed size heap %p size %lu \n", h, size); +hrt_log_delta("gc sweep fixed size", tstamp); +#endif h_passed->num_unswept_children--; if (!keep) { +#if GC_DEBUG_TRACE + fprintf(stderr, "heap %p marked for deletion\n", h); +#endif // Heap marked for deletion, remove it and keep searching gc_heap *freed = gc_heap_free(h, h_prev); if (freed) { @@ -1306,6 +1329,9 @@ void *gc_try_alloc_slow_fixed_size(gc_heap *h_passed, gc_heap *h, int heap_type, } else { // TODO: else, assign heap full? YES for fixed-size, for REST maybe not?? h->is_full = 1; +#if GC_DEBUG_TRACE + fprintf(stderr, "heap %p is full\n", h); +#endif } } return result; diff --git a/include/cyclone/runtime.h b/include/cyclone/runtime.h index 55d99286..93608603 100644 --- a/include/cyclone/runtime.h +++ b/include/cyclone/runtime.h @@ -105,8 +105,13 @@ void set_env_variables(char **vars); object cell_get(object cell); -#define global_set(glo,value) Cyc_global_set(data, (object *)&glo, value) -object Cyc_global_set(void *thd, object * glo, object value); +#define global_set(glo,value) Cyc_global_set(data, NULL, (object *)&glo, value) +#define global_set_id(id,glo,value) Cyc_global_set(data, id, (object *)&glo, value) +object Cyc_global_set(void *thd, object sym, object * glo, object value); + +#define global_set_cps(thd,k,glo,value) Cyc_global_set_cps(thd, k, NULL, (object *)&glo, value) +#define global_set_cps_id(thd,k,id,glo,value) Cyc_global_set_cps(thd, k, id, (object *)&glo, value) +object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo, object value); /* Variable argument count support @@ -491,6 +496,8 @@ object Cyc_vector_ref(void *d, object v, object k); ((vector) v)->elements[obj_obj2int(k)] object Cyc_vector_set(void *d, object v, object k, object obj); object Cyc_vector_set_unsafe(void *d, object v, object k, object obj); +object Cyc_vector_set_cps(void *d, object cont, object v, object k, object obj); +object Cyc_vector_set_unsafe_cps(void *d, object cont, object v, object k, object obj); object Cyc_make_vector(void *data, object cont, int argc, object len, ...); /**@}*/ @@ -782,7 +789,7 @@ object register_library(const char *name); */ /**@{*/ extern list global_table; -void add_global(object * glo); +void add_global(const char *identifier, object * glo); void Cyc_set_globals_changed(gc_thread_data *thd); /**@}*/ @@ -837,6 +844,8 @@ list malloc_make_pair(object, object); object Cyc_set_cell(void *, object l, object val); object Cyc_set_car(void *, object l, object val); object Cyc_set_cdr(void *, object l, object val); +object Cyc_set_car_cps(void *, object cont, object l, object val); +object Cyc_set_cdr_cps(void *, object cont, object l, object val); object Cyc_length(void *d, object l); object Cyc_length_unsafe(void *d, object l); object Cyc_list2vector(void *data, object cont, object l); diff --git a/include/cyclone/types.h b/include/cyclone/types.h index e377e47a..7eedefad 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -22,6 +22,17 @@ #include #include "cyclone/bignum.h" +#ifdef CYC_HIGH_RES_TIMERS +/** + * \defgroup hrt High resolution timers + */ +/**@{*/ +long long hrt_get_current(); +long long hrt_cmp_current(long long tstamp); +void hrt_log_delta(const char *label, long long tstamp); +/**@}*/ +#endif + /** * Generic object type * \ingroup objects @@ -524,6 +535,14 @@ void add_mutation(void *data, object var, int index, object value); void clear_mutations(void *data); /**@}*/ +/** + * \defgroup gc_minor_sh_obj Shared object write barrier + * @brief Minor GC write barrier to ensure there are no references to stack objects from the heap. + */ +/**@{*/ +object transport_stack_value(gc_thread_data *data, object var, object value, int *run_gc); +/**@}*/ + /**@}*/ // END GC section diff --git a/runtime.c b/runtime.c index be4a2974..95dfa0ad 100644 --- a/runtime.c +++ b/runtime.c @@ -9,6 +9,7 @@ */ #include +#include #include #include "cyclone/types.h" #include "cyclone/runtime.h" @@ -22,14 +23,6 @@ static uint32_t Cyc_utf8_decode(uint32_t* state, uint32_t* codep, uint32_t byte); static int Cyc_utf8_count_code_points_and_bytes(uint8_t* s, char_type *codepoint, int *cpts, int *bytes); -object Cyc_global_set(void *thd, object * glo, object value) -{ - gc_mut_update((gc_thread_data *) thd, *glo, value); - *(glo) = value; - ((gc_thread_data *) thd)->globals_changed = 1; - return value; -} - /* Error checking section - type mismatch, num args, etc */ /* Type names to use for error messages */ const char *tag_names[] = { @@ -99,6 +92,39 @@ void Cyc_check_bounds(void *data, const char *label, int len, int index) /* END error checking */ +#ifdef CYC_HIGH_RES_TIMERS +/* High resolution timers */ +#include +long long hrt_get_current() +{ + struct timeval tv; + gettimeofday(&tv, NULL); /* TODO: longer-term consider using clock_gettime instead */ + long long jiffy = (tv.tv_sec)*1000000LL + tv.tv_usec; + return jiffy; +} + +long long hrt_cmp_current(long long tstamp) +{ + long long now = hrt_get_current(); + return (now - tstamp); +} + +void hrt_log_delta(const char *label, long long tstamp) +{ + static long long initial = 1; + static long long initial_tstamp; + if (initial == 1) { + initial = 0; + initial_tstamp = hrt_get_current(); + } + long long total = hrt_cmp_current(initial_tstamp); + long long delta = hrt_cmp_current(tstamp); + fprintf(stderr, "%s, %llu, %llu\n", label, total, delta); +} + +/* END High resolution timers */ +#endif + /* These macros are hardcoded here to support functions in this module. */ #define closcall1(td, clo, a1) \ if (obj_is_not_closure(clo)) { \ @@ -302,6 +328,8 @@ void gc_init_heap(long heap_size) fprintf(stderr, "Unable to initialize symbol_table_lock mutex\n"); exit(1); } + + //ht_test(); // JAE - DEBUGGING!! } object cell_get(object cell) @@ -310,6 +338,46 @@ object cell_get(object cell) return car(cell); } +object Cyc_global_set(void *thd, object identifier, object * glo, object value) +{ + gc_mut_update((gc_thread_data *) thd, *glo, value); + *(glo) = value; + ((gc_thread_data *) thd)->globals_changed = 1; + return value; +} + +static void Cyc_global_set_cps_gc_return(void *data, int argc, object cont, object glo_obj, object val, object next) +{ + object *glo = (object *)glo_obj; + *(glo) = val; + closcall1(data, (closure)next, val); +} + +object Cyc_global_set_cps(void *thd, object cont, object identifier, object * glo, object value) +{ + int do_gc = 0; + value = transport_stack_value(thd, NULL, value, &do_gc); // glo cannot be thread-local! + gc_mut_update((gc_thread_data *) thd, *glo, value); + if (do_gc) { + // Ensure global is a root. We need to do this here to ensure + // global and all its children are relocated to the heap. + cvar_type cv = { {0}, cvar_tag, glo }; + gc_thread_data *data = (gc_thread_data *) thd; + data->mutations = vpbuffer_add(data->mutations, + &(data->mutation_buflen), + data->mutation_count, + &cv); + data->mutation_count++; + // Run GC, then do the actual assignment with heap objects + mclosure0(clo, (function_type)Cyc_global_set_cps_gc_return); + object buf[3]; buf[0] = (object)glo; buf[1] = value; buf[2] = cont; + GC(data, &clo, buf, 3); + } + *(glo) = value; // Already have heap objs, do assignment now + return value; +} + + static boolean_type t_boolean = { {0}, boolean_tag, "t" }; static boolean_type f_boolean = { {0}, boolean_tag, "f" }; static symbol_type Cyc_void_symbol = { {0}, symbol_tag, ""}; @@ -428,7 +496,7 @@ object register_library(const char *name) /* Global table */ list global_table = NULL; -void add_global(object * glo) +void add_global(const char *identifier, object * glo) { // Tried using a vpbuffer for this and the benchmark // results were the same or worse. @@ -462,6 +530,67 @@ void Cyc_set_globals_changed(gc_thread_data *thd) /* END Global table */ +/** new write barrier + * This function determines if a mutation introduces a pointer to a stack + * object from a heap object, and if so, either copies the object to the + * heap or lets the caller know a minor GC must be performed. + * + * @param data Current thread's data object + * @param var Object being mutated + * @param value New value being associated to var + * @param run_gc OUT parameter, returns 1 if minor GC needs to be invoked + * @return Pointer to `var` object + */ +object transport_stack_value(gc_thread_data *data, object var, object value, int *run_gc) +{ + char tmp; + int inttmp, *heap_grown = &inttmp; + gc_heap_root *heap = data->heap; + + // Nothing needs to be done unless we are mutating + // a heap variable to point to a stack var. + if (!gc_is_stack_obj(&tmp, data, var) && gc_is_stack_obj(&tmp, data, value)) { + // Must move `value` to the heap to allow use by other threads + switch(type_of(value)) { + case string_tag: + case bytevector_tag: + if (immutable(value)) { + // Safe to transport now + object hp = gc_alloc(heap, gc_allocated_bytes(value, NULL, NULL), value, data, heap_grown); + return hp; + } + // Need to GC if obj is mutable, EG: a string could be mutated so we can't + // have multiple copies of the object running around + *run_gc = 1; + return value; + case double_tag: + case port_tag: + case c_opaque_tag: + case complex_num_tag: { + // These objects are immutable, transport now + object hp = gc_alloc(heap, gc_allocated_bytes(value, NULL, NULL), value, data, heap_grown); + return hp; + } + // Objs w/children force minor GC to guarantee everything is relocated: + case cvar_tag: + case closure0_tag: + case closure1_tag: + case closureN_tag: + case pair_tag: + case vector_tag: + *run_gc = 1; + return value; + default: + // Other object types are not stack-allocated so should never get here + printf("Invalid shared object type %d\n", type_of(value)); + exit(1); + } + } + + return value; +} + + /* Mutation table functions * * Keep track of mutations (EG: set-car!) so we can avoid having heap @@ -1982,6 +2111,120 @@ object Cyc_vector_set_unsafe(void *data, object v, object k, object obj) return v; } +// Prevent the possibility of a race condition by doing the actual mutation +// after all relevant objects have been relocated to the heap +static void Cyc_set_car_cps_gc_return(void *data, int argc, object cont, object l, object val, object next) +{ + car(l) = val; + closcall1(data, (closure)next, l); +} + +object Cyc_set_car_cps(void *data, object cont, object l, object val) +{ + if (Cyc_is_pair(l) == boolean_f) { + Cyc_invalid_type_error(data, pair_tag, l); + } + Cyc_verify_mutable(data, l); + + // Alternate write barrier + int do_gc = 0; + val = transport_stack_value(data, l, val, &do_gc); + gc_mut_update((gc_thread_data *) data, car(l), val); + add_mutation(data, l, -1, val); // Ensure val is transported + if (do_gc) { // GC and then do assignment + mclosure0(clo, (function_type)Cyc_set_car_cps_gc_return); + object buf[3]; buf[0] = l; buf[1] = val; buf[2] = cont; + GC(data, &clo, buf, 3); + return NULL; + } else { + car(l) = val; // Assign now since we have heap objects + return l; + } +} + +static void Cyc_set_cdr_cps_gc_return(void *data, int argc, object cont, object l, object val, object next) +{ + cdr(l) = val; + closcall1(data, (closure)next, l); +} + +object Cyc_set_cdr_cps(void *data, object cont, object l, object val) +{ + if (Cyc_is_pair(l) == boolean_f) { + Cyc_invalid_type_error(data, pair_tag, l); + } + Cyc_verify_mutable(data, l); + + // Alternate write barrier + int do_gc = 0; + val = transport_stack_value(data, l, val, &do_gc); + + gc_mut_update((gc_thread_data *) data, cdr(l), val); + add_mutation(data, l, -1, val); // Ensure val is transported + if (do_gc) { // GC and then to assignment + mclosure0(clo, (function_type)Cyc_set_cdr_cps_gc_return); + object buf[3]; buf[0] = l; buf[1] = val; buf[2] = cont; + GC(data, &clo, buf, 3); + return NULL; + } else { + cdr(l) = val; // Assign now since we have heap objects + return l; + } +} + +static void Cyc_vector_set_cps_gc_return(void *data, int argc, object cont, object vec, object idx, object val, object next) +{ + int i = obj_obj2int(idx); + ((vector) vec)->elements[i] = val; + closcall1(data, (closure)next, vec); +} + +object Cyc_vector_set_cps(void *data, object cont, object v, object k, object obj) +{ + int idx; + Cyc_check_vec(data, v); + Cyc_check_fixnum(data, k); + Cyc_verify_mutable(data, v); + idx = unbox_number(k); + + if (idx < 0 || idx >= ((vector) v)->num_elements) { + Cyc_rt_raise2(data, "vector-set! - invalid index", k); + } + + int do_gc = 0; + obj = transport_stack_value(data, v, obj, &do_gc); + + gc_mut_update((gc_thread_data *) data, ((vector) v)->elements[idx], obj); + add_mutation(data, v, idx, obj); + if (do_gc) { // GC and then do assignment + mclosure0(clo, (function_type)Cyc_vector_set_cps_gc_return); + object buf[4]; buf[0] = v; buf[1] = k; buf[2] = obj; buf[3] = cont; + GC(data, &clo, buf, 4); + return NULL; + } else { + ((vector) v)->elements[idx] = obj; // Assign now since we have heap objs + return v; // Let caller pass this to cont + } +} + +object Cyc_vector_set_unsafe_cps(void *data, object cont, object v, object k, object obj) +{ + int idx = unbox_number(k); + int do_gc = 0; + obj = transport_stack_value(data, v, obj, &do_gc); + gc_mut_update((gc_thread_data *) data, ((vector) v)->elements[idx], obj); + add_mutation(data, v, idx, obj); + if (do_gc) { // GC and then do assignment + mclosure0(clo, (function_type)Cyc_vector_set_cps_gc_return); + object buf[4]; buf[0] = v; buf[1] = k; buf[2] = obj; buf[3] = cont; + GC(data, &clo, buf, 4); + return NULL; + } else { + ((vector) v)->elements[idx] = obj; // Assign now since we have heap objs + return v; + } +} + object Cyc_vector_ref(void *data, object v, object k) { int idx; @@ -4676,14 +4919,20 @@ void _null_127(void *data, object cont, object args) void _set_91car_67(void *data, object cont, object args) { + //Cyc_check_num_args(data, "set-car!", 2, args); + //return_closcall1(data, cont, Cyc_set_car(data, car(args), cadr(args))); Cyc_check_num_args(data, "set-car!", 2, args); - return_closcall1(data, cont, Cyc_set_car(data, car(args), cadr(args))); + //Cyc_set_car2(data, cont, car(args), cadr(args)); + return_closcall1(data, cont, Cyc_set_car_cps(data, cont, car(args), cadr(args))); } void _set_91cdr_67(void *data, object cont, object args) { + //Cyc_check_num_args(data, "set-cdr!", 2, args); + //return_closcall1(data, cont, Cyc_set_cdr(data, car(args), cadr(args))); Cyc_check_num_args(data, "set-cdr!", 2, args); - return_closcall1(data, cont, Cyc_set_cdr(data, car(args), cadr(args))); + //Cyc_set_cdr2(data, cont, car(args), cadr(args)); + return_closcall1(data, cont, Cyc_set_cdr_cps(data, cont, car(args), cadr(args))); } void _Cyc_91has_91cycle_127(void *data, object cont, object args) @@ -5103,7 +5352,7 @@ void _vector_91set_67(void *data, object cont, object args) { Cyc_check_num_args(data, "vector-set!", 3, args); { - object ref = Cyc_vector_set(data, car(args), cadr(args), caddr(args)); + object ref = Cyc_vector_set_cps(data, cont, car(args), cadr(args), caddr(args)); return_closcall1(data, cont, ref); }} @@ -5700,6 +5949,9 @@ int gc_minor(void *data, object low_limit, object high_limit, closure cont, for (i = 0; i < ((vector) v)->num_elements; i++) { gc_move2heap(((vector) v)->elements[i]); } + } else if (type_of(o) == cvar_tag) { + cvar_type *c = (cvar_type *) o; + gc_move2heap(*(c->pvar)); // Transport underlying global, not the pvar } else { printf("Unexpected type %d transporting mutation\n", type_of(o)); exit(1); @@ -5791,9 +6043,15 @@ void GC(void *data, closure cont, object * args, int num_args) char tmp; object low_limit = &tmp; // This is one end of the stack... object high_limit = ((gc_thread_data *) data)->stack_start; +#ifdef CYC_HIGH_RES_TIMERS +long long tstamp = hrt_get_current(); +#endif int alloci = gc_minor(data, low_limit, high_limit, cont, args, num_args); // Cooperate with the collector thread gc_mut_cooperate((gc_thread_data *) data, alloci); +#ifdef CYC_HIGH_RES_TIMERS +hrt_log_delta("minor gc", tstamp); +#endif // Let it all go, Neo... longjmp(*(((gc_thread_data *) data)->jmp_start), 1); } diff --git a/scheme/cyclone/cgen.sld b/scheme/cyclone/cgen.sld index cfc7613a..285771cd 100644 --- a/scheme/cyclone/cgen.sld +++ b/scheme/cyclone/cgen.sld @@ -689,8 +689,6 @@ (number->string (char->integer exp)) ")"))) ((string? exp) (c-compile-string exp use-alloca immutable)) -;TODO: not good enough, need to store new symbols in a table so they can -;be inserted into the C program ((symbol? exp) (allocate-symbol exp) (c-code (string-append "quote_" (mangle exp)))) @@ -1001,6 +999,21 @@ (c-args* (if (prim:arg-count? fun) (c:append (c-code num-args-str) c-args) c-args))) + ;; Emit symbol when mutating global variables, so we can look + ;; up the cvar + (when (eq? 'set-global! fun) + (let* ((ident (cadr args)) + (mangled (string-append "\"" (cgen:mangle-global ident) "\"")) + (all-args (string-split (car c-args) #\,)) + (new-all-args (string-join (cons mangled (cdr all-args)) ",")) + ) + (set-car! c-args* new-all-args) + (set-car! (cadddr c-args*) mangled) + ;(trace:debug `(JAE set-global args are ,c-args ,args mangled )) + ;; Example c-args: + ;;("quote__121pare_125, __glo__121pare_125, r_73558_731010_731308_731412" () 3 ("quote__121pare_125" () 0) ("__glo__121pare_125" ()) ("r_73558_731010_731308_731412" ())) + )) + (if (prim/cvar? fun) ;; Args need to go with alloc function (c-code/vars @@ -2122,9 +2135,13 @@ ;; Initialize global table (for-each (lambda (global) - (emits "\n add_global((object *) &") - (emits (cgen:mangle-global (car global))) - (emits ");")) + (let ((mglo (cgen:mangle-global (car global)))) + (emits (string-append + "\n add_global(\"" + mglo + "\", (object *) &")) + (emits mglo) + (emits ");"))) *globals*) (emit "") diff --git a/scheme/cyclone/common.sld b/scheme/cyclone/common.sld index 22ac615e..65f2b39e 100644 --- a/scheme/cyclone/common.sld +++ b/scheme/cyclone/common.sld @@ -15,7 +15,7 @@ *version-banner* *c-file-header-comment*) (begin -(define *version-number* "0.12") +(define *version-number* "0.14") (define *version-name* "") (define *version* (string-append *version-number* " " *version-name* "")) diff --git a/scheme/cyclone/cps-opt-memoize-pure-fncs.scm b/scheme/cyclone/cps-opt-memoize-pure-fncs.scm index 797350b8..62db884b 100644 --- a/scheme/cyclone/cps-opt-memoize-pure-fncs.scm +++ b/scheme/cyclone/cps-opt-memoize-pure-fncs.scm @@ -191,7 +191,7 @@ (new-var (cdr var/new-var)) (body `((Cyc-seq - (set-global! ,var ,rsym) + (set-global-unsafe! ,(list 'quote var) ,var ,rsym) ,acc))) ) `(Cyc-memoize diff --git a/scheme/cyclone/cps-optimizations.sld b/scheme/cyclone/cps-optimizations.sld index 34f27cb0..b60fe5ed 100644 --- a/scheme/cyclone/cps-optimizations.sld +++ b/scheme/cyclone/cps-optimizations.sld @@ -1091,8 +1091,11 @@ ((and (ast:lambda? (car exp)) (every (lambda (arg) - (or (not (prim-call? arg)) - (not (prim:cont? (car arg))))) + (and + (not (set!? arg)) + (or (not (prim-call? arg)) + (not (prim:cont? (car arg))) + ))) (cdr exp)) (every (lambda (param) diff --git a/scheme/cyclone/primitives.sld b/scheme/cyclone/primitives.sld index b7850758..0d268a8d 100644 --- a/scheme/cyclone/primitives.sld +++ b/scheme/cyclone/primitives.sld @@ -67,6 +67,7 @@ Cyc-spawn-thread! Cyc-end-thread! set-global! + set-global-unsafe! set-cell! set-car! set-cdr! @@ -132,6 +133,7 @@ Cyc-fast-list-4 cell-get set-global! + set-global-unsafe! set-cell! cell eq? @@ -277,7 +279,8 @@ (Cyc-fast-list-3 3 3) (Cyc-fast-list-4 4 4) (cell-get 1 1) - (set-global! 2 2) + (set-global! 3 3) + (set-global-unsafe! 3 3) (set-cell! 2 2) (cell 1 1) (eq? 2 2) @@ -631,8 +634,8 @@ "Cyc_vector_ref")) ((eq? p 'vector-set!) (if emit-unsafe - "Cyc_vector_set_unsafe" - "Cyc_vector_set")) + "Cyc_vector_set_unsafe_cps" + "Cyc_vector_set_cps")) ((eq? p 'string-append) "Cyc_string_append") ((eq? p 'string-cmp) "Cyc_string_cmp") ((eq? p 'string->symbol) "Cyc_string2symbol") @@ -650,8 +653,8 @@ (if emit-unsafe "Cyc_length_unsafe" "Cyc_length")) - ((eq? p 'set-car!) "Cyc_set_car") - ((eq? p 'set-cdr!) "Cyc_set_cdr") + ((eq? p 'set-car!) "Cyc_set_car_cps") + ((eq? p 'set-cdr!) "Cyc_set_cdr_cps") ((eq? p 'eq?) "Cyc_eq") ((eq? p 'eqv?) "Cyc_eq") ((eq? p 'equal?) "equalp") @@ -688,7 +691,8 @@ ((eq? p 'cell) "set_cell_as_expr") ((eq? p 'cell-get) "car") ;; Unsafe as cell gets added by compiler ((eq? p 'set-cell!) "Cyc_set_cell") - ((eq? p 'set-global!) "global_set") + ((eq? p 'set-global!) "global_set_cps_id") + ((eq? p 'set-global-unsafe!) "global_set_id") (else (error "unhandled primitive: " p)))) @@ -788,7 +792,8 @@ set-car! set-cdr! procedure? - set-cell!)) + set-cell! + set-global!)) (memq p *udf-prims*))) ;; Determine if primitive receives a pointer to a local C variable @@ -870,6 +875,10 @@ ((eq? p 'make-vector) "object") ((eq? p 'list->string) "object") ((eq? p 'list->vector) "object") + ((eq? p 'set-car!) "object") + ((eq? p 'set-cdr!) "object") + ((eq? p 'vector-set!) "object") + ((eq? p 'set-global!) "object") ((eq? p 'Cyc-installation-dir) "object") ((eq? p 'Cyc-compilation-environment) "object") ;((memq p *udf-prims*) "object") @@ -900,6 +909,10 @@ make-vector list->vector symbol->string number->string substring + set-car! + set-cdr! + vector-set! + set-global! ;Cyc-fast-plus ;Cyc-fast-sub ;Cyc-fast-mul @@ -938,6 +951,10 @@ Cyc-fast-apply + - * / = > < >= <= + set-car! + set-cdr! + vector-set! + set-global! Cyc-list Cyc-read-char Cyc-peek-char symbol->string list->string substring string-append string->number diff --git a/scheme/cyclone/transforms.sld b/scheme/cyclone/transforms.sld index 39f509a6..0a6affb8 100644 --- a/scheme/cyclone/transforms.sld +++ b/scheme/cyclone/transforms.sld @@ -141,7 +141,7 @@ (define (trace:error msg) (trace 1 msg pretty-print "")) (define (trace:warn msg) (trace 2 msg pretty-print "")) (define (trace:info msg) (trace 3 msg pretty-print "")) -(define (trace:debug msg) (trace 4 msg display "DEBUG: ")) +(define (trace:debug msg) (trace 4 msg write "DEBUG: ")) (define (cyc:error msg) (error msg) @@ -431,6 +431,7 @@ if (acc) { Cyc-current-exception-handler cell-get set-global! + set-global-unsafe! set-cell! cell cons @@ -847,11 +848,17 @@ if (acc) { ((prim? exp) exp) ((quote? exp) exp) ((lambda? exp) (error `(Unexpected lambda in wrap-mutables ,exp))) - ((set!? exp) `(,(if (member (set!->var exp) globals) - 'set-global! - 'set-cell!) - ,(set!->var exp) - ,(wrap-mutables (set!->exp exp) globals))) + ((set!? exp) + (cond + ((member (set!->var exp) globals) + `(set-global! + ,(list 'quote (set!->var exp)) + ,(set!->var exp) + ,(wrap-mutables (set!->exp exp) globals)) ) + (else + `(set-cell! + ,(set!->var exp) + ,(wrap-mutables (set!->exp exp) globals))) )) ((if? exp) `(if ,(wrap-mutables (if->condition exp) globals) ,(wrap-mutables (if->then exp) globals) ,(wrap-mutables (if->else exp) globals)))