# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1460304174 0
# Node ID 564c709801aac08fed1006521bb946adfa6a7f56
# Parent  e29b793a6e91dc7b39e4fbb2e28dedbd16764202
Implement the query code runner

Also adds a few convenience functions for functors, and makes structures print
more nicely in the heap dump.

diff -r e29b793a6e91 -r 564c709801aa bones.asd
--- a/bones.asd	Sun Apr 10 14:41:50 2016 +0000
+++ b/bones.asd	Sun Apr 10 16:02:54 2016 +0000
@@ -28,8 +28,8 @@
                                            (:file "cells")
                                            (:file "opcodes")
                                            (:file "wam")
+                                           (:file "compile")
                                            (:file "instructions")
-                                           (:file "compile")
                                            (:file "dump")))
                              (:file "bones")))))
 
diff -r e29b793a6e91 -r 564c709801aa src/wam/compile.lisp
--- a/src/wam/compile.lisp	Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/compile.lisp	Sun Apr 10 16:02:54 2016 +0000
@@ -395,13 +395,3 @@
         (multiple-value-call #'tokenize-assignments))
     (compile-program-tokens wam tokens functor arity (wam-code wam))))
 
-
-(defun run (wam instructions)
-  "Execute the machine instructions on the given WAM."
-  ; (loop :)
-  (mapc (lambda (action)
-          (when (not (wam-fail wam))
-            (apply (car action) wam (cdr action))))
-        instructions)
-  (values))
-
diff -r e29b793a6e91 -r 564c709801aa src/wam/constants.lisp
--- a/src/wam/constants.lisp	Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/constants.lisp	Sun Apr 10 16:02:54 2016 +0000
@@ -60,6 +60,7 @@
 (define-constant +opcode-get-variable+ 4)
 (define-constant +opcode-get-value+ 5)
 
+
 ;;; Query
 (define-constant +opcode-put-structure+ 6)
 (define-constant +opcode-set-variable+ 7)
diff -r e29b793a6e91 -r 564c709801aa src/wam/dump.lisp
--- a/src/wam/dump.lisp	Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/dump.lisp	Sun Apr 10 16:02:54 2016 +0000
@@ -6,18 +6,23 @@
         :when (= reg addr)
         :collect i))
 
-(defun heap-debug (wam addr cell)
+(defun heap-debug (wam addr cell indent-p)
   (format
-    nil "~A~{(X~A) ~}"
+    nil "~A~A~{<-X~A ~}"
+    (if indent-p
+      "  "
+      "")
     (switch ((cell-type cell))
       (+tag-reference+
         (if (= addr (cell-value cell))
           "unbound variable "
           (format nil "var pointer to ~D " (cell-value cell))))
+      (+tag-structure+
+        (format nil "structure pointer to ~D " (cell-value cell)))
       (+tag-functor+
-        (format nil "~A/~D "
-                (wam-functor-lookup wam (cell-functor-index cell))
-                (cell-functor-arity cell)))
+        (destructuring-bind (functor . arity)
+            (wam-functor-lookup wam (cell-functor-index cell))
+          (format nil "~A/~D " functor arity)))
       (t ""))
     (registers-pointing-to wam addr)))
 
@@ -30,17 +35,25 @@
     (format t "  +------+-----+--------------+--------------------------------------+~%")
     (when (> from 0)
       (format t "  |    ⋮ |  ⋮  |            ⋮ |                                      |~%"))
-    (flet ((print-cell (i cell)
+    (flet ((print-cell (i cell indent)
              (let ((hi (= i highlight)))
                (format t "~A ~4@A | ~A | ~12@A | ~36A ~A~%"
                        (if hi "==>" "  |")
                        i
                        (cell-type-short-name cell)
                        (cell-value cell)
-                       (heap-debug wam i cell)
+                       (heap-debug wam i cell (> indent 0))
                        (if hi "<===" "|")))))
       (loop :for i :from from :below to
-            :do (print-cell i (aref heap i))))
+            :with indent = 0
+            :for cell = (aref heap i)
+            :do
+            (progn
+              (print-cell i cell indent)
+              (if (cell-functor-p cell)
+                (setf indent (wam-functor-arity wam (cell-functor-index cell)))
+                (when (not (zerop indent))
+                  (decf indent))))))
     (when (< to (length heap))
       (format t "  |    ⋮ |  ⋮  |            ⋮ |                                      |~%"))
     (format t "  +------+-----+--------------+--------------------------------------+~%")
@@ -56,6 +69,7 @@
 (defun pretty-arguments (arguments)
   (format nil "~{ ~4,'0X~}" arguments))
 
+
 (defgeneric instruction-details (opcode arguments functor-list))
 
 (defmethod instruction-details ((opcode t) arguments functor-list)
@@ -87,12 +101,6 @@
           (pretty-functor (first arguments) functor-list)))
 
 
-(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
-  (format nil "CALL~A      ; ~A"
-          (pretty-arguments arguments)
-          (pretty-functor (first arguments) functor-list)))
-
-
 (defmethod instruction-details ((opcode (eql +opcode-get-variable+)) arguments functor-list)
   (format nil "GVAR~A ; A~D -> X~D"
           (pretty-arguments arguments)
@@ -105,20 +113,18 @@
           (second arguments)
           (first arguments)))
 
-
 (defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)
   (format nil "PVAR~A ; A~D <- X~D <- new REF"
           (pretty-arguments arguments)
           (second arguments)
           (first arguments)))
 
-; (defmethod instruction-details ((opcode (eql +opcode-get-value+)) arguments functor-list)
-;   )
 
-; (defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list))
-; (defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list))
-; (defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list))
-; (defmethod instruction-details ((opcode (eql +opcode-proceed+)) arguments functor-list))
+(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
+  (format nil "CALL~A      ; ~A"
+          (pretty-arguments arguments)
+          (pretty-functor (first arguments) functor-list)))
+
 
 (defun dump-code-store (code-store &optional
                                    (from 0)
@@ -189,8 +195,8 @@
       ((cell-structure-p cell)
        (extract-thing wam (cell-value cell)))
       ((cell-functor-p cell)
-       (let ((functor (wam-functor-lookup wam (cell-functor-index cell)))
-             (arity (cell-functor-arity cell)))
+       (destructuring-bind (functor . arity)
+           (wam-functor-lookup wam (cell-functor-index cell))
          (list* functor
                 (loop :for i :from (1+ address) :to (+ address arity)
                       :collect (extract-thing wam i)))))
diff -r e29b793a6e91 -r 564c709801aa src/wam/instructions.lisp
--- a/src/wam/instructions.lisp	Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/instructions.lisp	Sun Apr 10 16:02:54 2016 +0000
@@ -16,16 +16,10 @@
   "
   (wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam)))))
 
-(defun* push-new-functor! ((wam wam) (functor symbol) (arity arity))
+(defun* push-new-functor! ((wam wam) (functor functor-index))
   (:returns (values heap-cell heap-index))
-  "Push a new functor cell onto the heap.
-
-  If the functor isn't already in the functor table it will be added.
-
-  "
-  (wam-heap-push! wam (make-cell-functor
-                        (wam-ensure-functor-index wam functor)
-                        arity)))
+  "Push a new functor cell onto the heap."
+  (wam-heap-push! wam (make-cell-functor functor)))
 
 
 (defun* bound-reference-p ((wam wam) (address heap-index))
@@ -44,26 +38,18 @@
       (and (cell-reference-p cell)
            (= (cell-value cell) address)))))
 
-(defun* matching-functor-p ((wam wam)
-                            (cell heap-cell)
-                            (functor symbol)
-                            (arity arity))
+(defun* matching-functor-p ((cell heap-cell)
+                            (functor functor-index))
   (:returns boolean)
-  "Return whether `cell` is a functor cell of `functor`/`arity`."
+  "Return whether `cell` is a functor cell containing `functor`."
   (ensure-boolean
     (and (cell-functor-p cell)
-         (= arity (cell-functor-arity cell))
-         (eql functor
-              (wam-functor-lookup wam (cell-functor-index cell))))))
+         (= (cell-functor-index cell) functor))))
 
 (defun* functors-match-p ((functor-cell-1 heap-cell)
                           (functor-cell-2 heap-cell))
   (:returns boolean)
   "Return whether the two functor cells represent the same functor."
-  ;; Warning: this is a gross, fast hack.  Functor cell values are a combination
-  ;; of functor index and arity, so the only way they can represent the same
-  ;; functor is if they have the same value.  We don't have to bother actually
-  ;; looking up and comparing the functor symbols themselves.
   (= (cell-value functor-cell-1)
      (cell-value functor-cell-2)))
 
@@ -149,19 +135,20 @@
 
 ;;;; Query Instructions
 (defun* %put-structure ((wam wam)
-                        (functor symbol)
-                        (arity arity)
+                        (functor functor-index)
                         (register register-index))
   (:returns :void)
-  (setf (wam-register wam register)
-        (nth-value 1 (push-new-structure! wam)))
-  (push-new-functor! wam functor arity)
+  (->> (push-new-structure! wam)
+    (nth-value 1)
+    (setf (wam-register wam register)))
+  (push-new-functor! wam functor)
   (values))
 
 (defun* %set-variable ((wam wam) (register register-index))
   (:returns :void)
-  (setf (wam-register wam register)
-        (nth-value 1 (push-unbound-reference! wam)))
+  (->> (push-unbound-reference! wam)
+    (nth-value 1)
+    (setf (wam-register wam register)))
   (values))
 
 (defun* %set-value ((wam wam) (register register-index))
@@ -169,11 +156,24 @@
   (wam-heap-push! wam (wam-register-cell wam register))
   (values))
 
+(defun* %put-variable ((wam wam)
+                       (register register-index)
+                       (argument register-index))
+  (->> (push-unbound-reference! wam)
+    (nth-value 1)
+    (setf (wam-register wam register))
+    (setf (wam-register wam argument))))
+
+(defun* %put-value ((wam wam)
+                    (register register-index)
+                    (argument register-index))
+  (setf (wam-register wam register)
+        (wam-register wam argument)))
+
 
 ;;;; Program Instructions
 (defun* %get-structure ((wam wam)
-                        (functor symbol)
-                        (arity arity)
+                        (functor functor-index)
                         (register register-index))
   (:returns :void)
   (let* ((addr (deref wam (wam-register wam register)))
@@ -193,7 +193,7 @@
       ;; few instructions (which will be unify-*'s, executed in write mode).
       ((cell-reference-p cell)
        (let ((new-structure-address (nth-value 1 (push-new-structure! wam))))
-         (push-new-functor! wam functor arity)
+         (push-new-functor! wam functor)
          (bind! wam addr new-structure-address)
          (setf (wam-mode wam) :write)))
 
@@ -217,7 +217,7 @@
       ((cell-structure-p cell)
        (let* ((functor-addr (cell-value cell))
               (functor-cell (wam-heap-cell wam functor-addr)))
-         (if (matching-functor-p wam functor-cell functor arity)
+         (if (matching-functor-p functor-cell functor)
            (progn
              (setf (wam-s wam) (1+ functor-addr))
              (setf (wam-mode wam) :read))
@@ -246,3 +246,41 @@
   (incf (wam-s wam))
   (values))
 
+
+;;;; Running
+(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
+  "Expand into a call of the appropriate machine instruction.
+
+  `pc` should be a safe place representing the program counter.
+
+  `code-store` should be a safe place representing the instructions.
+
+  "
+  `(,instruction ,wam
+    ,@(loop :for i :from 1 :to number-of-arguments
+            :collect `(aref ,code-store (+ ,pc ,i)))))
+
+(defun run-query (wam term)
+  "Compile query `term` and run the instructions on the `wam`.
+
+  For now, just stop at the call instruction.
+
+  "
+  (let ((code (compile-query wam term)))
+    (loop
+      :with pc = 0 ; local program counter for this hunk of query code
+      :for opcode = (aref code pc)
+      :do
+      (progn
+        (eswitch (opcode)
+          (+opcode-put-structure+ (instruction-call wam %put-structure code pc 2))
+          (+opcode-set-variable+ (instruction-call wam %set-variable code pc 1))
+          (+opcode-set-value+ (instruction-call wam %set-value code pc 1))
+          (+opcode-put-variable+ (instruction-call wam %put-variable code pc 2))
+          (+opcode-put-value+ (instruction-call wam %put-value code pc 2))
+          (+opcode-call+ (return))) ; TODO: actually call
+        (incf pc (instruction-size opcode))
+        (when (>= pc (length code)) ; queries SHOULD always end in a CALL...
+          (error "Fell off the end of the query code store!")))))
+  (values))
+
diff -r e29b793a6e91 -r 564c709801aa src/wam/wam.lisp
--- a/src/wam/wam.lisp	Sun Apr 10 14:41:50 2016 +0000
+++ b/src/wam/wam.lisp	Sun Apr 10 16:02:54 2016 +0000
@@ -195,9 +195,19 @@
         (vector-push-extend functor functors))))
 
 (defun* wam-functor-lookup ((wam wam) (functor-index functor-index))
+  (:returns functor)
+  "Return the functor with the given index in the WAM."
+  (aref (wam-functors wam) functor-index))
+
+(defun* wam-functor-symbol ((wam wam) (functor-index functor-index))
   (:returns symbol)
-  "Return the symbol for the functor with the given index in the WAM."
-  (aref (wam-functors wam) functor-index))
+  "Return the symbol of the functor with the given index in the WAM."
+  (car (wam-functor-lookup wam functor-index)))
+
+(defun* wam-functor-arity ((wam wam) (functor-index functor-index))
+  (:returns arity)
+  "Return the arity of the functor with the given index in the WAM."
+  (cdr (wam-functor-lookup wam functor-index)))
 
 
 ;;;; Unification Stack