# HG changeset patch # User Steve Losh # Date 1461074432 0 # Node ID 67535b9c3b86ef02079af9c24f140b4caf897e27 # Parent 5085c5254515d7f4c8904f1264e91c5e7d8dddc9 Implement proper result extraction diff -r 5085c5254515 -r 67535b9c3b86 src/make-quickutils.lisp --- 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") diff -r 5085c5254515 -r 67535b9c3b86 src/quickutils.lisp --- 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 ;;;; diff -r 5085c5254515 -r 67535b9c3b86 src/wam/compiler.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)) diff -r 5085c5254515 -r 67535b9c3b86 src/wam/dump.lisp --- 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))) diff -r 5085c5254515 -r 67535b9c3b86 src/wam/interpreter.lisp --- 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))