--- a/src/make-quickutils.lisp Tue Apr 19 12:16:52 2016 +0000
+++ b/src/make-quickutils.lisp Tue Apr 19 14:00:32 2016 +0000
@@ -15,5 +15,6 @@
:zip
:alist-to-hash-table
:map-tree
+ :range
)
:package "BONES.QUICKUTILS")
--- a/src/quickutils.lisp Tue Apr 19 12:16:52 2016 +0000
+++ b/src/quickutils.lisp Tue Apr 19 14:00:32 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE) :ensure-package T :package "BONES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :RANGE) :ensure-package T :package "BONES.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.QUICKUTILS")
@@ -20,7 +20,7 @@
:SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
:TREE-MEMBER-P :TREE-COLLECT
:TRANSPOSE :ZIP :ALIST-TO-HASH-TABLE
- :MAP-TREE))))
+ :MAP-TREE :RANGE))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -288,9 +288,17 @@
(rec (cdr tree)))))))
(rec tree)))
+
+ (defun range (start end &key (step 1) (key 'identity))
+ "Return the list of numbers `n` such that `start <= n < end` and
+`n = start + k*step` for suitable integers `k`. If a function `key` is
+provided, then apply it to each number."
+ (assert (<= start end))
+ (loop :for i :from start :below end :by step :collecting (funcall key i)))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(define-constant set-equal curry switch eswitch cswitch
ensure-boolean while until tree-member-p tree-collect with-gensyms
- with-unique-names zip alist-to-hash-table map-tree)))
+ with-unique-names zip alist-to-hash-table map-tree range)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/wam/compiler.lisp Tue Apr 19 12:16:52 2016 +0000
+++ b/src/wam/compiler.lisp Tue Apr 19 14:00:32 2016 +0000
@@ -538,7 +538,6 @@
('(:register nil :query :local) +opcode-set-value-local+)
('(:register nil :query :stack) +opcode-set-value-stack+))))
-
(defun compile-tokens (wam head-tokens body-tokens store)
"Generate a series of machine instructions from a stream of head and body
tokens.
@@ -605,21 +604,22 @@
(handle-stream body-tokens))))
+;;;; UI
+(defun find-variables (terms)
+ "Return the set of variables in `terms`."
+ (remove-duplicates (tree-collect #'variable-p terms)))
-;;;; UI
(defun find-shared-variables (terms)
- "Return a list of all variables shared by two or more terms."
- (let* ((variables (remove-duplicates (tree-collect #'variable-p terms))))
- (labels
- ((count-uses (variable)
- (count-if (curry #'tree-member-p variable)
- terms))
- (shared-p (variable)
- (> (count-uses variable) 1)))
- (remove-if-not #'shared-p variables))))
+ "Return the set of all variables shared by two or more terms."
+ (labels
+ ((count-uses (variable)
+ (count-if (curry #'tree-member-p variable) terms))
+ (shared-p (variable)
+ (> (count-uses variable) 1)))
+ (remove-if-not #'shared-p (find-variables terms))))
(defun find-permanent-variables (clause)
- "Return a list of all the 'permanent' variables in `clause`.
+ "Return a list of all the permanent variables in `clause`.
Permanent variables are those that appear in more than one goal of the clause,
where the head of the clause is considered to be a part of the first goal.
@@ -655,14 +655,20 @@
(defun compile-clause (wam store head body)
- "Compile the clause into the given store array.
+ "Compile the clause directly into `store` and return the permanent variables.
- `head` should be the head of the clause for program clauses, or may be `nil`
- for query clauses.
+ `head` should be the head of the clause for program clauses, or `nil` for
+ query clauses.
+
+ `body` is the body of the clause, or `nil` for facts.
"
(let* ((permanent-variables
- (find-permanent-variables (cons head body)))
+ (if (null head)
+ ;; For query clauses we cheat a bit and make ALL variables
+ ;; permanent, so we can extract their bindings as results later.
+ (find-variables body)
+ (find-permanent-variables (cons head body))))
(head-variables
(set-difference (find-head-variables (cons head body))
permanent-variables))
@@ -699,26 +705,35 @@
((and head (null body)) ; a bare fact
(compile%)
(code-push-instruction! store +opcode-proceed+))
- (t ; just a query
- (compile%)))))
- (values))
+ (t ; a query
+ ;; The book doesn't have this ALOC here, but we do it to aid in result
+ ;; extraction. Basically, to make extracting th results of a query
+ ;; easier we allocate all of its variables on the stack, so we need
+ ;; push a stack frame for them before we get started. We don't DEAL
+ ;; because we want the frame to be left on the stack at the end so we
+ ;; can poke at it.
+ (code-push-instruction! store +opcode-allocate+ (length permanent-variables))
+ (compile%)
+ (code-push-instruction! store +opcode-done+))))
+ permanent-variables))
(defun compile-query (wam query)
"Compile `query` into a fresh array of bytecode.
`query` should be a list of goal terms.
+ Returns the fresh code array and the permanent variables.
+
"
- (let ((store (make-query-code-store)))
- (compile-clause wam store nil query)
- (code-push-instruction! store +opcode-done+)
- store))
+ (let* ((store (make-query-code-store))
+ (permanent-variables (compile-clause wam store nil query)))
+ (values store permanent-variables)))
(defun compile-program (wam rule)
"Compile `rule` into the WAM's code store.
`rule` should be a clause consisting of a head term and zero or more body
- terms. A rule with no body is also called a \"fact\".
+ terms. A rule with no body is called a fact.
"
(compile-clause wam (wam-code wam) (first rule) (rest rule))
--- a/src/wam/dump.lisp Tue Apr 19 12:16:52 2016 +0000
+++ b/src/wam/dump.lisp Tue Apr 19 14:00:32 2016 +0000
@@ -182,8 +182,8 @@
(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)))
+ (first arguments)
+ (second arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments functor-list)
(format nil "PVLU~A ; A~A <- X~A"
@@ -205,58 +205,43 @@
(defun dump-code-store (wam code-store
- &optional
- (from 0)
- (to (length code-store)))
- (let ((addr from)
+ &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 (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)))
+ (when (>= addr from)
+ (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)
+ (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 (max (- (wam-program-counter wam) 4) ; wow
+ (from (max (- (wam-program-counter wam) 8) ; wow
0)) ; this
- (to (min (+ (wam-program-counter wam) 6) ; is
+ (to (min (+ (wam-program-counter wam) 12) ; is
(length (wam-code wam))))) ; bad
(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))
@@ -269,7 +254,7 @@
(format nil "X~D" i)
reg
(cell-aesthetic contents)
- (format nil "; ~A" (extract-thing wam reg)))))
+ (format nil "; ~A" (first (extract-things wam (list reg)))))))
(defun dump-wam-functors (wam)
(format t " FUNCTORS: ~S~%" (wam-functors wam)))
--- a/src/wam/interpreter.lisp Tue Apr 19 12:16:52 2016 +0000
+++ b/src/wam/interpreter.lisp Tue Apr 19 14:00:32 2016 +0000
@@ -246,58 +246,59 @@
;;;; Program Instructions
-(define-instruction %get-structure-local
- ((wam wam)
- (functor functor-index)
- (register register-index))
- (let* ((addr (deref wam (wam-local-register wam register)))
- (cell (wam-heap-cell wam addr)))
- (cond
- ;; If the register points at a reference cell, we push two new cells onto
- ;; the heap:
- ;;
- ;; | N | STR | N+1 |
- ;; | N+1 | FUN | f/n |
- ;;
- ;; Then we bind this reference cell to point at the new structure and flip
- ;; over to write mode.
- ;;
- ;; It seems a bit confusing that we don't push the rest of the structure
- ;; stuff on the heap after it too. But that's going to happen in the next
- ;; 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)
- (bind! wam addr new-structure-address)
- (setf (wam-mode wam) :write)))
+(define-instruction %get-structure-local ((wam wam)
+ (functor functor-index)
+ (register register-index))
+ (with-accessors ((mode wam-mode) (s wam-s)) wam
+ (let* ((addr (deref wam (wam-local-register wam register)))
+ (cell (wam-heap-cell wam addr)))
+ (cond
+ ;; If the register points at a reference cell, we push two new cells onto
+ ;; the heap:
+ ;;
+ ;; | N | STR | N+1 |
+ ;; | N+1 | FUN | f/n |
+ ;; | | | | <- S
+ ;;
+ ;; Then we bind this reference cell to point at the new structure, set the
+ ;; S register to point beneath it and flip over to write mode.
+ ;;
+ ;; It seems a bit confusing that we don't push the rest of the structure
+ ;; stuff on the heap after it too. But that's going to happen in the next
+ ;; few instructions (which will be unify-*'s, executed in write mode).
+ ((cell-reference-p cell)
+ (let ((structure-address (nth-value 1 (push-new-structure! wam)))
+ (functor-address (push-new-functor! wam functor)))
+ (bind! wam addr structure-address)
+ (setf mode :write
+ s (1+ functor-address))))
- ;; If the register points at a structure cell, then we look at where that
- ;; cell points (which will be the functor cell for the structure):
- ;;
- ;; | N | STR | M | points at the structure, not necessarily contiguous
- ;; | ... |
- ;; | M | FUN | f/2 | the functor (hopefully it matches)
- ;; | M+1 | ... | ... | pieces of the structure, always contiguous
- ;; | M+2 | ... | ... | and always right after the functor
- ;;
- ;; If it matches the functor we're looking for, we can proceed. We set
- ;; the S register to the address of the first subform we need to match
- ;; (M+1 in the example above).
- ;;
- ;; What about if it's a 0-arity functor? The S register will be set to
- ;; garbage. But that's okay, because we know the next thing in the stream
- ;; of instructions will be another get-structure and we'll just blow away
- ;; the S register there.
- ((cell-structure-p cell)
- (let* ((functor-addr (cell-value cell))
- (functor-cell (wam-heap-cell wam functor-addr)))
- (if (matching-functor-p functor-cell functor)
- (progn
- (setf (wam-s wam) (1+ functor-addr))
- (setf (wam-mode wam) :read))
- (fail! wam "Functors don't match in get-struct"))))
- (t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A"
- (cell-aesthetic cell)))))))
+ ;; If the register points at a structure cell, then we look at where that
+ ;; cell points (which will be the functor cell for the structure):
+ ;;
+ ;; | N | STR | M | points at the structure, not necessarily contiguous
+ ;; | ... |
+ ;; | M | FUN | f/2 | the functor (hopefully it matches)
+ ;; | M+1 | ... | ... | pieces of the structure, always contiguous
+ ;; | M+2 | ... | ... | and always right after the functor
+ ;;
+ ;; If it matches the functor we're looking for, we can proceed. We set
+ ;; the S register to the address of the first subform we need to match
+ ;; (M+1 in the example above).
+ ;;
+ ;; What about if it's a 0-arity functor? The S register will be set to
+ ;; garbage. But that's okay, because we know the next thing in the stream
+ ;; of instructions will be another get-structure and we'll just blow away
+ ;; the S register there.
+ ((cell-structure-p cell)
+ (let* ((functor-addr (cell-value cell))
+ (functor-cell (wam-heap-cell wam functor-addr)))
+ (if (matching-functor-p functor-cell functor)
+ (setf s (1+ functor-addr)
+ mode :read)
+ (fail! wam "Functors don't match in get-struct"))))
+ (t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A"
+ (cell-aesthetic cell))))))))
(define-instructions (%unify-variable-local %unify-variable-stack)
((wam wam)
@@ -385,33 +386,58 @@
:collect `(aref ,code-store (+ ,pc ,i)))))
-(defun extract-query-results (wam goal)
- ;; TODO: rehaul this
- (let ((results (list)))
- (labels ((recur (original result)
- (cond
- ((and (variable-p original)
- (not (assoc original results)))
- (push (cons original
- (match result
- (`(,bare-functor) bare-functor)
- (r r)))
- results))
- ((consp original)
- (recur (car original) (car result))
- (recur (cdr original) (cdr result)))
- (t nil))))
- (loop :for argument :in (cdr goal)
- :for a :from 0
- :do (recur argument
- (extract-thing
- wam
- ;; results are stored in local (argument) registers
- (wam-local-register wam a)))))
- results))
+(defun extract-things (wam addresses)
+ "Extract the things at the given heap addresses.
+
+ The things will be returned in the same order as the addresses were given.
+
+ Unbound variables will be turned into uninterned symbols. There will only be
+ one such symbol for any specific unbound var, so if two addresses are
+ (eventually) bound to the same unbound var, the symbols returned from this
+ function will be `eql`.
+
+ "
+ (let ((unbound-vars (list)))
+ (labels
+ ((mark-unbound-var (address)
+ (let ((symbol (make-symbol (format nil "var-~D" ; lol
+ (length unbound-vars)))))
+ (car (push (cons address symbol) unbound-vars))))
+ (extract-var (address)
+ (cdr (or (assoc address unbound-vars)
+ (mark-unbound-var address))))
+ (recur (address)
+ (let ((cell (wam-heap-cell wam (deref wam address))))
+ (cond
+ ((cell-null-p cell) "NULL?!")
+ ((cell-reference-p cell) (extract-var (cell-value cell)))
+ ((cell-structure-p cell) (recur (cell-value cell)))
+ ((cell-functor-p cell)
+ (destructuring-bind (functor . arity)
+ (wam-functor-lookup wam (cell-functor-index cell))
+ (if (zerop arity)
+ functor
+ (list* functor
+ (mapcar #'recur
+ (range (+ address 1)
+ (+ address arity 1)))))))
+ (t (error "What to heck is this?"))))))
+ (mapcar #'recur addresses))))
+
+(defun extract-query-results (wam vars)
+ ""
+ (let* ((addresses (loop :for var :in vars
+ :for i :from 0
+ :collect (wam-stack-frame-arg wam i 0)))
+ (results (extract-things wam addresses)))
+ (pairlis vars results)))
+
+(defun print-query-results (results)
+ (loop :for (var . result) :in results :do
+ (format t "~S = ~S~%" var result)))
-(defun run-program (wam &optional (step nil))
+(defun run (wam &optional (step nil))
(with-slots (code program-counter fail) wam
(macrolet ((instruction (inst args)
`(instruction-call wam ,inst code program-counter ,args)))
@@ -458,7 +484,7 @@
(instruction %call 1)
(return-from op))
(+opcode-done+
- (return-from run-program)))
+ (return-from run)))
(incf program-counter (instruction-size opcode))
(when (>= program-counter (fill-pointer code))
(error "Fell off the end of the program code store!")))))
@@ -473,18 +499,21 @@
after each instruction.
"
- (let ((code (compile-query wam term)))
+ (multiple-value-bind (code vars)
+ (compile-query wam term)
(wam-reset! wam)
(wam-load-query-code! wam code)
(setf (wam-program-counter wam) 0
(wam-continuation-pointer wam) +code-sentinal+)
(when step
(format *debug-io* "Built query code:~%")
- (dump-code-store wam code)))
- (run-program wam step)
- (if (wam-fail wam)
- (princ "No.")
- (princ "Yes."))
+ (dump-code-store wam code))
+ (run wam step)
+ (if (wam-fail wam)
+ (princ "No.")
+ (progn
+ (print-query-results (extract-query-results wam vars))
+ (princ "Yes."))))
(values))