# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1467218522 0
# Node ID de6e248866f44f1b997669339a7cce227305419c
# Parent  792dfa2f9120e63ffa02cdd9368e364b30176691
Implement dynamic calling and fix `bind!`

It turns out `bind!` needs to actually *copy* the thing it's binding into the
target, not create a reference.

Dynamic calling was actually pretty easy.

diff -r 792dfa2f9120 -r de6e248866f4 .lispwords
--- 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)
diff -r 792dfa2f9120 -r de6e248866f4 package-test.lisp
--- 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
diff -r 792dfa2f9120 -r de6e248866f4 src/wam/bytecode.lisp
--- 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")
diff -r 792dfa2f9120 -r de6e248866f4 src/wam/compiler.lisp
--- 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+)
diff -r 792dfa2f9120 -r de6e248866f4 src/wam/constants.lisp
--- 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+
diff -r 792dfa2f9120 -r de6e248866f4 src/wam/vm.lisp
--- 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
diff -r 792dfa2f9120 -r de6e248866f4 test/wam.lisp
--- 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))