--- a/.lispwords Wed Jun 29 13:53:59 2016 +0000
+++ b/.lispwords Wed Jun 29 16:42:02 2016 +0000
@@ -6,3 +6,4 @@
(2 set-when-unbound)
(1 recursively)
(1 when-let)
+(1 rule)
--- a/package-test.lisp Wed Jun 29 13:53:59 2016 +0000
+++ b/package-test.lisp Wed Jun 29 16:42:02 2016 +0000
@@ -28,6 +28,7 @@
#:rules
#:fact
#:facts
+ #:call
#:return-one
#:return-all)
(:shadowing-import-from #:bones.wam
--- a/src/wam/bytecode.lisp Wed Jun 29 13:53:59 2016 +0000
+++ b/src/wam/bytecode.lisp Wed Jun 29 16:42:02 2016 +0000
@@ -33,6 +33,7 @@
(+opcode-put-value-stack+ 3)
(+opcode-call+ 2)
+ (+opcode-dynamic-call+ 1)
(+opcode-proceed+ 1)
(+opcode-allocate+ 2)
(+opcode-deallocate+ 1)
@@ -76,6 +77,7 @@
(+opcode-put-value-stack+ "PUT-VALUE")
(+opcode-call+ "CALL")
+ (+opcode-dynamic-call+ "DYNAMIC-CALL")
(+opcode-proceed+ "PROCEED")
(+opcode-allocate+ "ALLOCATE")
(+opcode-deallocate+ "DEALLOCATE")
@@ -119,6 +121,7 @@
(+opcode-put-value-stack+ "PVLU")
(+opcode-call+ "CALL")
+ (+opcode-dynamic-call+ "DYCL")
(+opcode-proceed+ "PROC")
(+opcode-allocate+ "ALOC")
(+opcode-deallocate+ "DEAL")
--- a/src/wam/compiler.lisp Wed Jun 29 13:53:59 2016 +0000
+++ b/src/wam/compiler.lisp Wed Jun 29 16:42:02 2016 +0000
@@ -920,9 +920,14 @@
(handle-cut ()
(push-instruction :cut))
(handle-call (functor arity)
- ;; CALL functor
- (push-instruction :call
- (wam-ensure-functor-index wam (cons functor arity)))
+ (if (and (eq functor 'call)
+ (= arity 1))
+ ;; DYNAMIC-CALL
+ (push-instruction :dynamic-call)
+ ;; CALL functor
+ (push-instruction
+ :call
+ (wam-ensure-functor-index wam (cons functor arity))))
;; This is a little janky, but at this point the body goals have been
;; turned into one single stream of tokens, so we don't have a nice
;; clean way to tell when one ends. But in practice, a body goal is
@@ -1250,6 +1255,7 @@
(:put-list +opcode-put-list+)
(:unify-constant +opcode-unify-constant+)
(:call +opcode-call+)
+ (:dynamic-call +opcode-dynamic-call+)
(:proceed +opcode-proceed+)
(:allocate +opcode-allocate+)
(:deallocate +opcode-deallocate+)
--- a/src/wam/constants.lisp Wed Jun 29 13:53:59 2016 +0000
+++ b/src/wam/constants.lisp Wed Jun 29 16:42:02 2016 +0000
@@ -134,6 +134,7 @@
;; Control
+opcode-call+
+ +opcode-dynamic-call+
+opcode-proceed+
+opcode-allocate+
+opcode-deallocate+
--- a/src/wam/vm.lisp Wed Jun 29 13:53:59 2016 +0000
+++ b/src/wam/vm.lisp Wed Jun 29 16:42:02 2016 +0000
@@ -76,6 +76,14 @@
(defmacro with-cell ((address-symbol cell-symbol) wam target &body body)
+ "Bind variables to the (dereferenced) contents of the cell
+
+ `target` should be an address in the WAM store.
+
+ `address-symbol` and `cell-symbol` will be bound to the final address/cell
+ after dereferencing `target.`
+
+ "
(once-only (wam target)
`(let* ((,address-symbol (deref ,wam ,target))
(,cell-symbol (wam-store-cell ,wam ,address-symbol)))
@@ -177,19 +185,22 @@
chosen arbitrarily.
"
- (cond
- ;; a1 <- a2
- ((unbound-reference-p wam address-1)
- (setf (wam-store-cell wam address-1)
- (make-cell-reference address-2))
- (trail! wam address-1))
- ;; a2 <- 1a
- ((unbound-reference-p wam address-2)
- (setf (wam-store-cell wam address-2)
- (make-cell-reference address-1))
- (trail! wam address-2))
- ;; wut
- (t (error "At least one cell must be an unbound reference when binding.")))
+ (let ((cell-1 (wam-store-cell wam address-1))
+ (cell-2 (wam-store-cell wam address-2)))
+ (cond
+ ;; a1 <- a2
+ ((and (cell-reference-p cell-1)
+ (or (not (cell-reference-p cell-2))
+ (< address-2 address-1)))
+ (setf (wam-store-cell wam address-1) cell-2)
+ (trail! wam address-1))
+ ;; a2 <- a1
+ ((cell-reference-p cell-2)
+ (setf (wam-store-cell wam address-2) cell-1)
+ (trail! wam address-2))
+ ;; wut
+ (t
+ (error "At least one cell must be an unbound reference when binding."))))
(values))
(defun* unify! ((wam wam) (a1 store-index) (a2 store-index))
@@ -455,12 +466,13 @@
;;;; Control Instructions
-(define-instruction %call ((wam wam) (functor functor-index))
+(define-instruction %call ((wam wam) (functor functor-index)
+ &optional (program-counter-increment
+ (instruction-size +opcode-call+)))
(let ((target (wam-code-label wam functor)))
(if target
(setf (wam-continuation-pointer wam) ; CP <- next instruction
- (+ (wam-program-counter wam)
- (instruction-size +opcode-call+))
+ (+ (wam-program-counter wam) program-counter-increment)
(wam-number-of-arguments wam) ; set NARGS
(wam-functor-arity wam functor)
@@ -473,6 +485,34 @@
;; Trying to call an unknown procedure.
(backtrack! wam))))
+(define-instruction %dynamic-call ((wam wam))
+ ;; It's assumed that whatever we want to dynamically call has been put in
+ ;; argument register zero.
+ (with-cell (addr cell) wam 0 ; A_0
+ (cond
+ ((cell-structure-p cell)
+ (with-cell (functor-address functor-cell) wam (cell-value cell)
+ (let ((functor (cell-value functor-cell)))
+ ;; If we have a non-zero-arity structure, we need to set up the
+ ;; argument registers before we call it. Luckily all the arguments
+ ;; conveniently live contiguously right after the functor cell.
+ (loop :with arity = (wam-functor-arity wam functor)
+ :for argument-register :from 0 :below arity
+ :for argument-address :from (1+ functor-address)
+ :do (setf (wam-local-register wam argument-register)
+ (wam-heap-cell wam argument-address)))
+ (%call wam functor (instruction-size +opcode-dynamic-call+)))))
+ ((cell-constant-p cell)
+ ;; Zero-arity functors don't need to set up anything at all -- we can
+ ;; just call them immediately.
+ (%call wam (cell-value cell) (instruction-size +opcode-dynamic-call+)))
+ ((cell-reference-p cell)
+ ;; It's okay to do (call :var), but :var has to be bound by the time you
+ ;; actually reach it at runtime.
+ (error "Cannot dynamically call an unbound variable."))
+ (t ; You can't (call) anything else.
+ (error "Cannot dynamically call something other than a structure.")))))
+
(define-instruction %proceed ((wam wam))
(setf (wam-program-counter wam) ; P <- CP
(wam-continuation-pointer wam)))
@@ -732,6 +772,9 @@
(+opcode-call+
(instruction %call 1)
(setf increment-pc nil))
+ (+opcode-dynamic-call+
+ (instruction %dynamic-call 0)
+ (setf increment-pc nil))
(+opcode-done+
(if (funcall done-thunk)
(return-from run)
@@ -745,7 +788,7 @@
(setf (wam-backtracked wam) nil
increment-pc t)
(when (>= pc (fill-pointer code))
- (error "Fell off the end of the program code store!"))))))
+ (error "Fell off the end of the program code store."))))))
(values)))
(defun run-query (wam term
--- a/test/wam.lisp Wed Jun 29 13:53:59 2016 +0000
+++ b/test/wam.lisp Wed Jun 29 16:42:02 2016 +0000
@@ -80,8 +80,15 @@
(defmacro should-return (&body queries)
`(progn
- ,@(loop :for (query results) :in queries :collect
- `(is (results= ',results (q ,query))))))
+ ,@(loop :for (query . results) :in queries
+ :collect
+ `(is (results= ',(cond
+ ((equal results '(empty))
+ (list nil))
+ ((equal results '(fail))
+ nil)
+ (t results))
+ (q ,query))))))
;;;; Tests
@@ -119,6 +126,55 @@
(q (listens :who blues)
(drinks :who :what))))))
+(test simple-unification
+ (with-fresh-database
+ (rule (= :x :x))
+ (should-return
+ ((= x x) empty)
+ ((= x y) fail)
+ ((= :x foo) (:x foo))
+ ((= foo :x) (:x foo))
+ ((= (f (g foo)) :x) (:x (f (g foo))))
+ ((= (f (g foo)) (f :x)) (:x (g foo)))
+ ((= (f :x cats) (f dogs :y)) (:x dogs :y cats))
+ ((= (f :x :x) (f dogs :y)) (:x dogs :y dogs)))))
+
+(test dynamic-call
+ (with-fresh-database
+ (facts (g cats)
+ (g (f dogs)))
+ (rule (normal :x)
+ (g :x))
+ (rule (dynamic :struct)
+ (call :struct))
+ (should-return
+ ((normal foo) fail)
+ ((normal cats) empty)
+ ((g cats) empty)
+ ((call (g cats)) empty)
+ ((call (g (f cats))) fail)
+ ((call (nothing)) fail)
+ ((call (g :x))
+ (:x cats)
+ (:x (f dogs)))
+ ((dynamic (g cats)) empty)
+ ((dynamic (g dogs)) fail)
+ ((dynamic (g (f dogs))) empty)
+ ((dynamic (g :x))
+ (:x cats)
+ (:x (f dogs))))))
+
+(test not
+ (with-fresh-database
+ (facts (yes :anything))
+ (rules ((not :x) (call :x) ! fail)
+ ((not :x)))
+ (should-return
+ ((yes x) empty)
+ ((no x) fail)
+ ((not (yes x)) fail)
+ ((not (no x)) empty))))
+
(test backtracking
(with-fresh-database
(facts (a))
@@ -129,8 +185,7 @@
((f :x) (b) (c))
((f :x) (d)))
(should-return
- ((f foo)
- (nil))))
+ ((f foo) empty)))
(with-fresh-database
; (facts (a))
(facts (b))
@@ -140,8 +195,7 @@
((f :x) (b) (c))
((f :x) (d)))
(should-return
- ((f foo)
- (nil))))
+ ((f foo) empty)))
(with-fresh-database
; (facts (a))
(facts (b))
@@ -151,8 +205,7 @@
((f :x) (b) (c))
((f :x) (d)))
(should-return
- ((f foo)
- (nil))))
+ ((f foo) empty)))
(with-fresh-database
; (facts (a))
; (facts (b))
@@ -162,8 +215,7 @@
((f :x) (b) (c))
((f :x) (d)))
(should-return
- ((f foo)
- nil)))
+ ((f foo) fail)))
(with-fresh-database
; (facts (a))
(facts (b))
@@ -173,8 +225,7 @@
((f :x) (b) (c))
((f :x) (d)))
(should-return
- ((f foo)
- nil))))
+ ((f foo) fail))))
(test basic-rules
(with-database *test-database*
@@ -183,25 +234,26 @@
(should-return
((pets alice :what)
- ((:what snakes) (:what cats)))
+ (:what snakes)
+ (:what cats))
((pets bob :what)
- ((:what cats)))
+ (:what cats))
((pets :who snakes)
- ((:who alice)))
+ (:who alice))
((likes kim :who)
- ((:who tom)
- (:who alice)
- (:who kim)
- (:who cats)))
+ (:who tom)
+ (:who alice)
+ (:who kim)
+ (:who cats))
((likes sally :who)
- ((:who tom)))
+ (:who tom))
((narcissist :person)
- ((:person kim))))))
+ (:person kim)))))
(test register-allocation
;; test for tricky register allocation bullshit
@@ -216,8 +268,7 @@
(c :c :c))
(should-return
- ((foo dogs)
- (nil)))))
+ ((foo dogs) empty))))
(test lists
(with-database *test-database*
@@ -229,15 +280,17 @@
(member a (list (list a))))
(should-return
((member :m (list a))
- ((:m a)))
+ (:m a))
((member :m (list a b))
- ((:m a) (:m b)))
+ (:m a)
+ (:m b))
((member :m (list a b a))
- ((:m a) (:m b)))
+ (:m a)
+ (:m b))
((member a (list a))
- (nil))
+ empty)
((member (list foo) (list a (list foo) b))
- (nil)))
+ empty))
;; Check that we can unify against unbound vars that turn into lists
(is ((lambda (result)
(eql (car (getf result :anything)) 'a))
@@ -255,10 +308,12 @@
(rules ((g :what) (never))
((g :what) (f :what)))
(should-return
- ((f :what) ((:what a)
- (:what bc)))
- ((g :what) ((:what a)
- (:what bc)))))
+ ((f :what)
+ (:what a)
+ (:what bc))
+ ((g :what)
+ (:what a)
+ (:what bc))))
(with-fresh-database
; (facts (a))
@@ -271,8 +326,10 @@
(rules ((g :what) (never))
((g :what) (f :what)))
(should-return
- ((f :what) ((:what bc)))
- ((g :what) ((:what bc)))))
+ ((f :what)
+ (:what bc))
+ ((g :what)
+ (:what bc))))
(with-fresh-database
; (facts (a))
@@ -285,8 +342,10 @@
(rules ((g :what) (never))
((g :what) (f :what)))
(should-return
- ((f :what) ((:what d)))
- ((g :what) ((:what d)))))
+ ((f :what)
+ (:what d))
+ ((g :what)
+ (:what d))))
(with-fresh-database
; (facts (a))