Merge branch 'thread-params-dev'

atomics.sld

@@ -0,0 +1,15 @@
+(define-library (atomics)
+  (export
+    atomic:get
+    atomic:set!
+  )
+  (include-c-header "<ck_pr.h>")
+  (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); ")
+  ))
+

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))

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;

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);

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 */

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);

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) '<param-set!>)
-             (set! value (cadr args)))
+             (let ((cell (assoc key (get-param-objs))))
+              (set-cdr! cell (cadr args))))
+             ;(set! value (cadr args)))
             ((eq? (car args) '<param-convert>)
              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)))

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)
         ))