--- a/bones.asd Sun Apr 10 14:41:50 2016 +0000
+++ b/bones.asd Sun Apr 10 16:02:54 2016 +0000
@@ -28,8 +28,8 @@
(:file "cells")
(:file "opcodes")
(:file "wam")
+ (:file "compile")
(:file "instructions")
- (:file "compile")
(:file "dump")))
(:file "bones")))))
--- a/src/wam/compile.lisp Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/compile.lisp Sun Apr 10 16:02:54 2016 +0000
@@ -395,13 +395,3 @@
(multiple-value-call #'tokenize-assignments))
(compile-program-tokens wam tokens functor arity (wam-code wam))))
-
-(defun run (wam instructions)
- "Execute the machine instructions on the given WAM."
- ; (loop :)
- (mapc (lambda (action)
- (when (not (wam-fail wam))
- (apply (car action) wam (cdr action))))
- instructions)
- (values))
-
--- a/src/wam/constants.lisp Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/constants.lisp Sun Apr 10 16:02:54 2016 +0000
@@ -60,6 +60,7 @@
(define-constant +opcode-get-variable+ 4)
(define-constant +opcode-get-value+ 5)
+
;;; Query
(define-constant +opcode-put-structure+ 6)
(define-constant +opcode-set-variable+ 7)
--- a/src/wam/dump.lisp Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/dump.lisp Sun Apr 10 16:02:54 2016 +0000
@@ -6,18 +6,23 @@
:when (= reg addr)
:collect i))
-(defun heap-debug (wam addr cell)
+(defun heap-debug (wam addr cell indent-p)
(format
- nil "~A~{(X~A) ~}"
+ 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 ~D " (cell-value cell))))
+ (+tag-structure+
+ (format nil "structure pointer to ~D " (cell-value cell)))
(+tag-functor+
- (format nil "~A/~D "
- (wam-functor-lookup wam (cell-functor-index cell))
- (cell-functor-arity cell)))
+ (destructuring-bind (functor . arity)
+ (wam-functor-lookup wam (cell-functor-index cell))
+ (format nil "~A/~D " functor arity)))
(t ""))
(registers-pointing-to wam addr)))
@@ -30,17 +35,25 @@
(format t " +------+-----+--------------+--------------------------------------+~%")
(when (> from 0)
(format t " | ⋮ | ⋮ | ⋮ | |~%"))
- (flet ((print-cell (i cell)
+ (flet ((print-cell (i cell indent)
(let ((hi (= i highlight)))
(format t "~A ~4@A | ~A | ~12@A | ~36A ~A~%"
(if hi "==>" " |")
i
(cell-type-short-name cell)
(cell-value cell)
- (heap-debug wam i cell)
+ (heap-debug wam i cell (> indent 0))
(if hi "<===" "|")))))
(loop :for i :from from :below to
- :do (print-cell i (aref heap i))))
+ :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 " +------+-----+--------------+--------------------------------------+~%")
@@ -56,6 +69,7 @@
(defun pretty-arguments (arguments)
(format nil "~{ ~4,'0X~}" arguments))
+
(defgeneric instruction-details (opcode arguments functor-list))
(defmethod instruction-details ((opcode t) arguments functor-list)
@@ -87,12 +101,6 @@
(pretty-functor (first arguments) functor-list)))
-(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
- (format nil "CALL~A ; ~A"
- (pretty-arguments arguments)
- (pretty-functor (first arguments) functor-list)))
-
-
(defmethod instruction-details ((opcode (eql +opcode-get-variable+)) arguments functor-list)
(format nil "GVAR~A ; A~D -> X~D"
(pretty-arguments arguments)
@@ -105,20 +113,18 @@
(second arguments)
(first arguments)))
-
(defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)
(format nil "PVAR~A ; A~D <- X~D <- new REF"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
-; (defmethod instruction-details ((opcode (eql +opcode-get-value+)) arguments functor-list)
-; )
-; (defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list))
-; (defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list))
-; (defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list))
-; (defmethod instruction-details ((opcode (eql +opcode-proceed+)) arguments functor-list))
+(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 (code-store &optional
(from 0)
@@ -189,8 +195,8 @@
((cell-structure-p cell)
(extract-thing wam (cell-value cell)))
((cell-functor-p cell)
- (let ((functor (wam-functor-lookup wam (cell-functor-index cell)))
- (arity (cell-functor-arity 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)))))
--- a/src/wam/instructions.lisp Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/instructions.lisp Sun Apr 10 16:02:54 2016 +0000
@@ -16,16 +16,10 @@
"
(wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam)))))
-(defun* push-new-functor! ((wam wam) (functor symbol) (arity arity))
+(defun* push-new-functor! ((wam wam) (functor functor-index))
(:returns (values heap-cell heap-index))
- "Push a new functor cell onto the heap.
-
- If the functor isn't already in the functor table it will be added.
-
- "
- (wam-heap-push! wam (make-cell-functor
- (wam-ensure-functor-index wam functor)
- arity)))
+ "Push a new functor cell onto the heap."
+ (wam-heap-push! wam (make-cell-functor functor)))
(defun* bound-reference-p ((wam wam) (address heap-index))
@@ -44,26 +38,18 @@
(and (cell-reference-p cell)
(= (cell-value cell) address)))))
-(defun* matching-functor-p ((wam wam)
- (cell heap-cell)
- (functor symbol)
- (arity arity))
+(defun* matching-functor-p ((cell heap-cell)
+ (functor functor-index))
(:returns boolean)
- "Return whether `cell` is a functor cell of `functor`/`arity`."
+ "Return whether `cell` is a functor cell containing `functor`."
(ensure-boolean
(and (cell-functor-p cell)
- (= arity (cell-functor-arity cell))
- (eql functor
- (wam-functor-lookup wam (cell-functor-index cell))))))
+ (= (cell-functor-index cell) functor))))
(defun* functors-match-p ((functor-cell-1 heap-cell)
(functor-cell-2 heap-cell))
(:returns boolean)
"Return whether the two functor cells represent the same functor."
- ;; Warning: this is a gross, fast hack. Functor cell values are a combination
- ;; of functor index and arity, so the only way they can represent the same
- ;; functor is if they have the same value. We don't have to bother actually
- ;; looking up and comparing the functor symbols themselves.
(= (cell-value functor-cell-1)
(cell-value functor-cell-2)))
@@ -149,19 +135,20 @@
;;;; Query Instructions
(defun* %put-structure ((wam wam)
- (functor symbol)
- (arity arity)
+ (functor functor-index)
(register register-index))
(:returns :void)
- (setf (wam-register wam register)
- (nth-value 1 (push-new-structure! wam)))
- (push-new-functor! wam functor arity)
+ (->> (push-new-structure! wam)
+ (nth-value 1)
+ (setf (wam-register wam register)))
+ (push-new-functor! wam functor)
(values))
(defun* %set-variable ((wam wam) (register register-index))
(:returns :void)
- (setf (wam-register wam register)
- (nth-value 1 (push-unbound-reference! wam)))
+ (->> (push-unbound-reference! wam)
+ (nth-value 1)
+ (setf (wam-register wam register)))
(values))
(defun* %set-value ((wam wam) (register register-index))
@@ -169,11 +156,24 @@
(wam-heap-push! wam (wam-register-cell wam register))
(values))
+(defun* %put-variable ((wam wam)
+ (register register-index)
+ (argument register-index))
+ (->> (push-unbound-reference! wam)
+ (nth-value 1)
+ (setf (wam-register wam register))
+ (setf (wam-register wam argument))))
+
+(defun* %put-value ((wam wam)
+ (register register-index)
+ (argument register-index))
+ (setf (wam-register wam register)
+ (wam-register wam argument)))
+
;;;; Program Instructions
(defun* %get-structure ((wam wam)
- (functor symbol)
- (arity arity)
+ (functor functor-index)
(register register-index))
(:returns :void)
(let* ((addr (deref wam (wam-register wam register)))
@@ -193,7 +193,7 @@
;; few instructions (which will be unify-*'s, executed in write mode).
((cell-reference-p cell)
(let ((new-structure-address (nth-value 1 (push-new-structure! wam))))
- (push-new-functor! wam functor arity)
+ (push-new-functor! wam functor)
(bind! wam addr new-structure-address)
(setf (wam-mode wam) :write)))
@@ -217,7 +217,7 @@
((cell-structure-p cell)
(let* ((functor-addr (cell-value cell))
(functor-cell (wam-heap-cell wam functor-addr)))
- (if (matching-functor-p wam functor-cell functor arity)
+ (if (matching-functor-p functor-cell functor)
(progn
(setf (wam-s wam) (1+ functor-addr))
(setf (wam-mode wam) :read))
@@ -246,3 +246,41 @@
(incf (wam-s wam))
(values))
+
+;;;; Running
+(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
+ "Expand into a call of the appropriate machine instruction.
+
+ `pc` should be a safe place representing the program counter.
+
+ `code-store` should be a safe place representing the instructions.
+
+ "
+ `(,instruction ,wam
+ ,@(loop :for i :from 1 :to number-of-arguments
+ :collect `(aref ,code-store (+ ,pc ,i)))))
+
+(defun run-query (wam term)
+ "Compile query `term` and run the instructions on the `wam`.
+
+ For now, just stop at the call instruction.
+
+ "
+ (let ((code (compile-query wam term)))
+ (loop
+ :with pc = 0 ; local program counter for this hunk of query code
+ :for opcode = (aref code pc)
+ :do
+ (progn
+ (eswitch (opcode)
+ (+opcode-put-structure+ (instruction-call wam %put-structure code pc 2))
+ (+opcode-set-variable+ (instruction-call wam %set-variable code pc 1))
+ (+opcode-set-value+ (instruction-call wam %set-value code pc 1))
+ (+opcode-put-variable+ (instruction-call wam %put-variable code pc 2))
+ (+opcode-put-value+ (instruction-call wam %put-value code pc 2))
+ (+opcode-call+ (return))) ; TODO: actually call
+ (incf pc (instruction-size opcode))
+ (when (>= pc (length code)) ; queries SHOULD always end in a CALL...
+ (error "Fell off the end of the query code store!")))))
+ (values))
+
--- a/src/wam/wam.lisp Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/wam.lisp Sun Apr 10 16:02:54 2016 +0000
@@ -195,9 +195,19 @@
(vector-push-extend functor functors))))
(defun* wam-functor-lookup ((wam wam) (functor-index functor-index))
+ (:returns functor)
+ "Return the functor with the given index in the WAM."
+ (aref (wam-functors wam) functor-index))
+
+(defun* wam-functor-symbol ((wam wam) (functor-index functor-index))
(:returns symbol)
- "Return the symbol for the functor with the given index in the WAM."
- (aref (wam-functors wam) functor-index))
+ "Return the symbol of the functor with the given index in the WAM."
+ (car (wam-functor-lookup wam functor-index)))
+
+(defun* wam-functor-arity ((wam wam) (functor-index functor-index))
+ (:returns arity)
+ "Return the arity of the functor with the given index in the WAM."
+ (cdr (wam-functor-lookup wam functor-index)))
;;;; Unification Stack