WIP 3.rkt

Final/3.rkt

@@ -58,8 +58,16 @@
               (test/exn (begin oper ...) expected))))]))
 
 (define (swap-spaces!)
-  ;; do nothing
+  (let ([current-offset (off)])
-  (void))
+    (if (= current-offset METADATA-SIZE)
+        ;; If left semi-space, switch to the right
+        (begin
+          (heap-set! LOC:OFFSET (+ METADATA-SIZE (space-size)))
+          (heap-set! LOC:PTR 0))
+        ;; Else switch back to the left semi-space
+        (begin
+          (heap-set! LOC:OFFSET METADATA-SIZE)
+          (heap-set! LOC:PTR 0)))))
 
 (module+ test
 
@@ -89,17 +97,70 @@
   )
 
 ;; malloc : size -> address
-(define (malloc n)
+(define (malloc n . other-roots)
-  (when (> (+ (ptr) n) (space-size))
+  (when (> (+ (ptr) n (length other-roots)) (space-size))
     (gc!))
-  (when (> (+ (ptr) n) (space-size))
+  (when (> (+ (ptr) n (length other-roots)) (space-size))
     (error 'malloc "out of memory!"))
-  (heap-set! LOC:PTR (+ (ptr) n))
+  (heap-set! LOC:PTR (+ (ptr) n (length other-roots)))
-  (+ (heap-ref LOC:OFFSET) (- (ptr) n)))
+  (+ (heap-ref LOC:OFFSET) (- (ptr) n (length other-roots))))
 
-(define (gc!)
+(define (forward/root thing)
-  ;; do nothing
+  (define addr (read-root thing))
-  (void))
+  (cond
+    [(gc:flat? addr) (gc:alloc-flat (gc:deref addr))]
+    [(gc:cons? addr) (gc:cons (gc:first thing) (gc:rest addr))]
+    [(gc:closure? addr) (gc:closure (gc:closure-code-ptr addr) (empty))]))
+
+(define (forward/loc thing)
+  (define tag (heap-ref thing))
+  (cond
+    [(equal? tag 'forwarded)
+     (void)]
+    [(equal? tag 'flat)
+     (heap-set! thing 'forwarded)
+     (heap-set! (+ thing 1) (gc:alloc-flat (heap-ref (+ thing 1))))]
+    [(equal? tag 'cons)
+     (heap-set! thing 'forwarded)
+     (heap-set! (+ thing 1) (gc:cons
+                             (simple-root (heap-ref (+ thing 1)))
+                             (simple-root (heap-ref (+ thing 2)))))]
+    [(equal? tag 'clos)
+     (let* ([code-ptr (heap-ref (+ thing 1))]
+            [n-vars (heap-ref (+ thing 2))]
+            [free-vars (for/list ([i (in-range n-vars)])
+                         (simple-root (heap-ref (+ thing 3 i))))])
+       (heap-set! thing 'forwarded)
+       (heap-set! (+ thing 1) (gc:closure code-ptr free-vars)))]
+    [else
+     (error 'forward/loc "Unknown tag: ~a" tag)]))
+
+
+(define (object-size addr)
+  (define tag (heap-ref addr))
+  (cond
+    [(equal? tag 'flat) 2]
+    [(equal? tag 'cons) 3]
+    [(equal? tag 'clos)
+     (let ([n-vars (+ addr 2)])
+       (+ 3 n-vars))]
+    [(equal? tag 'forwarded) 2]
+    [else
+     (error 'object-size "Unknown tag: ~a" tag)]))
+
+(define (gc! . other-roots)
+  (swap-spaces!)
+  (heap-set! LOC:PTR 0)  ; Reset the allocation pointer in the new semi-space
+
+  ;; Forward all roots to the new semi-space
+  (for-each forward/root (get-root-set))
+  (for-each forward/root other-roots)
+
+  ;; Forward all objects reachable from the roots
+  (let loop ([scan (off)])
+    (when (< scan (ptr))
+      (forward/loc scan)
+      (loop (+ scan (object-size scan))))))
 
 ;; gc:alloc-flat : flat-value -> address
 (define (gc:alloc-flat value)