;;; Garbage collector

(define mark
  (lambda (ptr)
    (variant-case ptr
      (pnum (val) (void))
      (pnull () (void))
      (pprim (proc) (void))
      (pclosure (address)
	(unless (marked? address)
	  (mark-cell address #t)
	  (mark-cell (+ address 1) #t)
	  (mark-cell (+ address 2) #t)
	  (for (+ address 3) (+ address 3 (apply-store address))
	    (lambda (i)
	      (mark-cell i #t)
	      (let ((x (apply-store i)))
		(variant-case x
		  (penv-cell (env-cell) (mark (cdr env-cell)))
		  (else (error 'gc "environment cell expected ~s" x))))))))
      (ppair (address)
	(unless (marked? address)
	  (mark-cell address #t)
	  (mark-cell (+ address 1) #t)
	  (mark (apply-store address))
	  (mark (apply-store (+ address 1)))))
      (else (error 'gc "invalid pointer ~s" ptr)))))

(define sweep
  (lambda ()
    (for 0 HEAP-SIZE
      (lambda (i)
	(if (marked? i) (mark-cell i #f) (free-cell i))))))

(define gc
  (lambda (env)
    (for-each (lambda (x) (mark (cdr x))) env)
    (sweep)))