diff --git a/atomics.sld b/atomics.sld new file mode 100644 index 00000000..573cf896 --- /dev/null +++ b/atomics.sld @@ -0,0 +1,15 @@ +(define-library (atomics) + (export + atomic:get + atomic:set! + ) + (include-c-header "") + (begin + ;TODO: won't work, ints are immutable + ;(define-c atomic:fx++ + ; "(void *data, int argc, closure _, object k, object num)" + ; " Cyc_check_fixnum(data, num); + ; ck_pr_add_ptr(&num, 2); + ; return_closcall1(data, k, num); ") + )) + diff --git a/examples/threading/parameters.scm b/examples/threading/parameters.scm index 7221cae8..0fc9ed71 100644 --- a/examples/threading/parameters.scm +++ b/examples/threading/parameters.scm @@ -1,4 +1,8 @@ ;; A simple program demonstrating how parameter objects interact with threads +;; +;; Note this is poor code as it uses timing via sleeps instead of proper +;; thread synchronization!!! +;; (import (scheme base) (scheme read) (scheme write) @@ -8,18 +12,20 @@ (thread-start! (make-thread (lambda () - (thread-sleep! 1000) + (thread-sleep! 1200) (display "started thread, this should be written to console") (newline) (display "thread done") - (newline)))) + (newline) + (flush-output-port (current-output-port))))) +(thread-sleep! 1000) ;; Prevent race condition replacing stdout before thread is spawned (write `(1 2 3)) (define fp (open-output-file "tmp.txt")) (parameterize ((current-output-port fp)) (write `(4 5 6)) - (thread-sleep! 5000) + (thread-sleep! 3000) ) (close-port fp) (write `(7 8 9)) diff --git a/gc.c b/gc.c index 502cc4c5..a77b2482 100644 --- a/gc.c +++ b/gc.c @@ -1307,6 +1307,12 @@ void gc_mut_cooperate(gc_thread_data * thd, int buf_len) if (thd->scm_thread_obj) { gc_mark_gray(thd, thd->scm_thread_obj); } + if (thd->exception_handler_stack) { + gc_mark_gray(thd, thd->exception_handler_stack); + } + if (thd->param_objs) { + gc_mark_gray(thd, thd->param_objs); + } // Also, mark everything the collector moved to the heap for (i = 0; i < buf_len; i++) { gc_mark_gray(thd, thd->moveBuf[i]); @@ -1690,6 +1696,15 @@ void gc_wait_handshake() //for (i = 0; i < m->gc_num_args; i++) { // gc_mark_gray(m, m->gc_args[i]); //} + if (m->scm_thread_obj) { + gc_mark_gray(m, m->scm_thread_obj); + } + if (m->exception_handler_stack) { + gc_mark_gray(m, m->exception_handler_stack); + } + if (m->param_objs) { + gc_mark_gray(m, m->param_objs); + } // Also, mark everything the collector moved to the heap for (i = 0; i < buf_len; i++) { gc_mark_gray(m, m->moveBuf[i]); @@ -1883,6 +1898,7 @@ void gc_thread_data_init(gc_thread_data * thd, int mut_num, char *stack_base, thd->mutation_count = 0; thd->mutations = vpbuffer_realloc(thd->mutations, &(thd->mutation_buflen)); + thd->param_objs = NULL; thd->exception_handler_stack = NULL; thd->scm_thread_obj = NULL; thd->thread_state = CYC_THREAD_STATE_NEW; diff --git a/include/cyclone/runtime.h b/include/cyclone/runtime.h index d575e26e..5511f941 100644 --- a/include/cyclone/runtime.h +++ b/include/cyclone/runtime.h @@ -73,6 +73,7 @@ void gc_init_heap(long heap_size); #define Cyc_check_pair(d,obj) Cyc_check_type(d,Cyc_is_pair, pair_tag, obj); #define Cyc_check_proc(d,obj) Cyc_check_type2(d,Cyc_is_procedure, closureN_tag, obj); #define Cyc_check_num(d,obj) Cyc_check_type(d,Cyc_is_number, integer_tag, obj); +#define Cyc_check_fixnum(d,obj) Cyc_check_type(d,Cyc_is_fixnum, integer_tag, obj); #define Cyc_check_int(d,obj) Cyc_check_type(d,Cyc_is_integer, integer_tag, obj); #define Cyc_check_str(d,obj) Cyc_check_type(d,Cyc_is_string, string_tag, obj); #define Cyc_check_sym(d,obj) Cyc_check_type(d,Cyc_is_symbol, symbol_tag, obj); @@ -359,6 +360,7 @@ object Cyc_is_null(object o); object Cyc_is_number(object o); object Cyc_is_real(object o); object Cyc_is_integer(object o); +object Cyc_is_fixnum(object o); object Cyc_is_bignum(object o); object Cyc_is_vector(object o); object Cyc_is_bytevector(object o); diff --git a/include/cyclone/types.h b/include/cyclone/types.h index b27d99c0..f59f73e6 100644 --- a/include/cyclone/types.h +++ b/include/cyclone/types.h @@ -294,6 +294,8 @@ struct gc_thread_data_t { char *stack_prev_frame; // Exception handler stack object exception_handler_stack; + // Parameter object data + object param_objs; }; /* GC prototypes */ diff --git a/runtime.c b/runtime.c index b9f99882..dd7ebc4f 100644 --- a/runtime.c +++ b/runtime.c @@ -1465,6 +1465,13 @@ object Cyc_is_real(object o) return Cyc_is_number(o); } +object Cyc_is_fixnum(object o) +{ + if (obj_is_int(o)) + return boolean_t; + return boolean_f; +} + object Cyc_is_integer(object o) { if ((o != NULL) && (obj_is_int(o) || @@ -1833,6 +1840,8 @@ object Cyc_string2number2_(void *data, object cont, int argc, object str, ...) result = (int)strtol(string_str(str), NULL, 2); } else if (base_num == 8) { result = (int)strtol(string_str(str), NULL, 8); + } else if (base_num == 10) { + Cyc_string2number_(data, cont, str); // Default processing } else if (base_num == 16) { result = (int)strtol(string_str(str), NULL, 16); } @@ -1842,7 +1851,7 @@ object Cyc_string2number2_(void *data, object cont, int argc, object str, ...) if (MP_OKAY != mp_read_radix(&(bignum_value(bn)), string_str(str), base_num)) { Cyc_rt_raise2(data, "Error converting string to bignum", str); } - _return_closcall1(data, cont, bn); + _return_closcall1(data, cont, Cyc_bignum_normalize(data, bn)); } else { _return_closcall1(data, cont, obj_int2obj(result)); } @@ -4776,6 +4785,7 @@ int gc_minor(void *data, object low_limit, object high_limit, closure cont, // Transport exception stack gc_move2heap(((gc_thread_data *) data)->exception_handler_stack); + gc_move2heap(((gc_thread_data *) data)->param_objs); gc_move2heap(((gc_thread_data *) data)->scm_thread_obj); // Transport mutations @@ -5318,11 +5328,29 @@ const object primitive_Cyc_91write = &Cyc_91write_primitive; const object primitive_Cyc_91display = &Cyc_91display_primitive; const object primitive_call_95cc = &call_95cc_primitive; +void *gc_alloc_pair(gc_thread_data *data, object head, object tail) +{ + int heap_grown; + pair_type *p; + pair_type tmp; + tmp.hdr.mark = gc_color_red; + tmp.hdr.grayed = 0; + tmp.tag = pair_tag; + tmp.pair_car = head; + tmp.pair_cdr = tail; + p = gc_alloc(((gc_thread_data *)data)->heap, sizeof(pair_type), (char *)(&tmp), (gc_thread_data *)data, &heap_grown); + + return p; +} + /** * Thread initialization function only called from within the runtime */ void *Cyc_init_thread(object thread_and_thunk) { + vector_type *t; + c_opaque_type *o; + object op, parent, child; long stack_start; gc_thread_data *thd; thd = malloc(sizeof(gc_thread_data)); @@ -5332,6 +5360,28 @@ void *Cyc_init_thread(object thread_and_thunk) thd->gc_num_args = 1; thd->gc_args[0] = &Cyc_91end_91thread_67_primitive; thd->thread_id = pthread_self(); + + // Copy thread params from the calling thread + t = (vector_type *)thd->scm_thread_obj; + op = Cyc_vector_ref(thd, t, obj_int2obj(2)); // Field set in thread-start! + o = (c_opaque_type *)op; + parent = ((gc_thread_data *)o->ptr)->param_objs; // Unbox parent thread's data + child = NULL; + thd->param_objs = NULL; + while (parent) { + if (thd->param_objs == NULL) { + thd->param_objs = gc_alloc_pair(thd, NULL, NULL); + child = thd->param_objs; + } else { + pair_type *p = gc_alloc_pair(thd, NULL, NULL); + cdr(child) = p; + child = p; + } + car(child) = gc_alloc_pair(thd, car(car(parent)), cdr(car(parent))); + parent = cdr(parent); + } + // Done initializing parameter objects + gc_add_mutator(thd); ck_pr_cas_int((int *)&(thd->thread_state), CYC_THREAD_STATE_NEW, CYC_THREAD_STATE_RUNNABLE); diff --git a/scheme/base.sld b/scheme/base.sld index 7db66cec..f3ab3e8c 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -107,6 +107,7 @@ string->vector string-map string-for-each + ;get-param-objs ;; TODO: only for debugging!! make-parameter current-output-port current-input-port @@ -948,21 +949,62 @@ () ((param value) ...) body)))) + (define-c get-param-objs + "(void *data, int argc, closure _, object k)" + " gc_thread_data *thd = (gc_thread_data *)data; + //Cyc_st_add(data, \"scheme/base.sld:get-param-objs\"); + return_closcall1(data, k, thd->param_objs); ") + (define-c set-param-obj! + "(void *data, int argc, closure _, object k, object obj)" + " gc_thread_data *thd = (gc_thread_data *)data; + make_pair(c, obj, thd->param_objs); + thd->param_objs = &c; + return_closcall1(data, k, &c); ") + ;"(void *data, int argc, closure _, object k, object obj)" + ;" make_pair(p, obj, ((gc_thread_data *)data)->param_objs); + ; gc_thread_data *thd = (gc_thread_data *)data; + ; //Cyc_st_add(data, \"scheme/base.sld:set-param-objs!\"); + ; //fprintf(stderr, \"scheme/base.sld:set-param-objs!\\n\"); + ; global_set((thd->param_objs), &p); + ; //thd->param_objs = (object)(&p); + ; // obj is on the stack, need to add it to write barrier + ; // to ensure it is transported to the heap + ; //add_mutation(data, &p, -1, obj); + ; return_closcall1(data, k, boolean_t); ") + (define *parameter-id* 0) (define (make-parameter init . o) (let* ((converter (if (pair? o) (car o) (lambda (x) x))) - (value (converter init))) + (value (converter init)) + (key #f)) + ;; TODO: this is not thread safe! + (set! key *parameter-id*) + (set! *parameter-id* (+ *parameter-id* 1)) + ;; + (set-param-obj! (cons key value)) + (lambda args (cond ((null? args) - value) + ;; DEBUG + (let ((pobj (get-param-objs))) + ;(if (not (pair? (car pobj))) + ; (Cyc-display `(get-param-objs not a list: ,(get-param-objs)))) + (cdr (assoc key pobj)))) + ;; END DEBUG + ;(cdr (assoc key (get-param-objs)))) + ;value) ((eq? (car args) ') - (set! value (cadr args))) + (let ((cell (assoc key (get-param-objs)))) + (set-cdr! cell (cadr args)))) + ;(set! value (cadr args))) ((eq? (car args) ') converter) (else ;(error "bad parameter syntax" args) - (set! value (converter (car args))) + (let ((cell (assoc key (get-param-objs)))) + (set-cdr! cell (converter (car args)))) + ;(set! value (converter (car args))) ))))) (define current-output-port (make-parameter (Cyc-stdout))) diff --git a/srfi/18.sld b/srfi/18.sld index 7353a0c9..43ebc45e 100644 --- a/srfi/18.sld +++ b/srfi/18.sld @@ -99,6 +99,8 @@ (thread-params (cons t (lambda () (vector-set! t 2 (%get-thread-data)) (thunk))))) + (vector-set! t 2 (%get-thread-data)) ;; Temporarily make parent thread + ;; data available for child init (Cyc-minor-gc) (Cyc-spawn-thread! thread-params) ))