--- a/examples/ggp-wam.lisp Fri Jul 15 15:03:01 2016 +0000
+++ b/examples/ggp-wam.lisp Fri Jul 15 19:12:21 2016 +0000
@@ -11,7 +11,7 @@
(init (off q))
(init (off r))
(init (off s))
- (init (step num1)))
+ (init (step 1)))
(rule (next (on p))
@@ -122,13 +122,13 @@
(succ ?x ?y))
-(facts (succ num1 num2)
- (succ num2 num3)
- (succ num3 num4)
- (succ num4 num5)
- (succ num5 num6)
- (succ num6 num7)
- (succ num7 num8))
+(facts (succ 1 2)
+ (succ 2 3)
+ (succ 3 4)
+ (succ 4 5)
+ (succ 5 6)
+ (succ 6 7)
+ (succ 7 8))
(facts (legal robot a)
(legal robot b)
@@ -136,23 +136,23 @@
(legal robot d))
-(rule (goal robot num100)
+(rule (goal robot 100)
(true (on p))
(true (on q))
(true (on r))
(true (on s)))
-(rule (goal robot num0)
+(rule (goal robot 0)
(true (off p)))
-(rule (goal robot num0)
+(rule (goal robot 0)
(true (off q)))
-(rule (goal robot num0)
+(rule (goal robot 0)
(true (off r)))
-(rule (goal robot num0)
+(rule (goal robot 0)
(true (off s)))
(rule (terminal)
- (true (step num8)))
+ (true (step 8)))
(rule (terminal)
(true (on p))
(true (on q))
@@ -247,7 +247,7 @@
; (format t "Searching: ~S (~D remaining)~%" state (length remaining))
(if (terminalp)
(prog1
- (if (and (not exhaust) (eq 'num100 (goal-value *role*)))
+ (if (and (not exhaust) (= 100 (goal-value *role*)))
(list state (reverse path))
nil)
(clear-state))
--- a/src/wam/bytecode.lisp Fri Jul 15 15:03:01 2016 +0000
+++ b/src/wam/bytecode.lisp Fri Jul 15 19:12:21 2016 +0000
@@ -43,7 +43,10 @@
(+opcode-subterm-constant+ "SUBTERM-CONSTANT")
(+opcode-get-list+ "GET-LIST")
- (+opcode-put-list+ "PUT-LIST")))
+ (+opcode-put-list+ "PUT-LIST")
+
+ (+opcode-get-lisp-object+ "GET-LISP-OBJECT")
+ (+opcode-put-lisp-object+ "PUT-LISP-OBJECT")))
(defun* opcode-short-name ((opcode opcode))
(:returns string)
@@ -86,7 +89,10 @@
(+opcode-subterm-constant+ "UCON")
(+opcode-get-list+ "GLST")
- (+opcode-put-list+ "PLST")))
+ (+opcode-put-list+ "PLST")
+
+ (+opcode-get-lisp-object+ "GLOB")
+ (+opcode-put-lisp-object+ "PLOB")))
;;;; Instructions
@@ -134,7 +140,10 @@
(#.+opcode-subterm-constant+ 2)
(#.+opcode-get-list+ 2)
- (#.+opcode-put-list+ 2))
+ (#.+opcode-put-list+ 2)
+
+ (#.+opcode-get-lisp-object+ 3)
+ (#.+opcode-put-lisp-object+ 3))
;;;; Cells
@@ -146,6 +155,7 @@
(#.+cell-type-functor+ "FUNCTOR")
(#.+cell-type-constant+ "CONSTANT")
(#.+cell-type-list+ "LIST")
+ (#.+cell-type-lisp-object+ "LISP-OBJECT")
(#.+cell-type-stack+ "STACK"))
(define-lookup cell-type-short-name (type cell-type string "")
@@ -156,5 +166,6 @@
(#.+cell-type-functor+ "FUN")
(#.+cell-type-constant+ "CON")
(#.+cell-type-list+ "LIS")
+ (#.+cell-type-lisp-object+ "OBJ")
(#.+cell-type-stack+ "STK"))
--- a/src/wam/compiler.lisp Fri Jul 15 15:03:01 2016 +0000
+++ b/src/wam/compiler.lisp Fri Jul 15 19:12:21 2016 +0000
@@ -10,6 +10,10 @@
(and (symbolp term)
(char= (char (symbol-name term) 0) #\?)))
+(defun lisp-object-to-string (o)
+ (with-output-to-string (str)
+ (print-unreadable-object (o str :type t :identity t))))
+
;;;; Registers
(declaim (inline register-type register-number make-register register=
@@ -133,6 +137,9 @@
((head :accessor node-head :type node :initarg :head)
(tail :accessor node-tail :type node :initarg :tail)))
+(defclass lisp-object-node (vanilla-node)
+ ((object :accessor node-object :type t :initarg :object)))
+
; todo functor -> fname
(defun* make-top-level-node ((functor symbol) (arity arity) (arguments list))
@@ -161,6 +168,10 @@
(:returns list-node)
(values (make-instance 'list-node :head head :tail tail)))
+(defun* make-lisp-object-node ((object t))
+ (:returns lisp-object-node)
+ (values (make-instance 'lisp-object-node :object object)))
+
(defgeneric* node-children (node)
(:returns list)
@@ -242,6 +253,11 @@
(dump-node element))))
(format t ">"))
+(defmethod dump-node ((node lisp-object-node))
+ (format t "~VA#<LISP OBJECT " *dump-node-indent* "")
+ (print-node-register node t)
+ (format t "~A>" (lisp-object-to-string (node-object node))))
+
(defmethod dump-node ((node top-level-node))
(format t "#<~A/~D" (node-functor node) (node-arity node))
(let ((*dump-node-indent* 4))
@@ -283,7 +299,7 @@
(destructuring-bind (functor . arguments) term
(when (not (symbolp functor))
(error
- "Cannot parse top-level term ~S because ~S is not a valid functor."
+ "Cannot parse term ~S because ~S is not a valid functor."
term functor))
(case functor
(list (parse-list arguments))
@@ -291,7 +307,9 @@
(t (make-structure-node functor
(length arguments)
(mapcar #'parse arguments))))))
- (t (error "Cannot parse form ~S into a Prolog term." term))))
+ ((numberp term)
+ (make-lisp-object-node term))
+ (t (error "Cannot parse term ~S into a Prolog term." term))))
(defun* parse-top-level (term)
(:returns top-level-node)
@@ -636,6 +654,10 @@
(set-when-unbound node 'register
(allocate-nonvariable-register state)))
+(defmethod allocate-register ((node lisp-object-node) state)
+ (set-when-unbound node 'register
+ (allocate-nonvariable-register state)))
+
(defun* allocate-argument-registers ((node top-level-node))
(loop :for argument :in (node-arguments node)
@@ -729,6 +751,9 @@
((head :accessor assignment-head :type register :initarg :head)
(tail :accessor assignment-tail :type register :initarg :tail)))
+(defclass lisp-object-assignment (register-assignment)
+ ((object :accessor assignment-object :type t :initarg :object)))
+
(defmethod print-object ((assignment structure-assignment) stream)
(print-unreadable-object (assignment stream :type nil :identity nil)
@@ -751,6 +776,12 @@
(register-to-string (assignment-head assignment))
(register-to-string (assignment-tail assignment)))))
+(defmethod print-object ((assignment lisp-object-assignment) stream)
+ (print-unreadable-object (assignment stream :type nil :identity nil)
+ (format stream "~A = ~A"
+ (register-to-string (assignment-register assignment))
+ (lisp-object-to-string (assignment-object assignment)))))
+
(defgeneric* node-flatten (node)
(:returns (or null register-assignment)))
@@ -776,6 +807,11 @@
:head (node-register (node-head node))
:tail (node-register (node-tail node)))))
+(defmethod node-flatten ((node lisp-object-node))
+ (values (make-instance 'lisp-object-assignment
+ :register (node-register node)
+ :object (node-object node))))
+
(defun* flatten-breadth-first ((tree top-level-node))
(:returns list)
@@ -834,6 +870,8 @@
(defclass list-token (register-token) ())
+(defclass lisp-object-token (register-token)
+ ((object :accessor token-object :type t :initarg :object)))
(defclass procedure-call-token ()
((functor :accessor token-functor :type symbol :initarg :functor)
@@ -871,6 +909,12 @@
(print-unreadable-object (token stream :identity nil :type nil)
(format stream "~A = LIST" (register-to-string (token-register token)))))
+(defmethod print-object ((token lisp-object-token) stream)
+ (print-unreadable-object (token stream :identity nil :type nil)
+ (format stream "~A = ~A"
+ (register-to-string (token-register token))
+ (lisp-object-to-string (token-object token)))))
+
(defmethod print-object ((token call-token) stream)
(print-unreadable-object (token stream :identity nil :type nil)
(format stream "CALL ~A/~D"
@@ -909,6 +953,10 @@
(make-register-token (assignment-head assignment))
(make-register-token (assignment-tail assignment))))
+(defmethod tokenize-assignment ((assignment lisp-object-assignment))
+ (list (make-instance 'lisp-object-token
+ :register (assignment-register assignment)
+ :object (assignment-object assignment))))
(defun* tokenize-assignments ((assignments list))
(:returns list)
@@ -1059,6 +1107,12 @@
(:program :get-list)
(:query :put-list)))
+(defun* find-opcode-lisp-object ((mode keyword))
+ (:returns keyword)
+ (ecase mode
+ (:program :get-lisp-object)
+ (:query :put-lisp-object)))
+
(defun* find-opcode-structure ((mode keyword))
(:returns keyword)
(ecase mode
@@ -1133,6 +1187,10 @@
(push register seen)
(push-instruction (find-opcode-list mode)
register))
+ (handle-lisp-object (register object)
+ ;; OP object register
+ (push register seen)
+ (push-instruction (find-opcode-lisp-object mode) object register))
(handle-cut ()
(push-instruction :cut))
(handle-procedure-call (functor arity is-jump)
@@ -1174,6 +1232,9 @@
(token-arity token)))
(list-token
(handle-list (token-register token)))
+ (lisp-object-token
+ (handle-lisp-object (token-register token)
+ (token-object token)))
(cut-token
(handle-cut))
(jump-token
@@ -1505,9 +1566,11 @@
(:subterm-void +opcode-subterm-void+)
(:put-constant +opcode-put-constant+)
(:get-constant +opcode-get-constant+)
+ (:subterm-constant +opcode-subterm-constant+)
(:get-list +opcode-get-list+)
(:put-list +opcode-put-list+)
- (:subterm-constant +opcode-subterm-constant+)
+ (:get-lisp-object +opcode-get-lisp-object+)
+ (:put-lisp-object +opcode-put-lisp-object+)
(:jump +opcode-jump+)
(:call +opcode-call+)
(:dynamic-jump +opcode-dynamic-jump+)
@@ -1524,11 +1587,9 @@
(defun* render-argument (argument)
(:returns code-word)
(etypecase argument
- ;; todo: simplify this to a single `if` once the store is fully split
(null 0) ; ugly choice point args that'll be filled later...
(register (register-number argument)) ; bytecode just needs register numbers
- (functor argument) ; functors just get literally included
- (number argument))) ; just a numeric argument, e.g. alloc 0
+ (t argument))) ; everything else just gets shoved right into the array
(defun* render-bytecode ((store generic-code-store)
(instructions circle)
--- a/src/wam/constants.lisp Fri Jul 15 15:03:01 2016 +0000
+++ b/src/wam/constants.lisp Fri Jul 15 19:12:21 2016 +0000
@@ -26,6 +26,7 @@
+cell-type-functor+
+cell-type-constant+
+cell-type-list+
+ +cell-type-lisp-object+
+cell-type-stack+)
@@ -136,7 +137,11 @@
;; Lists
+opcode-get-list+
- +opcode-put-list+)
+ +opcode-put-list+
+
+ ;; Lisp Objects
+ +opcode-get-lisp-object+
+ +opcode-put-lisp-object+)
;;;; Debug Config
--- a/src/wam/vm.lisp Fri Jul 15 15:03:01 2016 +0000
+++ b/src/wam/vm.lisp Fri Jul 15 19:12:21 2016 +0000
@@ -45,18 +45,21 @@
(wam-heap-push! wam +cell-type-constant+ constant))
-(defun* functors-match-p ((f1 functor)
- (f2 functor))
+(defun* functors-match-p ((f1 functor) (f2 functor))
(:returns boolean)
"Return whether the two functor cell values represent the same functor."
(eq f1 f2))
-(defun* constants-match-p ((c1 functor)
- (c2 functor))
+(defun* constants-match-p ((c1 functor) (c2 functor))
(:returns boolean)
- "Return whether the two constant cells represent the same functor."
+ "Return whether the two constant cell values unify."
(eq c1 c2))
+(defun* lisp-objects-match-p ((o1 t) (o2 t))
+ (:returns boolean)
+ "Return whether the two lisp object cells unify."
+ (eql o1 o2))
+
;;;; "Ancillary" Functions
(declaim (inline deref unbind! trail!))
@@ -174,63 +177,72 @@
(t (error "At least one cell must be an unbound reference when binding."))))
(defun* unify! ((wam wam) (a1 store-index) (a2 store-index))
- (wam-unification-stack-push! wam a1)
- (wam-unification-stack-push! wam a2)
(setf (wam-fail wam) nil)
- ;; TODO: refactor this horror show.
+ (wam-unification-stack-push! wam a1 a2)
+
(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)))
(t1 (wam-store-type wam d1))
(t2 (wam-store-type wam d2)))
- (when (not (= d1 d2))
- (cond
- ;; 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.
- ((or (cell-type= t1 :reference)
- (cell-type= t2 :reference))
- (bind! wam d1 d2))
+ (macrolet ((both (cell-type-designator)
+ `(and
+ (cell-type= t1 ,cell-type-designator)
+ (cell-type= t2 ,cell-type-designator)))
+ (either (cell-type-designator)
+ `(or
+ (cell-type= t1 ,cell-type-designator)
+ (cell-type= t2 ,cell-type-designator))))
+ (flet ((match-values (predicate)
+ (when (not (funcall predicate
+ (wam-store-value wam d1)
+ (wam-store-value wam d2)))
+ (backtrack! wam))))
+ (when (not (= d1 d2))
+ (cond
+ ;; 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.
+ ((either :reference)
+ (bind! wam d1 d2))
- ;; Otherwise if they're both constants, make sure they match.
- ((and (cell-type= t1 :constant)
- (cell-type= t2 :constant))
- (let ((c1 (wam-store-value wam d1))
- (c2 (wam-store-value wam d2)))
- (when (not (constants-match-p c1 c2))
- (backtrack! wam))))
+ ;; Otherwise if they're both constants or lisp objects, make sure
+ ;; they match exactly.
+ ((both :constant) (match-values #'constants-match-p))
+ ((both :lisp-object) (match-values #'lisp-objects-match-p))
- ;; Otherwise if they're both lists, unify their contents.
- ((and (cell-type= t1 :list)
- (cell-type= t2 :list))
- (wam-unification-stack-push! wam (wam-store-value wam d1))
- (wam-unification-stack-push! wam (wam-store-value wam d2))
- (wam-unification-stack-push! wam (1+ (wam-store-value wam d1)))
- (wam-unification-stack-push! wam (1+ (wam-store-value wam d2))))
+ ;; Otherwise if they're both lists, unify their contents.
+ ((both :list)
+ (wam-unification-stack-push! wam
+ (wam-store-value wam d1)
+ (wam-store-value wam d2))
+ (wam-unification-stack-push! wam
+ (1+ (wam-store-value wam d1))
+ (1+ (wam-store-value wam d2))))
- ;; Otherwise if they're both structures, make sure they match and
- ;; then schedule their subterms to be unified.
- ((and (cell-type= t1 :structure)
- (cell-type= t2 :structure))
- (let* ((s1 (wam-store-value wam d1)) ; find where they
- (s2 (wam-store-value wam d2)) ; start on the heap
- (f1 (wam-store-value wam s1)) ; grab the
- (f2 (wam-store-value wam s2))) ; functors
- (if (functors-match-p f1 f2)
- ;; If the functors match, push their pairs of arguments onto
- ;; the stack to be unified.
- (loop :with arity = (cdr f1)
- :for i :from 1 :to arity :do
- (wam-unification-stack-push! wam (+ s1 i))
- (wam-unification-stack-push! wam (+ s2 i)))
- ;; Otherwise we're hosed.
- (backtrack! wam))))
+ ;; Otherwise if they're both structures, make sure they match and
+ ;; then schedule their subterms to be unified.
+ ((both :structure)
+ (let* ((s1 (wam-store-value wam d1)) ; find where they
+ (s2 (wam-store-value wam d2)) ; start on the heap
+ (f1 (wam-store-value wam s1)) ; grab the
+ (f2 (wam-store-value wam s2))) ; functors
+ (if (functors-match-p f1 f2)
+ ;; If the functors match, push their pairs of arguments onto
+ ;; the stack to be unified.
+ (loop :with arity = (cdr f1)
+ :repeat arity
+ :for subterm1 :from (1+ s1)
+ :for subterm2 :from (1+ s2)
+ :do (wam-unification-stack-push! wam subterm1 subterm2))
+ ;; Otherwise we're hosed.
+ (backtrack! wam))))
- ;; Otherwise we're looking at two different kinds of cells, and are
- ;; just totally hosed. Backtrack.
- (t (backtrack! wam)))))))
+ ;; Otherwise we're looking at two different kinds of cells, and are
+ ;; just totally hosed. Backtrack.
+ (t (backtrack! wam)))))))))
;;;; Instruction Definition
@@ -338,6 +350,7 @@
(wam-heap-pointer wam))
(setf (wam-mode wam) :write))
+
(define-instructions (%put-variable-local %put-variable-stack)
((wam wam)
(register register-index)
@@ -427,6 +440,7 @@
;; Otherwise we can't unify.
(t (backtrack! wam))))
+
(define-instructions (%get-variable-local %get-variable-stack)
((wam wam)
(register register-index)
@@ -638,6 +652,42 @@
(tidy-trail! wam))))
+;;;; Lisp Object Instructions
+(declaim (inline %%match-lisp-object))
+
+
+(defun* %%match-lisp-object ((wam wam)
+ (object t)
+ (address store-index))
+ (cell-typecase (wam (deref wam address) address)
+ ;; If the thing points at a reference (unbound, because we deref'ed) we just
+ ;; bind it.
+ (:reference
+ (wam-set-store-cell! wam address +cell-type-lisp-object+ object)
+ (trail! wam address))
+
+ ;; If this is a lisp object, "unify" them with eql.
+ ((:lisp-object contents)
+ (when (not (lisp-objects-match-p object contents))
+ (backtrack! wam)))
+
+ ;; Otherwise we can't unify.
+ (t (backtrack! wam))))
+
+
+(define-instruction (%get-lisp-object)
+ ((wam wam)
+ (object t)
+ (register register-index))
+ (%%match-lisp-object wam object register))
+
+(define-instruction (%put-lisp-object)
+ ((wam wam)
+ (object t)
+ (register register-index))
+ (wam-set-local-register! wam register +cell-type-lisp-object+ object))
+
+
;;;; Constant Instructions
(declaim (inline %%match-constant))
@@ -652,7 +702,7 @@
(trail! wam address))
((:constant c)
- (when (not (eq constant c))
+ (when (not (constants-match-p constant c))
(backtrack! wam)))
(t (backtrack! wam))))
@@ -662,9 +712,7 @@
((wam wam)
(constant functor)
(register register-index))
- (wam-set-local-register! wam register +cell-type-constant+ constant)
- ; todo we can probably elide this because constants never have subterms...
- (setf (wam-mode wam) :write))
+ (wam-set-local-register! wam register +cell-type-constant+ constant))
(define-instruction (%get-constant)
((wam wam)
@@ -715,6 +763,7 @@
(loop :repeat arity
:for subterm :from (+ address 1)
:collect (recur subterm)))))
+ ((:lisp-object o) o)
(t (error "What to heck is this?")))))
(mapcar #'recur addresses))))
@@ -838,6 +887,9 @@
(#.+opcode-put-constant+ :instruction %put-constant)
(#.+opcode-get-constant+ :instruction %get-constant)
(#.+opcode-subterm-constant+ :instruction %subterm-constant)
+ ;; Lisp Objects
+ (#.+opcode-put-lisp-object+ :instruction %put-lisp-object)
+ (#.+opcode-get-lisp-object+ :instruction %get-lisp-object)
;; List
(#.+opcode-put-list+ :instruction %put-list)
(#.+opcode-get-list+ :instruction %get-list)
--- a/src/wam/wam.lisp Fri Jul 15 15:03:01 2016 +0000
+++ b/src/wam/wam.lisp Fri Jul 15 19:12:21 2016 +0000
@@ -147,6 +147,10 @@
;;; consecutive cells. The first cell is the car of the list, the second one is
;;; the cdr.
;;;
+;;; LISP-OBJECT cell values are simply arbitrary objects in memory. They are
+;;; compared with `eql` during the unification process, so we don't actually
+;;; care WHAT they are, exactly.
+;;;
;;; STACK cell values are special cases. The WAM's main store is a combination
;;; of the heap, the stack, and registers. Heap cells (and registers) are those
;;; detailed above, but stack cells can also hold numbers like the continuation
@@ -203,6 +207,7 @@
(define-unsafe %unsafe-functor-value functor)
(define-unsafe %unsafe-constant-value functor)
(define-unsafe %unsafe-list-value store-index)
+ (define-unsafe %unsafe-lisp-object-value t)
(define-unsafe %unsafe-stack-value stack-word))
@@ -214,6 +219,7 @@
(:functor +cell-type-functor+)
(:constant +cell-type-constant+)
(:list +cell-type-list+)
+ (:lisp-object +cell-type-lisp-object+)
((t) t)))
(defun %type-designator-accessor (designator)
@@ -223,7 +229,8 @@
(:reference '%unsafe-reference-value)
(:functor '%unsafe-functor-value)
(:constant '%unsafe-constant-value)
- (:list '%unsafe-list-value)))
+ (:list '%unsafe-list-value)
+ (:lisp-object '%unsafe-lisp-object-value)))
(defmacro cell-typecase ((wam address &optional address-symbol) &rest clauses)
@@ -1007,8 +1014,12 @@
wam-unification-stack-empty-p))
-(defun* wam-unification-stack-push! ((wam wam) (address store-index))
- (vector-push-extend address (wam-unification-stack wam)))
+(defun* wam-unification-stack-push!
+ ((wam wam)
+ (address1 store-index)
+ (address2 store-index))
+ (vector-push-extend address1 (wam-unification-stack wam))
+ (vector-push-extend address2 (wam-unification-stack wam)))
(defun* wam-unification-stack-pop! ((wam wam))
(:returns store-index)
--- a/test/wam.lisp Fri Jul 15 15:03:01 2016 +0000
+++ b/test/wam.lisp Fri Jul 15 19:12:21 2016 +0000
@@ -486,3 +486,28 @@
(?what ((move a b) (move a c) (move b c)
(move a b)
(move c a) (move c b) (move a b)))))))
+
+(test numbers
+ (with-fresh-database
+ (push-logic-frame-with
+ (rule (= ?x ?x))
+ (fact (foo 1))
+ (fact (bar 2))
+ (rule (baz ?x) (foo ?x))
+ (rule (baz ?x) (bar ?x))
+ (rule (lol ?x)
+ (foo ?x)
+ (bar ?x)))
+
+ (should-return
+ ((foo ?what)
+ (?what 1))
+ ((bar ?what)
+ (?what 2))
+ ((baz ?what)
+ (?what 1)
+ (?what 2))
+ ((foo 0) fail)
+ ((lol ?anything) fail)
+ ((= 0 1) fail)
+ ((= 0 0) empty))))