970e21fa14b0

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.
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Mon, 04 Jul 2016 23:35:08 +0000
parents d255816ad1d0
children 89df9abc00e5
branches/tags (none)
files examples/bench.lisp package-test.lisp package.lisp src/utils.lisp src/wam/bytecode.lisp src/wam/compiler.lisp src/wam/constants.lisp src/wam/vm.lisp test/wam.lisp

Changes

--- 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)))
--- 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
--- 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
--- 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`.
--- 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")
--- 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+)
--- 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+
--- 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))
--- 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))))