Allocate in co-op with GC.

Author: dvanhorn

langs/iniquity-gc/compile-ops.rkt

@@ -77,7 +77,9 @@
           unpad-stack
           (Mov rax val-void))]
     ['box
-     (seq (allocate 1)
+     (seq (Push rax)
+          (allocate 1)
+          (Pop rax)
           (Mov (Offset rbx 0) rax)
           (Mov rax rbx)
           (Or rax type-box)
@@ -131,19 +133,15 @@
             (Label done)))]))
 
 (define (allocate n)
-  (seq)
-  #;
-  (seq (Mov r15 rax) ; save rax
-       (Mov rdi rsp)
-       (Mov rsi rbp)
-       (Mov rdx rbx)
-       (Mov rcx n)
-       pad-stack
-       (Call 'alloc_val)
-       unpad-stack
-       ;(Mov rbx rax)
-       (Mov rax r15)))
-         
+ (seq (Mov rdi rsp)
+      (Mov rsi rbp)
+      (Mov rdx rbx)
+      (Mov rcx n)
+      pad-stack
+      (Call 'alloc_val)
+      unpad-stack
+      (Mov rbx rax)))
+
 ;; Op2 -> Asm
 (define (compile-op2 p)
   (match p
@@ -177,44 +175,52 @@
           (let ((true (gensym)))
             (seq (Je true)
                  (Mov rax val-false)
-                 (Label true))))]    
+                 (Label true))))]
+    ;; tricky: if you have a pointer in a register, GC might collect
+    ;; what it points to and create a dangling reference
     ['cons
-     (seq (allocate 2)
-          (Mov (Offset rbx 0) rax) ;; ALLOCATE
+     (seq (Push rax)
+          (allocate 2)
+          (Pop rax)
+          (Mov (Offset rbx 0) rax)
           (Pop rax)
           (Mov (Offset rbx 8) rax)
           (Mov rax rbx)
           (Or rax type-cons)
           (Add rbx 16))]
     ['eq?
      (seq (Pop r8)
-          (eq r8 rax))]     
+          (eq r8 rax))]
     ['make-vector
      (let ((loop (gensym))
            (done (gensym))
            (empty (gensym)))
-       (seq (Pop r14)
-            (assert-natural r14)
-            (Cmp r14 0) ; special case empty vector
+       (seq (Pop r8)
+            (assert-natural r8)
+            (Cmp r8 0) ; special case empty vector
             (Je empty)
-            
-            (Sar r14 int-shift)
 
-            (Add r14 1)
-            (allocate r14)
-            (Sub r14 1)
+
+            (Push rax)
+            (Mov rax r8)
+            (Sar rax int-shift)
+            (Add rax 1)
+            (allocate rax)
+            (Pop rax)
+
 
             (Mov r9 rbx)
             (Or r9 type-vect)
-            
-            (Mov (Offset rbx 0) r14)
-            (Add rbx 8)  ;; ALLOCATE
+
+            (Sar r8 int-shift)
+            (Mov (Offset rbx 0) r8)
+            (Add rbx 8)
 
             (Label loop)
             (Mov (Offset rbx 0) rax)
-            (Add rbx 8)  ;; ALLOCATE
-            (Sub r14 1)
-            (Cmp r14 0)
+            (Add rbx 8)
+            (Sub r8 1)
+            (Cmp r8 0)
             (Jne loop)
 
             (Mov rax r9)
@@ -223,7 +229,6 @@
             (Label empty)
             (Mov rax type-vect)
             (Label done)))]
-
     ['vector-ref
      (seq (Pop r8)
           (assert-vector r8)
@@ -250,12 +255,23 @@
             (Cmp r8 0) ; special case empty string
             (Je empty)
 
+            (Push rax)
+            (Mov rax r8)
+            (Sar rax int-shift)
+            (Add rax 1) ; adds 1
+            (Sar rax 1) ; when
+            (Sal rax 1) ; len is odd
+            (Add rax 1)
+            (allocate rax)
+            (Pop rax)
+
+
             (Mov r9 rbx)
             (Or r9 type-str)
 
             (Sar r8 int-shift)
             (Mov (Offset rbx 0) r8)
-            (Add rbx 8) ;; ALLOCATE
+            (Add rbx 8)
 
             (Sar rax char-shift)
 
@@ -265,7 +281,7 @@
 
             (Label loop)
             (Mov (Offset rbx 0) eax)
-            (Add rbx 4) ;; ALLOCATE
+            (Add rbx 4)
             (Sub r8 1)
             (Cmp r8 0)
             (Jne loop)
@@ -277,6 +293,7 @@
             (Mov rax type-str)
             (Label done)))]
 
+
     ['string-ref
      (seq (Pop r8)
           (assert-string r8)

langs/iniquity-gc/compile.rkt

@@ -88,6 +88,9 @@
     (if (zero? len)
         (seq (Mov rax type-str))
         (seq (Mov rax len)
+             (Push rax)
+             (allocate (add1 (quotient (add1 len) 2)))
+             (Pop rax)
              (Mov (Offset rbx 0) rax)
              (compile-string-chars (string->list s) 8)
              (Mov rax rbx)

langs/iniquity-gc/gc.c

@@ -29,17 +29,17 @@ void step(val_t** to_curr, val_t** to_next, int count, int* t_back) {
   val_t *ptr_v;
   for (i = 0; i < count; i++) {
     v = **to_curr;
-    ptr_v = val_unwrap(v);
     t = val_typeof(v);
     switch (t) {
     case T_BOX:
     case T_CONS:
     case T_VECT:
     case T_STR:
+      ptr_v = val_unwrap(v);
       if (ptr_v >= from && ptr_v < from + heap_size) {
 	// this is a pointer to from space so we need to deal with it
-	if (val_unwrap(*ptr_v) >= to &&
-	    val_unwrap(*ptr_v) < to + heap_size) {
+	if  (val_unwrap(*ptr_v) >= to &&
+	     val_unwrap(*ptr_v) < to + heap_size) {
 	  // it points to a fwd pointer (points in to to-space), so just set
 	  // curr to what it points to.
 	  **to_curr = *ptr_v;
@@ -70,6 +70,10 @@ void step(val_t** to_curr, val_t** to_next, int count, int* t_back) {
 
 
 int64_t* collect_garbage(int64_t* rsp, int64_t *rbp, int64_t* rbx) {
+
+  printf("Collect garbage: rsp = %" PRIx64 ", rbp = %" PRIx64 ", rbx = %" PRIx64 "\n",
+	 (int64_t)rsp, (int64_t)rbp, (int64_t)rbx);
+
   int stack_count = rbp - rsp;
 
   val_t *tmp;
@@ -82,7 +86,6 @@ int64_t* collect_garbage(int64_t* rsp, int64_t *rbp, int64_t* rbx) {
   // Step through everything on the stack
   val_t *rsp_curr = rsp;
   step(&rsp_curr, &to_next, stack_count, &t_back);
-
   int vi;
   // now play catch up between to_curr and to_next
   while (to_curr != to_next) {
@@ -139,8 +142,9 @@ int64_t* alloc_val(int64_t* rsp, int64_t* rbp, int64_t* rbx, int words) {
     rbx = collect_garbage(rsp, rbp, rbx);
     if (rbx + words >= from + heap_size) {
       printf("OUT OF MEMORY!!\n");
-      exit(1);
+      error_handler();
     }
   }
+  // printf("returning %" PRIx64 "\n", (int64_t)rbx);
   return rbx;
 }

langs/iniquity-gc/interp.rkt

@@ -40,6 +40,8 @@
     [(Prim0 'void) (void)]
     [(Prim0 'read-byte) (read-byte)]
     [(Prim0 'peek-byte) (peek-byte)]
+    [(Prim0 'dump-memory-stats) (dump-memory-stats)]
+    [(Prim0 'collect-garbage) (collect-garbage)]
     [(Prim1 p e)
      (match (interp-env e r ds)
        ['err 'err]

langs/iniquity-gc/test/test-runner.rkt

@@ -107,7 +107,7 @@
   (check-equal? (run '(eq? (cons 1 2) (cons 1 2))) #f)
   (check-equal? (run '(let ((x (cons 1 2))) (eq? x x))) #t)
 
-  ;; Hoax examples
+  ;; Hoax examples 
   (check-equal? (run '(make-vector 0 0)) #())
   (check-equal? (run '(make-vector 1 0)) #(0))
   (check-equal? (run '(make-vector 3 0)) #(0 0 0))
@@ -126,9 +126,9 @@
   (check-equal? (run '(let ((x (make-vector 3 5)))
                         (begin (vector-set! x 1 4)
                                x)))
-                #(5 4 5))
+                #(5 4 5))  
   (check-equal? (run '(vector-length (make-vector 3 #f))) 3)
-  (check-equal? (run '(vector-length (make-vector 0 #f))) 0)
+  (check-equal? (run '(vector-length (make-vector 0 #f))) 0)  
   (check-equal? (run '"") "")
   (check-equal? (run '"fred") "fred")
   (check-equal? (run '"wilma") "wilma")
@@ -179,7 +179,38 @@
                         (cons (add1 (car xs))
                               (map-add1 (cdr xs)))))
                  '(map-add1 (cons 1 (cons 2 (cons 3 '())))))
-                '(2 3 4)))
+                '(2 3 4))  
+
+  (check-equal? (run '(collect-garbage)) (void))
+  (check-equal? (run '(begin (box 0) (collect-garbage))) (void))
+  (check-equal? (run '(begin (collect-garbage) (box 0))) (box 0))
+  (check-equal? (run '(let ((x (box 0))) (collect-garbage))) (void))  
+  (check-equal? (run '(let ((x (box 0)))
+                        (begin (collect-garbage)
+                               x)))
+                (box 0))
+  ;; GC tests
+  (check-equal? (run
+                 '(define (n-boxes n)
+                    (if (zero? n)
+                        (void)
+                        (begin (box 0)
+                               (n-boxes (sub1 n)))))
+                 '(n-boxes 10001)) 
+                (void))
+
+  ;; can't test this in the interpreter, because it doesn't exhaust the heap there.
+  #;
+  (check-equal? (run
+                 '(define (nested-boxes n)
+                    (if (zero? n)
+                        (void)
+                        (box (nested-boxes (sub1 n)))))
+                 '(begin (nested-boxes 10001) (void)))
+                'err)
+  )
+
+                 
 
 (define (test-runner-io run)
   ;; Evildoer examples