# HG changeset patch # User Steve Losh # Date 1467675308 0 # Node ID 970e21fa14b07dbd950c7b0981e25b23092d41f4 # Parent d255816ad1d09b85195aa018cfafefe3d1d4ad3c Implement anonymous variables and the `*_void` opcodes That was more difficult than I expected. The shitty part was that we have to thread the anonymous variables way the hell down into the register allocation phase. I took the opportunity to refactor a bit so further things like this shouldn't be quite so bad. diff -r d255816ad1d0 -r 970e21fa14b0 examples/bench.lisp --- a/examples/bench.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/examples/bench.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -19,11 +19,11 @@ (load "examples/ggp-wam.lisp"))) (defun run-test% () - (format t "PAIP (Compiled) --------------------~%") - (time (paiprolog-test::dfs-exhaust)) + ; (format t "PAIP (Compiled) --------------------~%") + ; (time (paiprolog-test::dfs-exhaust)) - (format t "PAIP (Interpreted) -----------------~%") - (time (bones.paip::dfs-exhaust)) + ; (format t "PAIP (Interpreted) -----------------~%") + ; (time (bones.paip::dfs-exhaust)) (format t "WAM --------------------------------~%") (time (bones.wam::dfs-exhaust))) diff -r d255816ad1d0 -r 970e21fa14b0 package-test.lisp --- a/package-test.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/package-test.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -29,6 +29,7 @@ #:fact #:facts #:call + #:? #:return-one #:return-all) (:shadowing-import-from #:bones.wam diff -r d255816ad1d0 -r 970e21fa14b0 package.lisp --- a/package.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/package.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -14,6 +14,7 @@ #:recursively #:recur #:when-let + #:unique-items )) (defpackage #:bones.circle diff -r d255816ad1d0 -r 970e21fa14b0 src/utils.lisp --- a/src/utils.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/src/utils.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -43,6 +43,19 @@ (when ,symbol ,@body))) +(defun unique-items (list) + (loop + :with once = nil + :with seen = nil + :for item :in list + :do (if (member item seen) + (when (member item once) + (setf once (delete item once))) + (progn (push item seen) + (push item once))) + :finally (return once))) + + ;;;; loop/recur (defmacro recursively (bindings &body body) "Execute body recursively, like Clojure's `loop`/`recur`. diff -r d255816ad1d0 -r 970e21fa14b0 src/wam/bytecode.lisp --- a/src/wam/bytecode.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/src/wam/bytecode.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -10,6 +10,7 @@ " (eswitch (opcode) + ;; TODO: make this thing a jump table somehow... (+opcode-noop+ 1) (+opcode-get-structure+ 3) @@ -17,6 +18,7 @@ (+opcode-unify-variable-stack+ 2) (+opcode-unify-value-local+ 2) (+opcode-unify-value-stack+ 2) + (+opcode-unify-void+ 2) (+opcode-get-variable-local+ 3) (+opcode-get-variable-stack+ 3) (+opcode-get-value-local+ 3) @@ -27,6 +29,7 @@ (+opcode-set-variable-stack+ 2) (+opcode-set-value-local+ 2) (+opcode-set-value-stack+ 2) + (+opcode-set-void+ 2) (+opcode-put-variable-local+ 3) (+opcode-put-variable-stack+ 3) (+opcode-put-value-local+ 3) @@ -61,6 +64,7 @@ (+opcode-unify-variable-stack+ "UNIFY-VARIABLE") (+opcode-unify-value-local+ "UNIFY-VALUE") (+opcode-unify-value-stack+ "UNIFY-VALUE") + (+opcode-unify-void+ "UNIFY-VOID") (+opcode-get-variable-local+ "GET-VARIABLE") (+opcode-get-variable-stack+ "GET-VARIABLE") (+opcode-get-value-local+ "GET-VALUE") @@ -71,6 +75,7 @@ (+opcode-set-variable-stack+ "SET-VARIABLE") (+opcode-set-value-local+ "SET-VALUE") (+opcode-set-value-stack+ "SET-VALUE") + (+opcode-set-void+ "SET-VOID") (+opcode-put-variable-local+ "PUT-VARIABLE") (+opcode-put-variable-stack+ "PUT-VARIABLE") (+opcode-put-value-local+ "PUT-VALUE") @@ -105,6 +110,7 @@ (+opcode-unify-variable-stack+ "UVAR") (+opcode-unify-value-local+ "UVLU") (+opcode-unify-value-stack+ "UVLU") + (+opcode-unify-void+ "UVOI") (+opcode-get-variable-local+ "GVAR") (+opcode-get-variable-stack+ "GVAR") (+opcode-get-value-local+ "GVLU") @@ -115,6 +121,7 @@ (+opcode-set-variable-stack+ "SVAR") (+opcode-set-value-local+ "SVLU") (+opcode-set-value-stack+ "SVLU") + (+opcode-set-void+ "SVOI") (+opcode-put-variable-local+ "PVAR") (+opcode-put-variable-stack+ "PVAR") (+opcode-put-value-local+ "PVLU") diff -r d255816ad1d0 -r 970e21fa14b0 src/wam/compiler.lisp --- a/src/wam/compiler.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/src/wam/compiler.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -4,6 +4,7 @@ ;;;; Utils (declaim (inline variablep)) + (defun* variablep (term) (:returns boolean) (and (symbolp term) @@ -12,7 +13,7 @@ ;;;; Registers (deftype register-type () - '(member :argument :local :permanent)) + '(member :argument :local :permanent :anonymous)) (deftype register-number () `(integer 0 ,(1- +register-count+))) @@ -21,7 +22,7 @@ (declaim (inline register-type register-number)) (defstruct (register (:constructor make-register (type number))) (type :local :type register-type) - (number 0 :type register-number)) + (number 0 :type register-number)) (defun* make-temporary-register ((number register-number) (arity arity)) @@ -29,20 +30,25 @@ (make-register (if (< number arity) :argument :local) number)) -(defun* make-permanent-register ((number register-number) (arity arity)) +(defun* make-permanent-register ((number register-number)) (:returns register) - (declare (ignore arity)) (make-register :permanent number)) +(defun* make-anonymous-register () + (:returns register) + (make-register :anonymous 0)) + (defun* register-to-string ((register register)) - (format nil "~A~D" - (ecase (register-type register) - (:argument #\A) - (:local #\X) - (:permanent #\Y)) - (+ (register-number register) - (if *off-by-one* 1 0)))) + (if (eq (register-type register) :anonymous) + "__" + (format nil "~A~D" + (ecase (register-type register) + (:argument #\A) + (:local #\X) + (:permanent #\Y)) + (+ (register-number register) + (if *off-by-one* 1 0))))) (defmethod print-object ((object register) stream) (print-unreadable-object (object stream :identity nil :type nil) @@ -51,15 +57,19 @@ (declaim (inline register-argument-p register-temporary-p - register-permanent-p)) + register-permanent-p + register-anonymous-p)) (defun* register-argument-p ((register register)) - (eql (register-type register) :argument)) + (eq (register-type register) :argument)) (defun* register-temporary-p ((register register)) (member (register-type register) '(:argument :local))) (defun* register-permanent-p ((register register)) - (eql (register-type register) :permanent)) + (eq (register-type register) :permanent)) + +(defun* register-anonymous-p ((register register)) + (eq (register-type register) :anonymous)) (declaim (inline register=)) @@ -134,7 +144,10 @@ (make-instance 'variable-node :variable variable)) (defun make-argument-variable-node (variable) - (make-instance 'argument-variable-node :variable variable)) + (make-instance 'argument-variable-node + :variable (if (eq variable +wildcard-symbol+) + (gensym "?") + variable))) (defun make-list-node (head tail) (make-instance 'list-node :head head :tail tail)) @@ -270,6 +283,108 @@ arguments))))) +;;;; Clause Properties +;;; When tokenizing/precompiling a clause there are a few pieces of metadata +;;; we're going to need. We group them into a struct to make it easier to pass +;;; everything around. + +(defstruct (clause-properties (:conc-name clause-)) + (nead-vars nil :type list) + (nead-arity 0 :type arity) + (permanent-vars nil :type list) + (anonymous-vars nil :type list)) + + +(defun find-variables (terms) + "Return the set of variables in `terms`." + (remove-duplicates (tree-collect #'variablep terms))) + +(defun find-shared-variables (terms) + "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`. + + 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. + + " + (if (<= (length clause) 2) + (list) ; Facts and chain rules have no permanent variables at all + (destructuring-bind (head body-first . body-rest) clause + ;; The head is treated as part of the first goal for the purposes of + ;; finding permanent variables. + (find-shared-variables (cons (cons head body-first) body-rest))))) + +(defun find-nead-variables (clause) + "Return a list of all variables in the nead of `clause`. + + The head and neck (first term in the body) are the 'nead'. + + " + (if (<= (length clause) 1) + (list) + (destructuring-bind (head body-first . body-rest) clause + (declare (ignore body-rest)) + (find-variables (list head body-first))))) + +(defun find-anonymous-variables (clause) + "Return a list of all anonymous variables in `clause`. + + Anonymous variables are non-argument-position variables that are only ever + used once. + + " + ;; clause: ((member :x (list* :y :rest)) ;- + ;; (member :x :rest)) + ;; + ;; terms: (member :x (list* :y :rest)) + ;; (member :x :rest) + (flet ((argument-variables (term) + (remove-if-not #'variablep (cdr term))) + (non-argument-variables (term) + (loop :for argument :in (cdr term) + :when (consp argument) + :append (tree-collect #'variablep (cdr argument))))) + (let ((terms (remove-if-not #'consp clause))) + (set-difference (unique-items (mapcan #'non-argument-variables terms)) + (mapcan #'argument-variables terms))))) + + +(defun determine-clause-properties (head body) + (let* ((clause + (cons head body)) + (permanent-vars + (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 clause))) + (anonymous-vars + (if (null head) + ;; Again, for queries we cheat and never let anything be + ;; anonymous (except for the wildcard). + (list +wildcard-symbol+) + (cons +wildcard-symbol+ + (find-anonymous-variables clause)))) + (nead-vars + (set-difference (find-nead-variables clause) + permanent-vars)) + (nead-arity + (max (1- (length head)) + (1- (length (first (remove '! body))))))) ; gross + (make-clause-properties :nead-vars nead-vars + :nead-arity nead-arity + :permanent-vars permanent-vars + :anonymous-vars anonymous-vars))) + + ;;;; Register Allocation ;;; You might want to grab a coffee for this one. ;;; @@ -406,6 +521,7 @@ local-registers stack-registers permanent-variables + anonymous-variables reserved-variables reserved-arity actual-arity) @@ -416,7 +532,7 @@ (or (when-let (r (position variable (allocation-state-local-registers state))) (make-temporary-register r (allocation-state-actual-arity state))) (when-let (s (position variable (allocation-state-stack-registers state))) - (make-permanent-register s (allocation-state-actual-arity state))) + (make-permanent-register s)) nil)) (defun store-variable (state variable) @@ -443,6 +559,7 @@ `(when (not (slot-boundp ,instance ,slot)) (setf (slot-value ,instance ,slot) ,value-form)))) + (defun allocate-nonvariable-register (state) "Allocate and return a register for something that's not a variable." ;; We need to allocate registers for things like structures and lists, but we @@ -462,7 +579,10 @@ (defmethod allocate-register ((node variable-node) state) (set-when-unbound node 'register - (ensure-variable state (node-variable node)))) + (if (member (node-variable node) + (allocation-state-anonymous-variables state)) + (make-anonymous-register) + (ensure-variable state (node-variable node))))) (defmethod allocate-register ((node argument-variable-node) state) (set-when-unbound node 'secondary-register @@ -484,11 +604,15 @@ (make-register :argument i))) (values)) -(defun allocate-nonargument-registers - (node permanent-variables reserved-variables reserved-arity) +(defun allocate-nonargument-registers (node clause-props &key nead) ;; JESUS TAKE THE WHEEL (let* ((actual-arity (node-arity node)) + (reserved-arity (when nead + (clause-nead-arity clause-props))) + (reserved-variables (when nead + (clause-nead-vars clause-props))) + (permanent-variables (clause-permanent-vars clause-props)) ;; Preallocate enough registers for all of the arguments. We'll fill ;; them in later. Note that things are more complicated in the head and ;; first body term of a clause (see above). @@ -504,13 +628,15 @@ ;; flattened away anyway. (stack-registers (make-array (length permanent-variables) :initial-contents permanent-variables)) - (allocation-state (make-allocation-state - :local-registers local-registers - :stack-registers stack-registers - :permanent-variables permanent-variables - :reserved-variables reserved-variables - :reserved-arity reserved-arity - :actual-arity actual-arity))) + (allocation-state + (make-allocation-state + :local-registers local-registers + :stack-registers stack-registers + :permanent-variables permanent-variables + :anonymous-variables (clause-anonymous-vars clause-props) + :reserved-variables reserved-variables + :reserved-arity reserved-arity + :actual-arity actual-arity))) ;; Actually reserve the reserved (but non-permanent, see above) variables. ;; They need to live in consistent spots for the head and first body term. (loop :for variable :in reserved-variables @@ -522,11 +648,9 @@ (recur (append remaining (node-children node))))))) (values)) -(defun allocate-registers - (node permanent-variables &optional reserved-variables reserved-arity) +(defun allocate-registers (node clause-props &key nead) (allocate-argument-registers node) - (allocate-nonargument-registers - node permanent-variables reserved-variables reserved-arity) + (allocate-nonargument-registers node clause-props :nead nead) (values)) @@ -733,18 +857,16 @@ (mapcan #'tokenize-assignment assignments)) -(defun tokenize-program-term - (term permanent-variables nead-variables nead-arity) +(defun tokenize-program-term (term clause-props) "Tokenize `term` as a program term, returning its tokens." (let ((tree (parse-top-level term))) - (allocate-registers tree permanent-variables nead-variables nead-arity) + (allocate-registers tree clause-props :nead t) (-> tree flatten-program tokenize-assignments))) -(defun tokenize-query-term - (term permanent-variables &optional nead-variables nead-arity) +(defun tokenize-query-term (term clause-props &key nead) "Tokenize `term` as a query term, returning its tokens." (let ((tree (parse-top-level term))) - (allocate-registers tree permanent-variables nead-variables nead-arity) + (allocate-registers tree clause-props :nead nead) (-<> tree flatten-query tokenize-assignments @@ -851,35 +973,55 @@ ;;; the "substitution" for the first body goal (see the comment earlier for more ;;; on that rabbit hole). +(defun find-opcode (opcode first-seen mode &optional register) + (let ((register-variant (when register + (case (register-type register) + ((:local :argument) :local) + ((:permanent) :stack) + ((:anonymous) :void))))) + (case opcode ; oh fuck off + (:argument (if first-seen + (case mode + (:program (case register-variant + (:local :get-variable-local) + (:stack :get-variable-stack))) + (:query (case register-variant + (:local :put-variable-local) + (:stack :put-variable-stack)))) + (case mode + (:program (case register-variant + (:local :get-value-local) + (:stack :get-value-stack))) + (:query (case register-variant + (:local :put-value-local) + (:stack :put-value-stack)))))) + ;; Structures and lists can only live locally, they never go on the stack + (:structure (case mode + (:program :get-structure) + (:query :put-structure))) + (:list (case mode + (:program :get-list) + (:query :put-list))) + (:register (if first-seen + (case mode + (:program (case register-variant + (:local :unify-variable-local) + (:stack :unify-variable-stack) + (:void :unify-void))) + (:query (case register-variant + (:local :set-variable-local) + (:stack :set-variable-stack) + (:void :set-void)))) + (case mode + (:program (case register-variant + (:local :unify-value-local) + (:stack :unify-value-stack) + (:void :unify-void))) + (:query (case register-variant + (:local :set-value-local) + (:stack :set-value-stack) + (:void :set-void))))))))) -(defun find-opcode (opcode newp mode &optional register) - (flet ((find-variant (register) - (when register - (if (register-temporary-p register) - :local - :stack)))) - (eswitch ((list opcode newp mode (find-variant register)) :test #'equal) - ('(:argument t :program :local) :get-variable-local) - ('(:argument t :program :stack) :get-variable-stack) - ('(:argument t :query :local) :put-variable-local) - ('(:argument t :query :stack) :put-variable-stack) - ('(:argument nil :program :local) :get-value-local) - ('(:argument nil :program :stack) :get-value-stack) - ('(:argument nil :query :local) :put-value-local) - ('(:argument nil :query :stack) :put-value-stack) - ;; Structures and lists can only live locally, they never go on the stack - ('(:structure nil :program :local) :get-structure) - ('(:structure nil :query :local) :put-structure) - ('(:list nil :program :local) :get-list) - ('(:list nil :query :local) :put-list) - ('(:register t :program :local) :unify-variable-local) - ('(:register t :program :stack) :unify-variable-stack) - ('(:register t :query :local) :set-variable-local) - ('(:register t :query :stack) :set-variable-stack) - ('(:register nil :program :local) :unify-value-local) - ('(:register nil :program :stack) :unify-value-stack) - ('(:register nil :query :local) :set-value-local) - ('(:register nil :query :stack) :set-value-stack)))) (defun precompile-tokens (wam head-tokens body-tokens) "Generate a series of machine instructions from a stream of head and body @@ -942,9 +1084,12 @@ (reset-seen)) (handle-register (register) ;; OP reg - (let ((newp (push-if-new register seen :test #'register=))) - (push-instruction (find-opcode :register newp mode register) - register))) + (if (eq (register-type register) :anonymous) + (push-instruction (find-opcode :register nil mode register) 1) + (let ((first-seen (push-if-new register seen :test #'register=))) + (push-instruction + (find-opcode :register first-seen mode register) + register)))) (handle-token (token) (etypecase token (argument-variable-token @@ -973,46 +1118,6 @@ instructions))) -(defun find-variables (terms) - "Return the set of variables in `terms`." - (remove-duplicates (tree-collect #'variablep terms))) - -(defun find-shared-variables (terms) - "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`. - - 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. - - " - (if (<= (length clause) 2) - (list) ; Facts and chain rules have no permanent variables at all - (destructuring-bind (head body-first . body-rest) clause - ;; The head is treated as part of the first goal for the purposes of - ;; finding permanent variables. - (find-shared-variables (cons (cons head body-first) body-rest))))) - -(defun find-nead-variables (clause) - "Return a list of all variables in the nead of `clause`. - - The head and neck (first term in the body) are the 'nead'. - - " - (if (<= (length clause) 1) - (list) - (destructuring-bind (head body-first . body-rest) clause - (declare (ignore body-rest)) - (find-variables (list head body-first))))) - - (defun precompile-clause (wam head body) "Precompile the clause. @@ -1021,30 +1126,14 @@ `body` is the body of the clause, or `nil` for facts. - Returns a circle of instructions and the permanent variables. + Returns a circle of instructions and the properties of the clause. " - (let* ((basic-clause - (remove '! (cons head body))) ; gross - (permanent-variables - (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 basic-clause))) - ;; grep above to see what the hell the nead is. - (nead-variables - (set-difference (find-nead-variables basic-clause) - permanent-variables)) - (nead-arity - (max (1- (length head)) - (1- (length (second basic-clause))))) + (let* ((clause-props + (determine-clause-properties head body)) (head-tokens (when head - (tokenize-program-term head - permanent-variables - nead-variables - nead-arity))) + (tokenize-program-term head clause-props))) (body-tokens (when body (loop @@ -1058,14 +1147,12 @@ (list (make-instance 'cut-token))) (first (setf first nil) - (tokenize-query-term goal - permanent-variables - nead-variables - nead-arity)) + (tokenize-query-term goal clause-props + :nead t)) (t - (tokenize-query-term goal permanent-variables))))))) + (tokenize-query-term goal clause-props))))))) (let ((instructions (precompile-tokens wam head-tokens body-tokens)) - (variable-count (length permanent-variables))) + (variable-count (length (clause-permanent-vars clause-props)))) ;; We need to compile facts and rules differently. Facts end with ;; a PROCEED and rules are wrapped in ALOC/DEAL. (cond @@ -1085,7 +1172,7 @@ ;; can poke at it. (circle-insert-beginning instructions `(:allocate ,variable-count)) (circle-insert-end instructions `(:done)))) - (values instructions permanent-variables)))) + (values instructions clause-props)))) (defun precompile-query (wam query) @@ -1094,7 +1181,10 @@ `query` should be a list of goal terms. " - (precompile-clause wam nil query)) + (multiple-value-bind (instructions clause-props) + (precompile-clause wam nil query) + (values instructions + (clause-permanent-vars clause-props)))) (defun find-arity (rule) @@ -1222,8 +1312,35 @@ instructions)) +(defun optimize-void-runs (wam instructions) + ;; We can optimize runs of N (:[unify/set]-void 1) instructions into a single + ;; one that does all N at once. + (declare (ignore wam)) + (loop + :for node = (circle-forward instructions) :then (circle-forward node) + :while node + :for opcode = (car (circle-value node)) + :when (or (eq opcode :set-void) + (eq opcode :unify-void)) + :do + (loop + :with beginning = (circle-backward node) + :for run-node = node :then (circle-forward run-node) + :for run-opcode = (car (circle-value run-node)) + :while (eq opcode run-opcode) + :do (circle-remove run-node) + :sum 1 :into run-length + :finally + (progn + (setf node (circle-forward beginning)) + (circle-insert-after beginning + `(,opcode ,run-length)))))) + + (defun optimize-instructions (wam instructions) - (optimize-constants wam instructions)) + (->> instructions + (optimize-constants wam) + (optimize-void-runs wam))) ;;;; Rendering @@ -1237,6 +1354,7 @@ (:unify-variable-stack +opcode-unify-variable-stack+) (:unify-value-local +opcode-unify-value-local+) (:unify-value-stack +opcode-unify-value-stack+) + (:unify-void +opcode-unify-void+) (:get-variable-local +opcode-get-variable-local+) (:get-variable-stack +opcode-get-variable-stack+) (:get-value-local +opcode-get-value-local+) @@ -1246,6 +1364,7 @@ (:set-variable-stack +opcode-set-variable-stack+) (:set-value-local +opcode-set-value-local+) (:set-value-stack +opcode-set-value-stack+) + (:set-void +opcode-set-void+) (:put-variable-local +opcode-put-variable-local+) (:put-variable-stack +opcode-put-variable-stack+) (:put-value-local +opcode-put-value-local+) diff -r d255816ad1d0 -r 970e21fa14b0 src/wam/constants.lisp --- a/src/wam/constants.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/src/wam/constants.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -99,6 +99,9 @@ :documentation "The maximum number of functors the WAM can keep track of.") +(define-constant +wildcard-symbol+ '?) + + ;;;; Opcodes (defmacro define-opcodes (&rest symbols) `(progn @@ -116,6 +119,7 @@ +opcode-unify-variable-stack+ +opcode-unify-value-local+ +opcode-unify-value-stack+ + +opcode-unify-void+ +opcode-get-variable-local+ +opcode-get-variable-stack+ +opcode-get-value-local+ @@ -127,6 +131,7 @@ +opcode-set-variable-stack+ +opcode-set-value-local+ +opcode-set-value-stack+ + +opcode-set-void+ +opcode-put-variable-local+ +opcode-put-variable-stack+ +opcode-put-value-local+ diff -r d255816ad1d0 -r 970e21fa14b0 src/wam/vm.lisp --- a/src/wam/vm.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/src/wam/vm.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -359,6 +359,10 @@ (register register-index)) (wam-heap-push! wam (%wam-register% wam register))) +(define-instruction %set-void ((wam wam) (n arity)) + (repeat n + (push-unbound-reference! wam))) + (define-instructions (%put-variable-local %put-variable-stack) ((wam wam) (register register-index) @@ -465,6 +469,12 @@ (:write (wam-heap-push! wam (%wam-register% wam register)))) (incf (wam-subterm wam))) +(define-instruction %unify-void ((wam wam) (n arity)) + (ecase (wam-mode wam) + (:read (incf (wam-subterm wam) n)) + (:write (repeat n + (push-unbound-reference! wam))))) + (define-instructions (%get-variable-local %get-variable-stack) ((wam wam) (register register-index) @@ -746,6 +756,7 @@ (+opcode-set-variable-stack+ (instruction %set-variable-stack 1)) (+opcode-set-value-local+ (instruction %set-value-local 1)) (+opcode-set-value-stack+ (instruction %set-value-stack 1)) + (+opcode-set-void+ (instruction %set-void 1)) (+opcode-put-variable-local+ (instruction %put-variable-local 2)) (+opcode-put-variable-stack+ (instruction %put-variable-stack 2)) (+opcode-put-value-local+ (instruction %put-value-local 2)) @@ -756,6 +767,7 @@ (+opcode-unify-variable-stack+ (instruction %unify-variable-stack 1)) (+opcode-unify-value-local+ (instruction %unify-value-local 1)) (+opcode-unify-value-stack+ (instruction %unify-value-stack 1)) + (+opcode-unify-void+ (instruction %unify-void 1)) (+opcode-get-variable-local+ (instruction %get-variable-local 2)) (+opcode-get-variable-stack+ (instruction %get-variable-stack 2)) (+opcode-get-value-local+ (instruction %get-value-local 2)) diff -r d255816ad1d0 -r 970e21fa14b0 test/wam.lisp --- a/test/wam.lisp Sun Jul 03 22:50:24 2016 +0000 +++ b/test/wam.lisp Mon Jul 04 23:35:08 2016 +0000 @@ -52,9 +52,7 @@ (rules ((narcissist ?person) (likes ?person ?person))) - (rules ((member ?x (list* ?x ?rest))) - ((member ?x (list* ?y ?rest)) - (member ?x ?rest)))) + ) db)) (defparameter *test-database* (make-test-database)) @@ -271,7 +269,11 @@ ((foo dogs) empty)))) (test lists - (with-database *test-database* + (with-fresh-database + (rules ((member ?x (list* ?x ?))) + ((member ?x (list* ? ?rest)) + (member ?x ?rest))) + (should-fail (member ?anything nil) (member a nil) @@ -375,3 +377,13 @@ (f ?what) (g ?what)))) +(test anonymous-variables + (with-fresh-database + (fact (foo x)) + (rule (bar (baz ?x ?y ?z ?thing)) + (foo ?thing)) + (fact (wild ? ? ?)) + (should-return + ((bar (baz a b c no)) fail) + ((bar (baz a b c ?what)) (?what x)) + ((wild a b c) empty))))