GCの可視化をしようとしている。

GCでのメモリの様子などを可視化するとおもしろいかもなぁとおもい
とりあえず一時間ほどで書いてみました。Mark&Sweepをしています。（かなり初歩的な部分しかしていませんが）

(defclass <lobject> ()
  ((mark :initform nil :initarg :mark :accessor mark)
   (next :initform nil :initarg :next :accessor next)))

(defclass <cons> (<lobject>)
  ((car-ref :initarg :car-ref :accessor car-ref)
   (cdr-ref :initarg :cdr-ref :accessor cdr-ref)))

(defun create-cons (car-lobj cdr-lobj)
  (make-instance '<cons>
                 :car-ref car-lobj
                 :cdr-ref cdr-lobj))

(defclass <atom> (<lobject>)
  ((val :initform nil :initarg :val :accessor val)))

(defparameter *max-atom* 25)
(defparameter *max-cons* 25)

(defclass <bind-table> ()
  ((bind-table :initform nil :accessor bind-table)))

(defmethod bind ((table <bind-table>) (symb Symbol) (lobj <lobject>))
  (push
    (cons symb lobj)
    (bind-table table)))

(defmethod unbind ((table <bind-table>)
                   (symb Symbol))
  (setf (bind-table table)
        (remove-if (lambda (bind)
                     (eql (car bind) symb))
                   (bind-table table))))

(defmethod lookup ((table <bind-table>) (symb Symbol))
  (assoc symb (bind-table table)))

(defclass <lisp-vm> ()
  ((free-atoms :initform 
               (make-array *max-atom*
                           :initial-contents
                           (loop repeat *max-atom*
                                 for new-atom = (make-instance '<atom>)
                                 collect new-atom))
               :accessor free-atoms)
   (free-cells :initform
               (make-array *max-cons*
                           :initial-contents
                           (loop repeat *max-cons*
                                 for new-cons = (make-instance '<cons>)
                                 collect new-cons))
                           :accessor free-cells)
   (bind-table :initform 
               (make-instance '<bind-table>)
               :accessor bind-table)
   (free-cell-top :accessor free-cell-top)
   (free-cell-bottom :accessor free-cell-bottom)
   (free-atom-top :accessor free-atom-top)
   (free-atom-bottom :accessor free-atom-bottom)))

(defmethod init-vm ((vm <lisp-vm>))
  (with-slots (free-cells free-atoms
                  free-cell-top free-cell-bottom
                  free-atom-top free-atom-bottom) vm
    ;;Initialize free area
    (init-free-cells free-cells)
    (init-free-atoms free-atoms)
    (setf (bind-table (bind-table vm)) nil)
    ;;Setup pointers
    (setf free-cell-top (aref free-cells 0))
    (setf free-cell-bottom (aref free-cells 
                                 (1- (length free-cells))))
    (setf free-atom-top (aref free-atoms 0))
    (setf free-atom-bottom (aref free-atoms
                                 (1- (length free-atoms))))))

(defun init-free-cells (cells)
  (loop for idx from 0 upto (- (length cells) 2)
        for prev-cell = (aref cells idx)
        for next-cell = (aref cells (1+ idx))
        do
        (setf (car-ref prev-cell) nil
              (cdr-ref prev-cell) nil
              (next prev-cell) next-cell)
  (setf (next (aref cells (1- (length cells)))) nil)))

(defun init-free-atoms (atoms)
  (loop for idx from 0 upto (- (length atoms) 2)
        for prev-atom = (aref atoms idx)
        for next-atom = (aref atoms (1+ idx))
        do
        (setf (val prev-atom) nil
              (next prev-atom) next-atom)
  (setf (next (aref atoms (1- (length atoms)))) nil)))


(defun create-vm ()
  (let ((vm (make-instance '<lisp-vm>)))
    (init-vm vm)
    vm))

(defmethod alloc-cons ((vm <lisp-vm>))
  ;;まずフリーリストの先頭を取得
  (let ((new-cons (free-cell-top vm)))
    (if (not (null new-cons))
      (progn
        ;;フリーリストを一つすすめる
        (setf (free-cell-top vm)
            (next (free-cell-top vm)))
        (setf (car-ref new-cons) nil
              (cdr-ref new-cons) nil)
        new-cons)
      (progn
        (run-gc vm)
        (if (not (null (free-cell-top vm)))
          (alloc-cons vm)
          (error "Can't allocate new cons.."))))))

(defmethod alloc-atom ((vm <lisp-vm>))
  (let ((new-atom (free-atom-top vm)))
    (if (not (null new-atom))
      (progn
        (setf (free-atom-top vm)
            (next (free-atom-top vm)))
        (setf (val new-atom) nil)
        new-atom)
      (progn
        (run-gc vm)
        (if (not (null (free-atom-top vm)))
          (alloc-atom vm)
          (error "Can't allocate new atom.."))))))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; 
;;  Mark
;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod recur-mark ((obj <lobject>))
  (error "Unknown object"))

(defmethod recur-mark ((cell <cons>))
  (setf (mark cell) t)
  (when (car-ref cell)
    (recur-mark (car-ref cell)))
  (when (cdr-ref cell)
    (recur-mark (cdr-ref cell))))

(defmethod recur-mark ((atom <atom>))
  (setf (mark atom) t))

(defmethod mark-phrase ((vm <lisp-vm>))
  (loop for bind in (bind-table (bind-table vm))
        do
        (recur-mark (cdr bind))))

(defmethod display-vm-state ((vm <lisp-vm>))
  (princ "Cells: ")
  (loop for cell across (free-cells vm)
        do
        (cond ((mark cell) (format t "*"))
              ((equal (free-cell-top vm) cell)
               (format t "F"))
              ((equal (free-cell-bottom vm) cell)
               (format t "B"))
              (t (format t "-")))
        finally (format t "~%"))
  (princ "Atoms: ")
  (loop for atom across (free-atoms vm)
        do
        (cond ((mark atom) (format t "*"))
              ((equal (free-atom-top vm) atom)
               (format t "F"))
              ((equal (free-atom-bottom vm) atom)
               (format t "B"))
              (t (format t "-")))
        finally (format t "~%"))
  (format t "Bind: ~%~{|~A|~%~}~%" (bind-table (bind-table vm))))

(defmethod bind-val ((vm <lisp-vm>) (sym Symbol) (lobj <lobject>))
  (bind (bind-table vm) sym lobj))

;;;;;;;;;;;;;;;;;
;;
;; Sweep
;;
;;;;;;;;;;;;;;;;;
(defmethod sweep-cells ((vm <lisp-vm>))
  ;;setup free list
  (loop for cell across (free-cells vm)
        until (not (mark cell))
        finally (setf (free-cell-top vm) cell
                      (free-cell-bottom vm) cell))
  (loop for cell across (free-cells vm)
        if (not (mark cell))
        do
        (setf (next (free-cell-bottom vm)) cell)
        (setf (free-cell-bottom vm) cell)
        else
        do
        (setf (mark cell) nil)
        finally (setf (next (free-cell-bottom vm)) nil)))

(defmethod sweep-atoms ((vm <lisp-vm>))
  ;;setup free list
  (loop for atom across (free-atoms vm)
        until (not (mark atom))
        finally (setf (free-atom-top vm) atom
                      (free-atom-bottom vm) atom))
  (loop for atom across (free-atoms vm)
        if (not (mark atom))
        do
        (setf (next (free-atom-bottom vm)) atom)
        (setf (free-atom-bottom vm) atom)
        else
        do
        (setf (mark atom) nil)
        finally (setf (next (free-atom-bottom vm)) nil)))

(defmethod sweep-phrase ((vm <lisp-vm>))
    (sweep-atoms vm)
    (sweep-cells vm))

;;;;
;;; GC
;;; 
(defmethod run-gc ((vm <lisp-vm>))
  (format t "[Garbage collection]~%");
  (mark-phrase vm)
  (sweep-phrase vm))

(defmethod gc-test ((vm <lisp-vm>))
  (loop repeat (+ *max-cons* 5)
        do
        (display-vm-state vm)
        (if (zerop (random 5))
          (bind-val vm (gensym) (alloc-cons vm))
          (alloc-cons vm))))

(defmethod primitive-p (val)
  (or (numberp val)
      (stringp val)))

(defmacro aif (test then else)
  `(let ((it ,test))
     (if it
       ,then
       ,else)))

(defmethod leval ((vm <lisp-vm>) expr)
  (cond ((primitive-p expr)
         (let ((new-atom (alloc-atom vm)))
           (setf (val new-atom) expr)
           new-atom))
        ((symbolp expr)
         (aif (lookup (bind-table vm) expr)
           (cdr it)
           (error "Undefined variable")))
        ((and (eql 'bind (car expr))
              (symbolp (cadr expr)))
         (bind-val vm (cadr expr) 
                   (leval vm (caddr expr))))
        ((and (eql 'cons (car expr))
              (= 2 (length (cdr expr))))
         (let ((new-cons (alloc-cons vm)))
           (setf (car-ref new-cons) (leval vm (cadr expr))
                 (cdr-ref new-cons) (leval vm (caddr expr)))
           new-cons))
        (t (error "Unrecognizable expr"))))

こんな感じです。

CL-USER(2): (defparameter *sample-vm* (create-vm))

*SAMPLE-VM*
CL-USER(3): (display-vm-state *sample-vm*)
Cells: F-----------------------B
Atoms: F-----------------------B
Bind: 

NIL

CL-USER(4): (leval *sample-vm* '(cons 10 10))

#<<CONS> {B6C1B19}>
CL-USER(5): (display-vm-state *sample-vm*)
Cells: -F----------------------B
Atoms: --F---------------------B
Bind: 

NIL

CL-USER(6): (leval *sample-vm* '(bind x 10))

((X . #<<ATOM> {B65E229}>))
CL-USER(7): (display-vm-state *sample-vm*)
Cells: -F----------------------B
Atoms: ---F--------------------B
Bind: 
|(X . #<<ATOM> {B65E229}>)|

NIL

CL-USER(8): (mark-phrase *sample-vm*)

NIL
CL-USER(9): (display-vm-state *sample-vm*)
Cells: -F----------------------B
Atoms: --*F--------------------B
Bind: 
|(X . #<<ATOM> {B65E229}>)|

NIL

CL-USER(10): (sweep-phrase *sample-vm*)

NIL
CL-USER(11): (display-vm-state *sample-vm*)
Cells: F-----------------------B
Atoms: F-----------------------B
Bind: 
|(X . #<<ATOM> {B65E229}>)|

NIL

CL-USER(12): (leval *sample-vm* '(bind y 20))

((Y . #<<ATOM> {B65E1C9}>) (X . #<<ATOM> {B65E229}>))
CL-USER(13): (leval *sample-vm* '(bind z (cons x y)))

((Z . #<<CONS> {B6C1B19}>) (Y . #<<ATOM> {B65E1C9}>) (X . #<<ATOM> {B65E229}>))
CL-USER(14): (display-vm-state *sample-vm*)
Cells: -F----------------------B
Atoms: -F----------------------B
Bind: 
|(Z . #<<CONS> {B6C1B19}>)|
|(Y . #<<ATOM> {B65E1C9}>)|
|(X . #<<ATOM> {B65E229}>)|

NIL

CL-USER(15): (mark-phrase *sample-vm*)

NIL
CL-USER(16): (display-vm-state *sample-vm*)
Cells: *F----------------------B
Atoms: *F*---------------------B
Bind: 
|(Z . #<<CONS> {B6C1B19}>)|
|(Y . #<<ATOM> {B65E1C9}>)|
|(X . #<<ATOM> {B65E229}>)|

NIL
CL-USER(17): (run-gc *sample-vm*)
[Garbage collection]
NIL
CL-USER(18): (display-vm-state *sample-vm*)
Cells: -F----------------------B
Atoms: -F----------------------B
Bind: 
|(Z . #<<CONS> {B6C1B19}>)|
|(Y . #<<ATOM> {B65E1C9}>)|
|(X . #<<ATOM> {B65E229}>)|

NIL

こんな感じでmarkされてsweepされている様子があるていど確認できます。