Added Cyc-minor-gc

include/cyclone/runtime.h

@@ -192,6 +192,7 @@ void Cyc_end_thread(gc_thread_data *thd);
 void Cyc_exit_thread(gc_thread_data *thd);
 object Cyc_thread_sleep(void *data, object timeout);
 void GC(void *,closure,object*,int);
+object Cyc_trigger_minor_gc(void *data, object cont);
 
 void Cyc_st_add(void *data, char *frame);
 void Cyc_st_print(void *data, FILE *out);
@@ -231,6 +232,7 @@ extern const object primitive_Cyc_91has_91cycle_127;
 extern const object primitive_Cyc_91spawn_91thread_67;
 extern const object primitive_Cyc_91end_91thread_67;
 extern const object primitive_thread_91sleep_67;
+extern const object primitive_Cyc_91minor_91gc;
 extern const object primitive__87;
 extern const object primitive__91;
 extern const object primitive__85;

runtime.c

@@ -1730,6 +1730,8 @@ void _Cyc_91end_91thread_67(void *data, object cont, object args) {
 void _thread_91sleep_67(void *data, object cont, object args) {
     Cyc_check_num_args(data, "thread-sleep!", 1, args);
     return_closcall1(data, cont, Cyc_thread_sleep(data, car(args))); }
+void _Cyc_91minor_91gc_primitive(void *data, object cont, object args){
+    Cyc_trigger_minor_gc(data, cont); }
 void __87(void *data, object cont, object args) {
     integer_type argc = Cyc_length(data, args);
     dispatch(data, argc.value, (function_type)dispatch_sum, cont, cont, args); }
@@ -2265,6 +2267,13 @@ char *gc_move(char *obj, gc_thread_data *thd, int *alloci, int *heap_grown) {
   } \
 }
 
+object Cyc_trigger_minor_gc(void *data, object cont) {
+  gc_thread_data* thd = (gc_thread_data *)data;
+  thd->gc_args = boolean_t;
+  GC(data, cont, thd->gc_args, 1);
+  return nil;
+}
+
 // Do a minor GC
 int gc_minor(void *data, object low_limit, object high_limit, closure cont, object *args, int num_args)
 { 
@@ -2399,9 +2408,9 @@ void GC(void *data, closure cont, object *args, int num_args)
   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);
-#if GC_DEBUG_TRACE
+//#if GC_DEBUG_TRACE
   fprintf(stderr, "done with minor GC\n");
-#endif
+//#endif
   // Let it all go, Neo...
   longjmp(*(((gc_thread_data *)data)->jmp_start), 1);
 }
@@ -2537,6 +2546,7 @@ static primitive_type Cyc_91has_91cycle_127_primitive = {{0}, primitive_tag, "Cy
 static primitive_type Cyc_91spawn_91thread_67_primitive = {{0}, primitive_tag, "Cyc-spawn-thread!", &_Cyc_91spawn_91thread_67};
 static primitive_type Cyc_91end_91thread_67_primitive = {{0}, primitive_tag, "Cyc-end-thread!", &_Cyc_91end_91thread_67};
 static primitive_type thread_91sleep_67_primitive = {{0}, primitive_tag, "thread-sleep!", &_thread_91sleep_67};
+static primitive_type Cyc_91minor_91gc_primitive = {{0}, primitive_tag, "Cyc-minor-gc", &_Cyc_91minor_91gc_primitive};
 static primitive_type _87_primitive = {{0}, primitive_tag, "+", &__87};
 static primitive_type _91_primitive = {{0}, primitive_tag, "-", &__91};
 static primitive_type _85_primitive = {{0}, primitive_tag, "*", &__85};
@@ -2657,6 +2667,7 @@ const object primitive_Cyc_91has_91cycle_127 = &Cyc_91has_91cycle_127_primitive;
 const object primitive_Cyc_91spawn_91thread_67 = &Cyc_91spawn_91thread_67_primitive;
 const object primitive_Cyc_91end_91thread_67 = &Cyc_91end_91thread_67_primitive;
 const object primitive_thread_91sleep_67 = &thread_91sleep_67_primitive;
+const object primitive_Cyc_91minor_91gc = &Cyc_91minor_91gc_primitive;
 const object primitive__87 = &_87_primitive;
 const object primitive__91 = &_91_primitive;
 const object primitive__85 = &_85_primitive;

scheme/cyclone/cgen.sld

@@ -535,6 +535,7 @@
      ((eq? p 'substring)      "Cyc_substring")
      ((eq? p 'Cyc-installation-dir) "Cyc_installation_dir")
      ((eq? p 'command-line-arguments) "Cyc_command_line_arguments")
+     ((eq? p 'Cyc-minor-gc)  "Cyc_trigger_minor_gc")
      ((eq? p 'system)         "Cyc_system")
      ((eq? p 'assq)          "assq")
      ((eq? p 'assv)          "assq")
@@ -617,6 +618,7 @@
     substring
     Cyc-installation-dir
     command-line-arguments
+    Cyc-minor-gc
     assq
     assv
     assoc
@@ -655,6 +657,7 @@
     ((eq? p 'read-char) "object")
     ((eq? p 'peek-char) "object")
     ((eq? p 'command-line-arguments) "object")
+    ((eq? p 'Cyc-minor-gc) "object")
     ((eq? p 'number->string) "object")
     ((eq? p 'symbol->string) "object")
     ((eq? p 'substring) "object")
@@ -683,6 +686,7 @@
              string-length substring
              + - * / apply 
              command-line-arguments
+             Cyc-minor-gc
              Cyc-read-line
              read-char peek-char
              cons length vector-length cell))))
@@ -690,7 +694,7 @@
 ;; Pass continuation as the function's first parameter?
 (define (prim:cont? exp)
   (and (prim? exp)
-       (member exp '(Cyc-read-line apply command-line-arguments number->string 
+       (member exp '(Cyc-read-line apply command-line-arguments Cyc-minor-gc number->string 
                      read-char peek-char
                      symbol->string list->string substring string-append
                      make-vector list->vector Cyc-installation-dir))))
@@ -698,7 +702,7 @@
 ;; Primitive functions that pass a continuation but have no other arguments
 (define (prim:cont/no-args? exp)
   (and (prim? exp)
-       (member exp '(command-line-arguments))))
+       (member exp '(command-line-arguments Cyc-minor-gc))))
 
 ;; Pass an integer arg count as the function's first parameter?
 (define (prim:arg-count? exp)

scheme/cyclone/transforms.sld

@@ -454,6 +454,7 @@
      Cyc-spawn-thread!
      Cyc-end-thread!
      thread-sleep!
+     Cyc-minor-gc
      Cyc-stdout
      Cyc-stdin
      Cyc-stderr
@@ -560,6 +561,7 @@
                   Cyc-spawn-thread!
                   Cyc-end-thread!
                   thread-sleep!
+                  Cyc-minor-gc
                   apply
                   %halt
                   exit

scheme/eval.sld

@@ -156,6 +156,7 @@
       (list 'Cyc-installation-dir Cyc-installation-dir)
       (list 'system system)
       (list 'command-line-arguments command-line-arguments)
+      (list 'Cyc-minor-gc Cyc-minor-gc)
       (list 'error error)
       (list 'cons cons)
       (list 'cell-get cell-get)