# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1459103557 0
# Node ID d80af96eaf15dc468212f909a451154c13892a5e
# Parent  e38bc4395d659e0484d9e98300cc6bfa2223abf7
Rewrite registers to be addresses, not cells

Also add initial (incomplete) implementations of the unification instructions.

diff -r e38bc4395d65 -r d80af96eaf15 src/make-utilities.lisp
--- a/src/make-utilities.lisp	Sat Mar 26 22:53:28 2016 +0000
+++ b/src/make-utilities.lisp	Sun Mar 27 18:32:37 2016 +0000
@@ -4,5 +4,7 @@
                     :utilities '(:define-constant
                                  :set-equal
                                  :curry
-                                 :switch)
+                                 :switch
+                                 :ensure-boolean
+                                 )
                     :package "BONES.UTILS")
diff -r e38bc4395d65 -r d80af96eaf15 src/utils.lisp
--- a/src/utils.lisp	Sat Mar 26 22:53:28 2016 +0000
+++ b/src/utils.lisp	Sun Mar 27 18:32:37 2016 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH) :ensure-package T :package "BONES.UTILS")
+;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN) :ensure-package T :package "BONES.UTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "BONES.UTILS")
@@ -17,7 +17,7 @@
                                          :MAKE-GENSYM-LIST :ENSURE-FUNCTION
                                          :CURRY :STRING-DESIGNATOR
                                          :WITH-GENSYMS :EXTRACT-FUNCTION-NAME
-                                         :SWITCH))))
+                                         :SWITCH :ENSURE-BOOLEAN))))
 
   (defun %reevaluate-constant (name value test)
     (if (not (boundp name))
@@ -205,7 +205,13 @@
     "Like `switch`, but signals a continuable error if no key matches."
     (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
   
+
+  (defun ensure-boolean (x)
+    "Convert `x` into a Boolean value."
+    (and x t))
+  
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(define-constant set-equal curry switch eswitch cswitch)))
+  (export '(define-constant set-equal curry switch eswitch cswitch
+            ensure-boolean)))
 
 ;;;; END OF utils.lisp ;;;;
diff -r e38bc4395d65 -r d80af96eaf15 src/wam/cells.lisp
--- a/src/wam/cells.lisp	Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/cells.lisp	Sun Mar 27 18:32:37 2016 +0000
@@ -97,13 +97,30 @@
             (+tag-structure+
               (format nil " ~D" (cell-value cell)))
             (+tag-functor+
-              (format nil "functor ~D/~D"
+              (format nil " functor ~D/~D"
                       (cell-functor-index cell)
                       (cell-functor-arity cell)))
             (+tag-reference+
               (format nil " ~D" (cell-value cell))))))
 
 
+(defun* cell-null-p ((cell heap-cell))
+  (:returns boolean)
+  (= (cell-type cell) +tag-null+))
+
+(defun* cell-reference-p ((cell heap-cell))
+  (:returns boolean)
+  (= (cell-type cell) +tag-reference+))
+
+(defun* cell-functor-p ((cell heap-cell))
+  (:returns boolean)
+  (= (cell-type cell) +tag-functor+))
+
+(defun* cell-structure-p ((cell heap-cell))
+  (:returns boolean)
+  (= (cell-type cell) +tag-structure+))
+
+
 (defun* make-cell ((tag heap-cell-tag) (value heap-cell-value))
   (:returns heap-cell)
   (values
diff -r e38bc4395d65 -r d80af96eaf15 src/wam/dump.lisp
--- a/src/wam/dump.lisp	Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/dump.lisp	Sun Mar 27 18:32:37 2016 +0000
@@ -15,7 +15,6 @@
 (defun dump-heap (wam from to highlight)
   ;; This code is awful, sorry.
   (let ((heap (wam-heap wam)))
-    (format t "HEAP SIZE: ~A~%" (length heap))
     (format t "  +------+-----+--------------+----------------------------+~%")
     (format t "  | ADDR | TYP |        VALUE | DEBUG                      |~%")
     (format t "  +------+-----+--------------+----------------------------+~%")
@@ -40,19 +39,24 @@
 
 (defun dump-wam-registers (wam)
   (format t "REGISTERS:~%")
+  (format t  "~5@A ->~4@A~%" "S" (wam-s wam))
   (loop :for i :from 0
         :for reg :across (wam-registers wam)
-        :do (format t "~5@A -> ~A~%"
+        :for contents = (wam-register-cell wam i)
+        :do (format t "~5@A ->~4@A ~A~%"
                     (format nil "X~D" i)
-                    (cell-aesthetic reg))))
+                    reg
+                    (cell-aesthetic contents))))
 
 (defun dump-wam-functors (wam)
-  (format t "FUNCTORS: ~S~%" (wam-functors wam)))
+  (format t " FUNCTORS: ~S~%" (wam-functors wam)))
 
 
 (defun dump-wam (wam from to highlight)
+  (format t "     FAIL: ~A~%" (wam-fail wam))
+  (format t "     MODE: ~A~%" (wam-mode wam))
   (dump-wam-functors wam)
-  (format t "~%")
+  (format t "HEAP SIZE: ~A~%" (length (wam-heap wam)))
   (dump-wam-registers wam)
   (format t "~%")
   (dump-heap wam from to highlight))
diff -r e38bc4395d65 -r d80af96eaf15 src/wam/instructions.lisp
--- a/src/wam/instructions.lisp	Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/instructions.lisp	Sun Mar 27 18:32:37 2016 +0000
@@ -1,30 +1,123 @@
 (in-package #:bones.wam)
 
+;;;; Utilities
+(defun* push-unbound-reference! ((wam wam))
+  (:returns (values heap-cell heap-index))
+  "Push a new unbound reference cell onto the heap."
+  (wam-heap-push! wam (make-cell-reference (wam-heap-pointer wam))))
+
+(defun* push-new-structure! ((wam wam))
+  (:returns (values heap-cell heap-index))
+  "Push a new structure cell onto the heap.
+
+  The structure cell's value will point at the next address, so make sure you
+  push something there too!
+
+  "
+  (wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam)))))
+
+(defun* push-new-functor! ((wam wam) (functor symbol) (arity arity))
+  (: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)))
+
+
+(defun* bound-reference-p ((address heap-index) (cell heap-cell))
+  (:returns boolean)
+  "Return whether `cell` is a bound reference, assuming it lives at `address`."
+  (ensure-boolean
+    (and (cell-reference-p cell)
+         (not (= (cell-value cell) address)))))
+
+(defun* unbound-reference-p ((address heap-index) (cell heap-cell))
+  (:returns boolean)
+  "Return whether `cell` is an unbound reference, assuming it lives at `address`."
+  (ensure-boolean
+    (and (cell-reference-p cell)
+         (= (cell-value cell) address))))
+
+(defun* matching-functor-p ((wam wam)
+                            (cell heap-cell)
+                            (functor symbol)
+                            (arity arity))
+  (:returns boolean)
+  "Return whether `cell` is a functor cell of `functor`/`arity`."
+  (ensure-boolean
+    (and (cell-functor-p cell)
+         (= arity (cell-functor-arity cell))
+         (eql functor
+              (wam-functor-lookup wam (cell-functor-index cell))))))
+
+
+(defun* deref ((wam wam) (address heap-index))
+  (:returns heap-index)
+  "Dereference the address in the WAM to its eventual destination.
+
+  If the address is a variable that's bound to something, that something will be
+  looked up (recursively) and the address of whatever it's ultimately bound to
+  will be returned.
+
+  "
+  (let ((cell (wam-heap-cell wam address)))
+    (if (bound-reference-p address cell)
+      (deref wam (cell-value cell))
+      address)))
+
+
+(defun* bind! ((wam wam) (address heap-index) (target heap-index))
+  "Bind the reference cell at `address` to `target`.
+
+  The reference cell must be unbound to begin with.
+  TODO: are we sure about this?
+
+  `target` doesn't necessarily need to exist yet.
+  TODO: this seems dangerous...
+
+  "
+  (assert (unbound-reference-p address
+                               (wam-heap-cell wam address))
+          ()
+          "Cannot bind address ~D because it is not an unbound reference."
+          address)
+  (setf (wam-heap-cell wam address)
+        (make-cell-reference target)))
+
+(defun* fail! ((wam wam))
+  "Mark a failure in the WAM."
+  (setf (wam-fail wam) t))
+
+
+(defun* unify ((wam wam) (a1 heap-index) (a2 heap-index))
+  nil
+  )
+
+
 ;;;; Query Instructions
 (defun* %put-structure ((wam wam)
                         (functor symbol)
                         (arity arity)
                         (register register-index))
   (:returns :void)
-  (let ((structure-cell (make-cell-structure (1+ (wam-heap-pointer wam))))
-        (functor-cell (make-cell-functor
-                        (wam-ensure-functor-index wam functor)
-                        arity)))
-    (wam-heap-push! wam structure-cell)
-    (wam-heap-push! wam functor-cell)
-    (setf (wam-register wam register) structure-cell))
+  (setf (wam-register wam register)
+        (nth-value 1 (push-new-structure! wam)))
+  (push-new-functor! wam functor arity)
   (values))
 
 (defun* %set-variable ((wam wam) (register register-index))
   (:returns :void)
-  (let ((cell (make-cell-reference (wam-heap-pointer wam))))
-    (wam-heap-push! wam cell)
-    (setf (wam-register wam register) cell))
+  (setf (wam-register wam register)
+        (nth-value 1 (push-unbound-reference! wam)))
   (values))
 
 (defun* %set-value ((wam wam) (register register-index))
   (:returns :void)
-  (wam-heap-push! wam (wam-register wam register))
+  (wam-heap-push! wam (wam-register-cell wam register))
   (values))
 
 
@@ -34,13 +127,44 @@
                         (arity arity)
                         (register register-index))
   (:returns :void)
+  (let* ((addr (deref wam (wam-register wam register)))
+         (cell (wam-heap-cell wam addr)))
+    (cond
+      ;; If the register points at a reference cell
+      ((cell-reference-p cell)
+       (bind! wam addr (wam-heap-pointer wam))
+       (push-new-structure! wam)
+       (push-new-functor! wam functor arity)
+       (setf (wam-mode wam) :write))
+      ;; If the register points at a structure cell
+      ((cell-structure-p cell)
+       (let* ((target-addr (cell-value cell))
+              (target (wam-heap-cell wam target-addr)))
+         (if (matching-functor-p wam target functor arity)
+           (progn
+             (setf (wam-s wam) (1+ target-addr))
+             (setf (wam-mode wam) :read))
+           (fail! wam))))
+      (t (fail! wam))))
   (values))
 
 (defun* %unify-variable ((wam wam) (register register-index))
   (:returns :void)
+  (ecase (wam-mode wam)
+    (:read (setf (wam-register wam register)
+                 (wam-s-cell wam)))
+    (:write (setf (wam-register wam register)
+                  (nth-value 1 (push-unbound-reference! wam)))))
+  (incf (wam-s wam))
   (values))
 
 (defun* %unify-value ((wam wam) (register register-index))
   (:returns :void)
+  (ecase (wam-mode wam)
+    (:read (unify wam
+                  (cell-value (wam-register wam register))
+                  (wam-s wam)))
+    (:write (wam-heap-push! wam (wam-register wam register))))
+  (incf (wam-s wam))
   (values))
 
diff -r e38bc4395d65 -r d80af96eaf15 src/wam/wam.lisp
--- a/src/wam/wam.lisp	Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/wam.lisp	Sun Mar 27 18:32:37 2016 +0000
@@ -1,9 +1,11 @@
 (in-package #:bones.wam)
 
 ;;;; WAM
+(defparameter *wam-heap-size* 32)
+
 (defclass wam ()
   ((heap
-     :initform (make-array 32
+     :initform (make-array *wam-heap-size*
                            :initial-element (make-cell-null)
                            :element-type 'heap-cell)
      :reader wam-heap
@@ -22,9 +24,26 @@
    (registers
      :reader wam-registers
      :initform (make-array +register-count+
-                           :initial-element (make-cell-null)
-                           :element-type 'heap-cell)
-     :documentation "An array of the X_i registers.")))
+                           ;; Point at the last heap index by default, just to
+                           ;; make it easier to read debug output.
+                           :initial-element (1- *wam-heap-size*)
+                           :element-type 'heap-index)
+     :documentation "An array of the X_i registers.")
+   (fail
+     :accessor wam-fail
+     :initform nil
+     :type boolean
+     :documentation "The failure register.")
+   (s
+     :accessor wam-s
+     :initform nil
+     :type (or null heap-index)
+     :documentation "The S register (address of next subterm to match).")
+   (mode
+     :accessor wam-mode
+     :initform nil
+     :type (or null (member :read :write))
+     :documentation "Current unification mode (:READ or :WRITE (or NIL)).")))
 
 
 (defun make-wam ()
@@ -38,16 +57,16 @@
 ;;; because you can only index so many addresses with N bits.
 
 (defun* wam-heap-push! ((wam wam) (cell heap-cell))
-  (:returns heap-cell)
+  (:returns (values heap-cell heap-index))
   "Push the cell onto the WAM heap and increment the heap pointer.
 
-  Returns the cell.
+  Returns the cell and the address it was pushed to.
 
   "
   (with-slots (heap heap-pointer) wam
     (setf (aref heap heap-pointer) cell)
     (incf heap-pointer)
-    cell))
+    (values cell (1- heap-pointer))))
 
 
 (defun* wam-heap-cell ((wam wam) (address heap-index))
@@ -61,6 +80,7 @@
 
 ;;;; Registers
 ;;; WAM registers are implemented as an array of a fixed number of registers.
+;;; A register contains the address of a cell in the heap.
 
 (defun* wam-register ((wam wam) (register register-index))
   (:returns heap-cell)
@@ -70,6 +90,24 @@
 (defun (setf wam-register) (new-value wam register)
   (setf (aref (wam-registers wam) register) new-value))
 
+(defun* wam-register-cell ((wam wam) (register register-index))
+  (:returns heap-cell)
+  "Return the heap cell `register` is pointing at."
+  (->> register
+    (wam-register wam)
+    (wam-heap-cell wam)))
+
+(defun* wam-s-cell ((wam wam))
+  "Retrieve the cell the S register is pointing at.
+
+  If S is unbound, throws an error.
+
+  "
+  (let ((s (wam-s wam)))
+    (if (null s)
+      (error "Cannot dereference unbound S register.")
+      (wam-heap-cell wam s))))
+
 
 ;;;; Functors
 ;;; Functors are symbols stored in an adjustable array.  Cells refer to