Merge branch 'gc-share2-dev'

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
 

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

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)

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;

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)
+#define global_set(glo,value) Cyc_global_set(data, NULL, (object *)&glo, value)
-object Cyc_global_set(void *thd, object * glo, object 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);

include/cyclone/types.h

@@ -22,6 +22,17 @@
 #include <dlfcn.h>
 #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

runtime.c

@@ -9,6 +9,7 @@
  */
 
 #include <ck_hs.h>
+#include <ck_ht.h>
 #include <ck_pr.h>
 #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 <sys/time.h>
+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);
 }

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 *) &")
+        (let ((mglo (cgen:mangle-global (car global))))
-        (emits (cgen:mangle-global (car global)))
+          (emits (string-append
-        (emits ");"))
+                   "\n  add_global(\""
+                   mglo
+                   "\", (object *) &"))
+          (emits mglo)
+          (emits ");")))
       *globals*)
     (emit "")
 

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

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

scheme/cyclone/cps-optimizations.sld

@@ -1091,8 +1091,11 @@
             ((and (ast:lambda? (car exp))
                   (every
                     (lambda (arg)
-                      (or (not (prim-call? arg))
+                      (and
-                          (not (prim:cont? (car arg)))))
+                        (not (set!? arg))
+                        (or (not (prim-call? arg))
+                            (not (prim:cont? (car arg)))
+                            )))
                     (cdr exp))
                   (every
                     (lambda (param)

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_unsafe_cps"
-              "Cyc_vector_set"))
+              "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-car!)      "Cyc_set_car_cps")
-         ((eq? p 'set-cdr!)      "Cyc_set_cdr")
+         ((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

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!? exp)   
-                            'set-global!
+     (cond
-                            'set-cell!) 
+       ((member (set!->var exp) globals)
-                        ,(set!->var exp) 
+          `(set-global!
-                        ,(wrap-mutables (set!->exp exp) globals)))
+            ,(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)))