simplistic mark-sweep

gc.lisp

(defpackage #:mark-sweep
  (:use #:cl)
  (:shadow #:room)
  (:export #:test))

(in-package #:mark-sweep)

(defconstant +memory-size+ 1000)
(defvar *memory* (make-array +memory-size+))
(defvar *free* (make-array +memory-size+ :element-type 'bit :initial-element 1))
(defvar *mark* (make-array +memory-size+))
(defvar *root* (make-array +memory-size+ :element-type 'bit :initial-element 0))

;; internal operators
(defun valid-index-p (index)
  (and (integerp index) (<= 0 index) (< index +memory-size+)))

;; exports
(defun @ (index) (aref *memory* index))

(defun room () (count 1 *free*))

(defun reset ()
  (fill *free* 1)
  (fill *root* 0)
  (values))

(defun kons (car-index cdr-index)
  (assert (valid-index-p car-index))
  (assert (valid-index-p cdr-index))
  (let ((free (position 1 *free*)))
    (when (null free) (error "OOM"))
    (setf (aref *free* free) 0
          (aref *memory* free) (cons car-index cdr-index))
    free))

(defun root (index)
  (assert (valid-index-p index))
  (when (= 1 (aref *free* index)) (error "Cannot root unallocated memory"))
  (setf (aref *root* index) 1))

(defun gc ()
  ;; mark
  (fill *mark* 0)
  (labels ((mark (index)
             (unless (= (aref *mark* index) 1)
               (setf (aref *mark* index) 1)
               (mark (car (@ index)))
               (mark (cdr (@ index))))))
    (loop for i below +memory-size+
          when (= 1 (aref *root* i)) do (mark i)))
  ;; sweep
  (loop for i below +memory-size+
        unless (= 1 (aref *mark* i)) do (setf (aref *free* i) 1))
  (values))

;; example
(defun test ()
  (reset)
  (let ((nail (kons 0 0))) ; "nil" = #1=(#1# . #1#), arbitrarily
    (setf (car (@ nail)) nail (cdr (@ nail)) nail)
    (let ((root (kons 0 nail))) ; #2=(#2# . nil) is our one root
      (setf (car (@ root)) root)
      (root root))
    ;; cons up some garbage
    (loop repeat 23 do (kons 0 0)))
  (fresh-line)
  (format t "memory: ~s~%" (subseq *memory* 0 30))
  (format t "free: ~s~%" (subseq *free* 0 30))
  (format t "roots: ~s~%" (subseq *root* 0 30))
  (format t "~&Room before GC: ~d~%" (room))
  (gc)
  (format t "~&Room after GC: ~d~%" (room))
  (format t "free: ~s~%" (subseq *free* 0 30)))