# HG changeset patch # User Steve Losh # Date 1459125804 0 # Node ID 0432f016c9120f7ff50b53fdbbed8e06bd5fa01e # Parent 0b1008a7fe76c948dcf554e2bda229e2769fe7d7 WHAT HATH GOD WROUGHT I have a WAM, and it unifies things. Good lord. diff -r 0b1008a7fe76 -r 0432f016c912 src/make-utilities.lisp --- a/src/make-utilities.lisp Sun Mar 27 22:30:52 2016 +0000 +++ b/src/make-utilities.lisp Mon Mar 28 00:43:24 2016 +0000 @@ -6,5 +6,7 @@ :curry :switch :ensure-boolean + :while + :until ) :package "BONES.UTILS") diff -r 0b1008a7fe76 -r 0432f016c912 src/utils.lisp --- a/src/utils.lisp Sun Mar 27 22:30:52 2016 +0000 +++ b/src/utils.lisp Mon Mar 28 00:43:24 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-BOOLEAN) :ensure-package T :package "BONES.UTILS") +;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL) :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 :ENSURE-BOOLEAN)))) + :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE)))) (defun %reevaluate-constant (name value test) (if (not (boundp name)) @@ -210,8 +210,21 @@ "Convert `x` into a Boolean value." (and x t)) + + (defmacro until (expression &body body) + "Executes `body` until `expression` is true." + `(do () + (,expression) + ,@body)) + + + (defmacro while (expression &body body) + "Executes `body` while `expression` is true." + `(until (not ,expression) + ,@body)) + (eval-when (:compile-toplevel :load-toplevel :execute) (export '(define-constant set-equal curry switch eswitch cswitch - ensure-boolean))) + ensure-boolean while until))) ;;;; END OF utils.lisp ;;;; diff -r 0b1008a7fe76 -r 0432f016c912 src/wam/compile.lisp --- a/src/wam/compile.lisp Sun Mar 27 22:30:52 2016 +0000 +++ b/src/wam/compile.lisp Mon Mar 28 00:43:24 2016 +0000 @@ -225,7 +225,8 @@ (defun run (wam instructions) "Execute the machine instructions on the given WAM." (mapc (lambda (action) - (apply (car action) wam (cdr action))) + (when (not (wam-fail wam)) + (apply (car action) wam (cdr action)))) instructions) (values)) diff -r 0b1008a7fe76 -r 0432f016c912 src/wam/dump.lisp --- a/src/wam/dump.lisp Sun Mar 27 22:30:52 2016 +0000 +++ b/src/wam/dump.lisp Mon Mar 28 00:43:24 2016 +0000 @@ -73,7 +73,7 @@ -(defun extract-thing (wam address) +(defun extract-thing (wam &optional (address (wam-register wam 0))) (let ((cell (wam-heap-cell wam (deref wam address)))) (cond ((cell-null-p cell) diff -r 0b1008a7fe76 -r 0432f016c912 src/wam/instructions.lisp --- a/src/wam/instructions.lisp Sun Mar 27 22:30:52 2016 +0000 +++ b/src/wam/instructions.lisp Mon Mar 28 00:43:24 2016 +0000 @@ -56,6 +56,17 @@ (eql functor (wam-functor-lookup wam (cell-functor-index cell)))))) +(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))) + (defun* deref ((wam wam) (address heap-index)) (:returns heap-index) @@ -94,16 +105,46 @@ (values)) -(defun* fail! ((wam wam)) +(defun* fail! ((wam wam) (reason string)) (:returns :void) "Mark a failure in the WAM." (setf (wam-fail wam) t) + (format *debug-io* "FAIL: ~A~%" reason) (values)) -(defun* unify ((wam wam) (a1 heap-index) (a2 heap-index)) - nil - ) +(defun* unify! ((wam wam) (a1 heap-index) (a2 heap-index)) + (wam-unification-stack-push! wam a1) + (wam-unification-stack-push! wam a2) + (setf (wam-fail wam) nil) + ;; TODO: refactor this horror show. + (until (or (wam-fail wam) + (wam-unification-stack-empty-p wam)) + (let ((d1 (deref wam (wam-unification-stack-pop! wam))) + (d2 (deref wam (wam-unification-stack-pop! wam)))) + (when (not (= d1 d2)) + (let ((cell-1 (wam-heap-cell wam d1)) + (cell-2 (wam-heap-cell wam d2))) + (if (or (cell-reference-p cell-1) + (cell-reference-p cell-2)) + ;; If at least one is a reference, bind them. + ;; + ;; We know that any references we see here will be unbound, + ;; because we deref'ed them above. + (bind! wam d1 d2) + ;; Otherwise we're looking at two structures (hopefully, lol). + (let* ((structure-1-addr (cell-value cell-1)) ; find where they + (structure-2-addr (cell-value cell-2)) ; start on the heap + (functor-1 (wam-heap-cell wam structure-1-addr)) ; grab the + (functor-2 (wam-heap-cell wam structure-2-addr))) ;functors + (if (functors-match-p functor-1 functor-2) + ;; If the functors match, push their pairs of arguments onto + ;; the stack to be unified. + (loop :for i :from 1 :to (cell-functor-arity functor-1) :do + (wam-unification-stack-push! wam (+ structure-1-addr i)) + (wam-unification-stack-push! wam (+ structure-2-addr i))) + ;; Otherwise we're hosed. + (fail! wam "Functors don't match in unify!"))))))))) ;;;; Query Instructions @@ -180,15 +221,16 @@ (progn (setf (wam-s wam) (1+ functor-addr)) (setf (wam-mode wam) :read)) - (fail! wam)))) - (t (fail! wam)))) + (fail! wam "Functors don't match in get-struct")))) + (t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A" + (cell-aesthetic cell)))))) (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))) + (wam-s wam))) (:write (setf (wam-register wam register) (nth-value 1 (push-unbound-reference! wam))))) (incf (wam-s wam)) @@ -197,9 +239,9 @@ (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))) + (: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 0b1008a7fe76 -r 0432f016c912 src/wam/wam.lisp --- a/src/wam/wam.lisp Sun Mar 27 22:30:52 2016 +0000 +++ b/src/wam/wam.lisp Mon Mar 28 00:43:24 2016 +0000 @@ -1,7 +1,7 @@ (in-package #:bones.wam) ;;;; WAM -(defparameter *wam-heap-size* 32) +(defparameter *wam-heap-size* 48) (defclass wam () ((heap @@ -34,6 +34,13 @@ :initform nil :type boolean :documentation "The failure register.") + (unification-stack + :reader wam-unification-stack + :initform (make-array 16 + :fill-pointer 0 + :adjustable t + :element-type 'heap-index) + :documentation "The unification stack.") (s :accessor wam-s :initform nil @@ -132,3 +139,17 @@ "Return the symbol for the functor with the given index in the WAM." (aref (wam-functors wam) functor-index)) + +;;;; Unification Stack +(defun* wam-unification-stack-push! ((wam wam) (address heap-index)) + (:returns :void) + (vector-push-extend address (wam-unification-stack wam)) + (values)) + +(defun* wam-unification-stack-pop! ((wam wam)) + (:returns heap-index) + (vector-pop (wam-unification-stack wam))) + +(defun* wam-unification-stack-empty-p ((wam wam)) + (:returns boolean) + (zerop (length (wam-unification-stack wam))))