--- a/src/wam/bytecode.lisp Sun Jul 17 16:59:50 2016 +0000
+++ b/src/wam/bytecode.lisp Fri Jul 22 20:32:51 2016 +0000
@@ -17,6 +17,7 @@
(+opcode-put-variable-stack+ "PUT-VARIABLE")
(+opcode-put-value-local+ "PUT-VALUE")
(+opcode-put-value-stack+ "PUT-VALUE")
+ (+opcode-put-void+ "PUT-VOID")
(+opcode-subterm-variable-local+ "SUBTERM-VARIABLE")
(+opcode-subterm-variable-stack+ "SUBTERM-VARIABLE")
@@ -62,6 +63,7 @@
(+opcode-put-variable-stack+ "PVAR")
(+opcode-put-value-local+ "PVLU")
(+opcode-put-value-stack+ "PVLU")
+ (+opcode-put-void+ "PVOI")
(+opcode-subterm-variable-local+ "SVAR")
(+opcode-subterm-variable-stack+ "SVAR")
@@ -113,6 +115,7 @@
(#.+opcode-put-variable-stack+ 3)
(#.+opcode-put-value-local+ 3)
(#.+opcode-put-value-stack+ 3)
+ (#.+opcode-put-void+ 2)
(#.+opcode-subterm-variable-local+ 2)
(#.+opcode-subterm-variable-stack+ 2)
--- a/src/wam/compiler/5-precompilation.lisp Sun Jul 17 16:59:50 2016 +0000
+++ b/src/wam/compiler/5-precompilation.lisp Fri Jul 22 20:32:51 2016 +0000
@@ -180,9 +180,13 @@
(setf seen (remove-if #'register-temporary-p seen)))
(handle-argument (argument-register source-register)
(if (register-anonymous-p source-register)
- ;; Crazy, but we can just drop argument-position anonymous
- ;; variables on the floor at this point.
- nil
+ (ecase mode
+ ;; Query terms need to put an unbound var into their argument
+ ;; register for each anonymous variable.
+ (:query (push-instruction :put-void argument-register))
+ ;; Crazy, but for program terms we can just drop
+ ;; argument-position anonymous variables on the floor.
+ (:program nil))
;; OP X_n A_i
(let ((first-seen (push-if-new source-register seen :test #'register=)))
(push-instruction
--- a/src/wam/compiler/6-optimization.lisp Sun Jul 17 16:59:50 2016 +0000
+++ b/src/wam/compiler/6-optimization.lisp Fri Jul 22 20:32:51 2016 +0000
@@ -79,14 +79,13 @@
(defun optimize-void-runs (instructions)
- ;; We can optimize runs of N (:[unify/set]-void 1) instructions into a single
- ;; one that does all N at once.
+ ;; We can optimize runs of N (:unify-void 1) instructions into a single one
+ ;; that does all N at once.
(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 :subterm-void))
+ :when (eq opcode :subterm-void)
:do
(loop
:with beginning = (circle-backward node)
--- a/src/wam/compiler/7-rendering.lisp Sun Jul 17 16:59:50 2016 +0000
+++ b/src/wam/compiler/7-rendering.lisp Fri Jul 22 20:32:51 2016 +0000
@@ -48,6 +48,7 @@
(:put-variable-stack +opcode-put-variable-stack+)
(:put-value-local +opcode-put-value-local+)
(:put-value-stack +opcode-put-value-stack+)
+ (:put-void +opcode-put-void+)
(:subterm-variable-local +opcode-subterm-variable-local+)
(:subterm-variable-stack +opcode-subterm-variable-stack+)
(:subterm-value-local +opcode-subterm-value-local+)
--- a/src/wam/constants.lisp Sun Jul 17 16:59:50 2016 +0000
+++ b/src/wam/constants.lisp Fri Jul 22 20:32:51 2016 +0000
@@ -108,6 +108,7 @@
+opcode-put-variable-stack+
+opcode-put-value-local+
+opcode-put-value-stack+
+ +opcode-put-void+
;; Subterm
+opcode-subterm-variable-local+
--- a/src/wam/vm.lisp Sun Jul 17 16:59:50 2016 +0000
+++ b/src/wam/vm.lisp Fri Jul 22 20:32:51 2016 +0000
@@ -353,6 +353,10 @@
(setf (wam-mode wam) :write))
+(define-instruction (%put-void) (wam argument)
+ (wam-copy-to-local-register! wam argument (push-unbound-reference! wam)))
+
+
;;;; Program Instructions
(define-instruction (%get-structure) (wam functor arity register)
(cell-typecase (wam (deref wam register) address)
@@ -824,6 +828,7 @@
(#.+opcode-put-variable-stack+ :instruction %put-variable-stack)
(#.+opcode-put-value-local+ :instruction %put-value-local)
(#.+opcode-put-value-stack+ :instruction %put-value-stack)
+ (#.+opcode-put-void+ :instruction %put-void)
;; Program
(#.+opcode-get-structure+ :instruction %get-structure)
(#.+opcode-get-variable-local+ :instruction %get-variable-local)
--- a/test/wam.lisp Sun Jul 17 16:59:50 2016 +0000
+++ b/test/wam.lisp Fri Jul 22 20:32:51 2016 +0000
@@ -379,12 +379,18 @@
(fact (foo x))
(rule (bar (baz ?x ?y ?z ?thing))
(foo ?thing))
- (fact (wild ? ? ?)))
+ (fact (wild ? ? ?))
+
+ (fact (does x move))
+ (rule (next z)
+ (does ? move)))
(should-return
((following (s x x x a)) empty)
((bar (baz a b c no)) fail)
((bar (baz a b c ?what)) (?what x))
- ((wild a b c) empty))))
+ ((wild a b c) empty)
+ ((next z) empty)
+ )))
(test normalization-ui
(with-fresh-database
@@ -483,3 +489,4 @@
((lol ?anything) fail)
((= 0 1) fail)
((= 0 0) empty))))
+