Add tests from TAOP section 2.3
| author |
Steve Losh <steve@stevelosh.com> |
| date |
Sun, 24 Jul 2016 12:44:54 +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)))