Make L2 work properly
This changes a lot of things.
First, we split apart all the register-using opcodes into local and stack
variants, and tear out the register designator stuff. This is ugly, but will be
way faster because the check doesn't need to happen at runtime any more. It's
made slightly less ugly with a real nasty macro.
We also change how the head and first body term in clauses interact. It turns
out the head needs to respect the arity of the first body clause (if it's
larger), and the two clauses need to share local variable register assignments.
Apparently when HAK says "compiled as one unit" in the book he means this.
Would have been nice if he could have explained that, or at least showed an
example that makes use of it so I have a chance of noticing it.
Still to do before we move on to L3:
* Add a few comments to document the stuff added in this commit.
* Rework the query code store to fall at the beginning of the `CODE` section so
we can just have one program counter and interpreter function to rule them
all.
* Consider figuring out the answer extraction process (we basically need to
modify the query compiler to treat all variables as permanent, and keep that
mapping so we can extract them from the stack at the very end).
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Sun, 17 Apr 2016 21:36:15 +0000 |
| parents |
2f0b5c92febe |
| children |
902d171a1a85 |
(in-package #:bones.wam)
(defun registers-pointing-to (wam addr)
(loop :for reg :across (wam-local-registers wam)
:for i :from 0
:when (= reg addr)
:collect i))
(defun heap-debug (wam addr cell indent-p)
(format
nil "~A~A~{<-X~A ~}"
(if indent-p
" "
"")
(switch ((cell-type cell))
(+tag-reference+
(if (= addr (cell-value cell))
"unbound variable "
(format nil "var pointer to ~4,'0X " (cell-value cell))))
(+tag-structure+
(format nil "structure pointer to ~4,'0X " (cell-value cell)))
(+tag-functor+
(destructuring-bind (functor . arity)
(wam-functor-lookup wam (cell-functor-index cell))
(format nil "~A/~D " functor arity)))
(t ""))
(registers-pointing-to wam addr)))
(defun dump-heap (wam from to highlight)
;; This code is awful, sorry.
(let ((heap (wam-heap wam)))
(format t "HEAP~%")
(format t " +------+-----+----------+--------------------------------------+~%")
(format t " | ADDR | TYP | VALUE | DEBUG |~%")
(format t " +------+-----+----------+--------------------------------------+~%")
(when (> from 0)
(format t " | ⋮ | ⋮ | ⋮ | |~%"))
(flet ((print-cell (i cell indent)
(let ((hi (= i highlight)))
(format t "~A ~4,'0X | ~A | ~8,'0X | ~36A ~A~%"
(if hi "==>" " |")
i
(cell-type-short-name cell)
(cell-value cell)
(heap-debug wam i cell (> indent 0))
(if hi "<===" "|")))))
(loop :for i :from from :below to
:with indent = 0
:for cell = (aref heap i)
:do
(progn
(print-cell i cell indent)
(if (cell-functor-p cell)
(setf indent (wam-functor-arity wam (cell-functor-index cell)))
(when (not (zerop indent))
(decf indent))))))
(when (< to (length heap))
(format t " | ⋮ | ⋮ | ⋮ | |~%"))
(format t " +------+-----+----------+--------------------------------------+~%")
(values)))
(defun dump-stack (wam &optional (e (wam-environment-pointer wam)))
(format t "STACK~%")
(format t " +------+----------+-------------------------------+~%")
(format t " | ADDR | VALUE | |~%")
(format t " +------+----------+-------------------------------+~%")
(loop :with n = nil
:with arg = 0
:for offset = 0 :then (1+ offset)
:for cell :across (wam-stack wam)
:for addr :from 0 :do
(format t " | ~4,'0X | ~8,'0X | ~30A|~A~A~%"
addr
cell
(cond
((= offset 0) "CE ===========================")
((= offset 1) "CP")
((= offset 2)
(if (zerop cell)
(progn
(setf offset -1)
"N: EMPTY")
(progn
(setf n cell)
(format nil "N: ~D" cell))))
((< arg n)
(prog1
(format nil " Y~D: ~4,'0X"
arg
;; look up the actual cell in the heap
(cell-aesthetic (wam-heap-cell wam cell)))
(when (= n (incf arg))
(setf offset -1
n nil
arg 0)))))
(if (= addr (wam-environment-pointer wam)) " <- E" "")
(if (= addr e) " <- FRAME" "")))
(format t " +------+----------+-------------------------------+~%"))
(defun pretty-functor (functor-index functor-list)
(when functor-list
(destructuring-bind (symbol . arity)
(elt functor-list functor-index)
(format nil "~A/~D" symbol arity))))
(defun pretty-arguments (arguments)
(format nil "~{ ~4,'0X~}" arguments))
(defgeneric instruction-details (opcode arguments functor-list))
(defmethod instruction-details ((opcode t) arguments functor-list)
(format nil "~A~A"
(opcode-short-name opcode)
(pretty-arguments arguments)))
(defmethod instruction-details ((opcode (eql +opcode-set-variable-local+)) arguments functor-list)
(format nil "SVAR~A ; X~A <- new unbound REF"
(pretty-arguments arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-set-variable-stack+)) arguments functor-list)
(format nil "SVAR~A ; Y~A <- new unbound REF"
(pretty-arguments arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-set-value-local+)) arguments functor-list)
(format nil "SVLU~A ; new REF to X~A"
(pretty-arguments arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-set-value-stack+)) arguments functor-list)
(format nil "SVLU~A ; new REF to Y~A"
(pretty-arguments arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-structure-local+)) arguments functor-list)
(format nil "GETS~A ; X~A = ~A"
(pretty-arguments arguments)
(second arguments)
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-get-structure-stack+)) arguments functor-list)
(format nil "GETS~A ; Y~A = ~A"
(pretty-arguments arguments)
(second arguments)
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-put-structure-local+)) arguments functor-list)
(format nil "PUTS~A ; X~A <- new ~A"
(pretty-arguments arguments)
(second arguments)
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-put-structure-stack+)) arguments functor-list)
(format nil "PUTS~A ; Y~A <- new ~A"
(pretty-arguments arguments)
(second arguments)
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments functor-list)
(format nil "GVAR~A ; X~A <- A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-variable-stack+)) arguments functor-list)
(format nil "GVAR~A ; Y~A <- A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-value-local+)) arguments functor-list)
(format nil "GVLU~A ; X~A = A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-value-stack+)) arguments functor-list)
(format nil "GVLU~A ; Y~A = A~A"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-variable-local+)) arguments functor-list)
(format nil "PVAR~A ; X~A <- A~A <- new unbound REF"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-variable-stack+)) arguments functor-list)
(format nil "PVAR~A ; Y~A <- A~A <- new unbound REF"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments functor-list)
(format nil "PVLU~A ; A~A <- X~A"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-value-stack+)) arguments functor-list)
(format nil "PVLU~A ; A~A <- Y~A"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
(format nil "CALL~A ; ~A"
(pretty-arguments arguments)
(pretty-functor (first arguments) functor-list)))
(defun dump-code-store (wam code-store
&optional
(from 0)
(to (length code-store)))
(let ((addr from)
(lbls (bones.utils::invert-hash-table (wam-code-labels wam)))) ; oh god
(while (< addr to)
(let ((lbl (gethash addr lbls))) ; forgive me
(when lbl
(format t ";;;; BEGIN ~A~%"
(pretty-functor lbl (wam-functors wam)))))
(format t ";~A~4,'0X: "
(if (= (wam-program-counter wam) addr)
">>"
" ")
addr)
(let ((instruction (retrieve-instruction code-store addr)))
(format t "~A~%" (instruction-details (aref instruction 0)
(rest (coerce instruction 'list))
(wam-functors wam)))
(incf addr (length instruction))))))
(defun dump-code (wam &optional (from 0) (to (length (wam-code wam))))
(format t "CODE~%")
(dump-code-store wam (wam-code wam) from to))
(defun extract-thing (wam address)
"Extract the thing at the given heap address."
(let ((cell (wam-heap-cell wam (deref wam address))))
(cond
((cell-null-p cell)
"NULL!")
((cell-reference-p cell)
;; TODO: figure out what the hell to return here
(gensym (format nil "var@~4,'0X-" (cell-value cell))))
((cell-structure-p cell)
(extract-thing wam (cell-value cell)))
((cell-functor-p cell)
(destructuring-bind (functor . arity)
(wam-functor-lookup wam (cell-functor-index cell))
(list* functor
(loop :for i :from (1+ address) :to (+ address arity)
:collect (extract-thing wam i)))))
(t (error "What to heck is this?")))))
(defun dump-wam-registers (wam)
(format t "REGISTERS:~%")
(format t "~5@A ->~6@A~%" "S" (wam-s wam))
(loop :for i :from 0
:for reg :across (wam-local-registers wam)
:for contents = (when (not (= reg (1- +heap-limit+)))
(wam-heap-cell wam reg))
:when contents
:do (format t "~5@A ->~6@A ~10A ~A~%"
(format nil "X~D" i)
reg
(cell-aesthetic contents)
(format nil "; ~A" (extract-thing wam reg)))))
(defun dump-wam-functors (wam)
(format t " FUNCTORS: ~S~%" (wam-functors wam)))
(defun dump-labels (wam)
(format t "LABELS:~%~{ ~A -> ~4,'0X~^~%~}~%"
(loop :for functor-index
:being :the :hash-keys :of (wam-code-labels wam)
:using (hash-value address)
:nconc (list (pretty-functor functor-index
(wam-functors wam))
address))))
(defun dump-wam (wam from to highlight)
(format t " FAIL: ~A~%" (wam-fail wam))
(format t " MODE: ~S~%" (wam-mode wam))
(dump-wam-functors wam)
(format t "HEAP SIZE: ~A~%" (length (wam-heap wam)))
(format t "PROGRAM C: ~A~%" (wam-program-counter wam))
(format t "CONT PTR: ~A~%" (wam-continuation-pointer wam))
(format t "ENVIR PTR: ~A~%" (wam-environment-pointer wam))
(dump-wam-registers wam)
(format t "~%")
(dump-heap wam from to highlight)
(format t "~%")
(dump-stack wam)
(format t "~%")
(dump-labels wam)
(dump-code wam))
(defun dump-wam-full (wam)
(dump-wam wam 0 (length (wam-heap wam)) -1))
(defun dump-wam-around (wam addr width)
(dump-wam wam
(max 0 (- addr width))
(min (length (wam-heap wam))
(+ addr width 1))
addr))