Add precompilation of static queries at compile time
Imagine a function like this:
(defun legal-moves ()
(query (legal ?who ?move)))
The argument to `query` there is constant, so we can compile it into WAM
bytecode once, when the Lisp function around it is compiled. Then running the
query doesn't need to touch the Bones compiler -- it can just load the bytecode
from an array and first up the VM loop.
This saves a lot of time (and consing) compared to compiling the same query over
and over at runtime.
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Sun, 17 Jul 2016 16:49:06 +0000 |
| parents |
f1ef8f905a1d |
| children |
(none) |
(in-package #:bones.wam)
(defun heap-debug (wam address indent-p)
(format
nil "~A~A"
(if indent-p
" "
"")
(cell-typecase (wam address)
((:reference r) (if (= address r)
"unbound variable "
(format nil "var pointer to ~8,'0X " r)))
((:structure s) (format nil "struct pointer to ~8,'0X " s))
((:functor f) (format nil "functor symbol ~A " f))
((:constant c) (format nil "constant symbol ~A " c))
(t ""))))
(defun dump-cell-value (value)
;; todo flesh this out
(typecase value
(fixnum (format nil "~16,'0X" value))
(t (format nil "~16<#<lisp object>~;~>"))))
(defun dump-heap (wam from to)
;; This code is awful, sorry.
(format t "HEAP~%")
(format t " +----------+-----+------------------+--------------------------------------+~%")
(format t " | ADDR | TYP | VALUE | DEBUG |~%")
(format t " +----------+-----+------------------+--------------------------------------+~%")
(when (> from (1+ +heap-start+))
(format t " | ⋮ | ⋮ | ⋮ | |~%"))
(flet ((print-cell (address indent)
(format t " | ~8,'0X | ~A | ~16,'0X | ~36A |~%"
address
(cell-type-short-name (wam-store-type wam address))
(dump-cell-value (wam-store-value wam address))
(heap-debug wam address (plusp indent)))))
(loop :with indent = 0
:for address :from from :below to
:do (progn
(print-cell address indent)
(cell-typecase (wam address)
((:functor f n) (declare (ignore f)) (setf indent n))
(t (when (not (zerop indent))
(decf indent)))))))
(when (< to (wam-heap-pointer wam))
(format t " | ⋮ | ⋮ | ⋮ | |~%"))
(format t " +----------+-----+------------------+--------------------------------------+~%")
(values))
(defun dump-stack-frame (wam start-address)
(loop :with remaining = nil
:with arg-number = nil
:for address :from start-address
:for offset :from 0
:for type = (wam-store-type wam address)
:for value = (wam-store-value wam address)
:while (or (null remaining) (plusp remaining))
:do (format
t " | ~8,'0X | ~A | ~30A|~A~A~A~%"
address
(dump-cell-value value)
(cond
((= address +stack-start+) "")
((= offset 0) "CE ===========================")
((= offset 1) "CP")
((= offset 2) "CUT")
((= offset 3) (progn
(setf remaining value
arg-number 0)
(format nil "N: ~D" value)))
(t (prog1
(format nil " Y~D: ~A ~A"
arg-number
(cell-type-short-name type)
(dump-cell-value value))
(decf remaining)
(incf arg-number))))
(if (= address (wam-environment-pointer wam)) " <- E" "")
(if (= address (wam-backtrack-pointer wam)) " <- B" "")
(if (= address (wam-cut-pointer wam)) " <- CUT" ""))
:finally (return address)))
(defun dump-stack-choice (wam start-address)
(loop :with remaining = nil
:with arg-number = nil
:for address :from start-address
:for offset :from 0
:for type = (wam-store-type wam address)
:for value = (wam-store-value wam address)
:while (or (null remaining) (plusp remaining))
:do (format
t " | ~8,'0X | ~A | ~30A|~A~A~A~%"
address
(dump-cell-value value)
(cond
((= address +stack-start+) "")
((= offset 0) (progn
(setf remaining value
arg-number 0)
(format nil "N: ~D =============" value)))
((= offset 1) "CE saved env pointer")
((= offset 2) "CP saved cont pointer")
((= offset 3) "CB previous choice")
((= offset 4) "BP next clause")
((= offset 5) "TR saved trail pointer")
((= offset 6) "H saved heap pointer")
(t (prog1
(format nil " A~D: ~A ~A"
arg-number
(cell-type-short-name type)
(dump-cell-value value))
(decf remaining)
(incf arg-number))))
(if (= address (wam-environment-pointer wam)) " <- E" "")
(if (= address (wam-backtrack-pointer wam)) " <- B" "")
(if (= address (wam-cut-pointer wam)) " <- CUT" ""))
:finally (return address)))
(defun dump-stack (wam)
(format t "STACK~%")
(format t " +----------+------------------+-------------------------------+~%")
(format t " | ADDR | VALUE | |~%")
(format t " +----------+------------------+-------------------------------+~%")
(with-accessors ((e wam-environment-pointer) (b wam-backtrack-pointer)) wam
(when (not (= +stack-start+ e b))
(loop :with address = (1+ +stack-start+)
:while (< address (wam-stack-top wam))
:do (cond
((= address e) (setf address (dump-stack-frame wam address)))
((= address b) (setf address (dump-stack-choice wam address)))
(t
(format t " | ~8,'0X | | |~%" address)
(incf address))))))
(format t " +----------+------------------+-------------------------------+~%"))
(defun pretty-functor (functor)
(etypecase functor
(symbol (format nil "~A/0" functor))
(cons (destructuring-bind (symbol . arity) functor
(format nil "~A/~D" symbol arity)))))
(defun pretty-argument (argument)
(typecase argument
(fixnum (format nil "~4,'0X" argument))
(t (format nil "#<*>"))))
(defun pretty-arguments (arguments)
(format nil "~10<~{ ~A~}~;~>" (mapcar #'pretty-argument arguments)))
(defgeneric instruction-details (opcode arguments))
(defmethod instruction-details ((opcode t) arguments)
(format nil "~A~A"
(opcode-short-name opcode)
(pretty-arguments arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments)
(format nil "GETS~A ; X~A = ~A/~D"
(pretty-arguments arguments)
(third arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments)
(format nil "PUTS~A ; X~A <- new ~A/~D"
(pretty-arguments arguments)
(third arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments)
(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)
(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)
(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)
(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)
(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)
(format nil "PVAR~A ; Y~A <- A~A <- new unbound REF"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments)
(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)
(format nil "PVLU~A ; A~A <- Y~A"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments)
(format nil "CALL~A ; call ~A/~D"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-jump+)) arguments)
(format nil "JUMP~A ; jump ~A/~D"
(pretty-arguments arguments)
(first arguments)
(second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-dynamic-call+)) arguments)
(format nil "DYCL~A ; dynamic call"
(pretty-arguments arguments)))
(defmethod instruction-details ((opcode (eql +opcode-dynamic-jump+)) arguments)
(format nil "DYJP~A ; dynamic jump"
(pretty-arguments arguments)))
(defmethod instruction-details ((opcode (eql +opcode-get-constant+)) arguments)
(format nil "GCON~A ; X~A = CONSTANT ~A"
(pretty-arguments arguments)
(second arguments)
(pretty-functor (first arguments))))
(defmethod instruction-details ((opcode (eql +opcode-put-constant+)) arguments)
(format nil "PCON~A ; X~A <- CONSTANT ~A"
(pretty-arguments arguments)
(second arguments)
(pretty-functor (first arguments))))
(defmethod instruction-details ((opcode (eql +opcode-subterm-constant+)) arguments)
(format nil "SCON~A ; SUBTERM CONSTANT ~A"
(pretty-arguments arguments)
(pretty-functor (first arguments))))
(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments)
(format nil "GLST~A ; X~A = [vvv | vvv]"
(pretty-arguments arguments)
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments)
(format nil "PLST~A ; X~A = [vvv | vvv]"
(pretty-arguments arguments)
(first arguments)))
(defun functor-table (wam)
(loop
:with result = (make-hash-table)
:for arity :from 0
:for table :across (wam-code-labels wam)
:when table
:do (maphash (lambda (functor loc)
(setf (gethash loc result)
(cons functor arity)))
table)
:finally (return result)))
(defun dump-code-store (wam code-store
&optional
(from 0)
(to (length code-store)))
;; This is a little trickier than might be expected. We have to walk from
;; address 0 no matter what `from` we get, because instruction sizes vary and
;; aren't aligned. So if we just start at `from` we might start in the middle
;; of an instruction and everything would be fucked.
(let ((addr 0)
(lbls (functor-table wam))) ; oh god
(while (< addr to)
(let ((instruction (retrieve-instruction code-store addr)))
(when (>= addr from)
(when (not (= +opcode-noop+ (aref instruction 0)))
(let ((lbl (gethash addr lbls))) ; forgive me
(when lbl
(format t ";;;; BEGIN ~A~%"
(pretty-functor lbl))))
(format t ";~A~4,'0X: "
(if (= (wam-program-counter wam) addr)
">>"
" ")
addr)
(format t "~A~%" (instruction-details (aref instruction 0)
(rest (coerce instruction 'list))))))
(incf addr (length instruction))))))
(defun dump-code
(wam
&optional
(from (max (- (wam-program-counter wam) 8) ; wow
0)) ; this
(to (min (+ (wam-program-counter wam) 8) ; is
(length (wam-code wam))))) ; bad
(format t "CODE (size: ~D frame(s) / ~:[OPEN~;CLOSED~])~%"
(length (wam-logic-stack wam))
(wam-logic-closed-p wam))
(dump-code-store wam (wam-code wam) from to))
(defun dump-wam-registers (wam)
(format t "REGISTERS:~%")
(format t "~5@A -> ~8X~%" "S" (wam-subterm wam))
(loop :for register :from 0 :to +register-count+
:for type = (wam-store-type wam register)
:for value = (wam-store-value wam register)
:when (not (cell-type-p (wam register) :null))
:do (format t "~5@A -> ~A ~A ~A~%"
(format nil "X~D" register)
(cell-type-short-name type)
(dump-cell-value value)
(format nil "; ~A" (first (extract-things wam (list register)))))))
(defun dump-wam-trail (wam)
(format t " TRAIL: ")
(loop :for address :across (wam-trail wam) :do
(format t "~8,'0X //" address))
(format t "~%"))
(defun dump-wam (wam from to)
(format t " FAIL: ~A~%" (wam-fail wam))
(format t " BACKTRACKED?: ~A~%" (wam-backtracked wam))
(format t " MODE: ~S~%" (wam-mode wam))
(format t " HEAP SIZE: ~A~%" (- (wam-heap-pointer wam) +heap-start+))
(format t " PROGRAM COUNTER: ~4,'0X~%" (wam-program-counter wam))
(format t "CONTINUATION PTR: ~4,'0X~%" (wam-continuation-pointer wam))
(format t " ENVIRONMENT PTR: ~4,'0X~%" (wam-environment-pointer wam))
(format t " BACKTRACK PTR: ~4,'0X~%" (wam-backtrack-pointer wam))
(format t " CUT PTR: ~4,'0X~%" (wam-cut-pointer wam))
(format t "HEAP BCKTRCK PTR: ~4,'0X~%" (wam-heap-backtrack-pointer wam))
(dump-wam-trail wam)
(dump-wam-registers wam)
(format t "~%")
(dump-heap wam from to)
(format t "~%")
(dump-stack wam)
(format t "~%")
(dump-code wam))
(defun dump-wam-query-code (wam &optional (max +maximum-query-size+))
(with-slots (code) wam
(dump-code-store wam code 0 max)))
(defun dump-wam-code (wam)
(with-slots (code) wam
(dump-code-store wam code +maximum-query-size+ (length code))))
(defun dump-wam-full (wam)
(dump-wam wam (1+ +heap-start+) (wam-heap-pointer wam)))