# HG changeset patch # User Steve Losh # Date 1464874978 0 # Node ID e8934091b7bba1ac1612e58d17874d3cc8f314e9 # Parent a696be29e83002aece28b7249a14fc591e61f841 Implement Prolog lists diff -r a696be29e830 -r e8934091b7bb .lispwords --- a/.lispwords Thu Jun 02 10:36:29 2016 +0000 +++ b/.lispwords Thu Jun 02 13:42:58 2016 +0000 @@ -2,3 +2,4 @@ (1 repeat) (2 define-instruction define-instructions) (1 with-database) +(3 with-cell) diff -r a696be29e830 -r e8934091b7bb examples/ggp-wam.lisp --- a/examples/ggp-wam.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/examples/ggp-wam.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -3,8 +3,8 @@ (defparameter *d* (make-database)) (with-database *d* - (rules ((member :thing (cons :thing :rest))) - ((member :thing (cons :other :rest)) + (rules ((member :thing '(:thing . :rest))) + ((member :thing '(:other . :rest)) (member :thing :rest))) (rule (true :state :thing) @@ -173,13 +173,13 @@ (defun extract (key results) (mapcar (lambda (result) (getf result key)) results)) -(defun to-fake-list (l) +(defun to-prolog-list (l) (if (null l) - 'nil - `(cons ,(car l) ,(to-fake-list (cdr l))))) + nil + (list 'quote l))) (defun initial-state () - (to-fake-list + (to-prolog-list (with-database *d* (extract :what (return-all (init :what)))))) @@ -205,13 +205,13 @@ (perform-return `((goal ,state :role :goal)) :all))) (defun next-state (current-state move) - (let ((does (to-fake-list `((does - ,(getf move :role) - ,(getf move :move)))))) + (let ((does `('(does + ,(getf move :role) + ,(getf move :move))))) (with-database *d* - (to-fake-list + (to-prolog-list (extract :what - (perform-return `((next ,current-state ,does :what)) :all)))))) + (perform-return `((next ,current-state ,does :what)) :all)))))) diff -r a696be29e830 -r e8934091b7bb src/make-quickutils.lisp --- a/src/make-quickutils.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/make-quickutils.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -12,6 +12,7 @@ :tree-member-p :tree-collect :with-gensyms + :once-only :zip :alist-to-hash-table :map-tree diff -r a696be29e830 -r e8934091b7bb src/quickutils.lisp --- a/src/quickutils.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/quickutils.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :RANGE :ALIST-PLIST) :ensure-package T :package "BONES.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ONCE-ONLY :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :RANGE :ALIST-PLIST) :ensure-package T :package "BONES.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "BONES.QUICKUTILS") @@ -19,9 +19,9 @@ :WITH-GENSYMS :EXTRACT-FUNCTION-NAME :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE :TREE-MEMBER-P :TREE-COLLECT - :TRANSPOSE :ZIP :ALIST-TO-HASH-TABLE - :MAP-TREE :WEAVE :RANGE :SAFE-ENDP - :ALIST-PLIST)))) + :ONCE-ONLY :TRANSPOSE :ZIP + :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE + :RANGE :SAFE-ENDP :ALIST-PLIST)))) (defun %reevaluate-constant (name value test) (if (not (boundp name)) @@ -257,6 +257,45 @@ :append (tree-collect predicate item))))) + (defmacro once-only (specs &body forms) + "Evaluates `forms` with symbols specified in `specs` rebound to temporary +variables, ensuring that each initform is evaluated only once. + +Each of `specs` must either be a symbol naming the variable to be rebound, or of +the form: + + (symbol initform) + +Bare symbols in `specs` are equivalent to + + (symbol symbol) + +Example: + + (defmacro cons1 (x) (once-only (x) `(cons ,x ,x))) + (let ((y 0)) (cons1 (incf y))) => (1 . 1)" + (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY")) + (names-and-forms (mapcar (lambda (spec) + (etypecase spec + (list + (destructuring-bind (name form) spec + (cons name form))) + (symbol + (cons spec spec)))) + specs))) + ;; bind in user-macro + `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n))))) + gensyms names-and-forms) + ;; bind in final expansion + `(let (,,@(mapcar (lambda (g n) + ``(,,g ,,(cdr n))) + gensyms names-and-forms)) + ;; bind in user-macro + ,(let ,(mapcar (lambda (n g) (list (car n) g)) + names-and-forms gensyms) + ,@forms))))) + + (defun transpose (lists) "Analog to matrix transpose for a list of lists given by `lists`." (apply #'mapcar #'list lists)) @@ -330,7 +369,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (export '(define-constant set-equal curry switch eswitch cswitch ensure-boolean while until tree-member-p tree-collect with-gensyms - with-unique-names zip alist-to-hash-table map-tree weave range - alist-plist plist-alist))) + with-unique-names once-only zip alist-to-hash-table map-tree weave + range alist-plist plist-alist))) ;;;; END OF quickutils.lisp ;;;; diff -r a696be29e830 -r e8934091b7bb src/wam/bytecode.lisp --- a/src/wam/bytecode.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/bytecode.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -1,6 +1,7 @@ (in-package #:bones.wam) ;;;; Opcodes +(declaim (inline instruction-size)) (defun* instruction-size ((opcode opcode)) (:returns (integer 1 3)) "Return the size of an instruction for the given opcode. @@ -11,7 +12,7 @@ (eswitch (opcode) (+opcode-noop+ 1) - (+opcode-get-structure-local+ 3) + (+opcode-get-structure+ 3) (+opcode-unify-variable-local+ 2) (+opcode-unify-variable-stack+ 2) (+opcode-unify-value-local+ 2) @@ -21,7 +22,7 @@ (+opcode-get-value-local+ 3) (+opcode-get-value-stack+ 3) - (+opcode-put-structure-local+ 3) + (+opcode-put-structure+ 3) (+opcode-set-variable-local+ 2) (+opcode-set-variable-stack+ 2) (+opcode-set-value-local+ 2) @@ -43,14 +44,17 @@ (+opcode-get-constant+ 3) (+opcode-set-constant+ 2) (+opcode-put-constant+ 3) - (+opcode-unify-constant+ 2))) + (+opcode-unify-constant+ 2) + + (+opcode-get-list+ 2) + (+opcode-put-list+ 2))) (defun* opcode-name ((opcode opcode)) (:returns string) (eswitch (opcode) (+opcode-noop+ "NOOP") - (+opcode-get-structure-local+ "GET-STRUCTURE") + (+opcode-get-structure+ "GET-STRUCTURE") (+opcode-unify-variable-local+ "UNIFY-VARIABLE") (+opcode-unify-variable-stack+ "UNIFY-VARIABLE") (+opcode-unify-value-local+ "UNIFY-VALUE") @@ -60,7 +64,7 @@ (+opcode-get-value-local+ "GET-VALUE") (+opcode-get-value-stack+ "GET-VALUE") - (+opcode-put-structure-local+ "PUT-STRUCTURE") + (+opcode-put-structure+ "PUT-STRUCTURE") (+opcode-set-variable-local+ "SET-VARIABLE") (+opcode-set-variable-stack+ "SET-VARIABLE") (+opcode-set-value-local+ "SET-VALUE") @@ -82,14 +86,17 @@ (+opcode-get-constant+ "GET-CONSTANT") (+opcode-set-constant+ "SET-CONSTANT") (+opcode-put-constant+ "PUT-CONSTANT") - (+opcode-unify-constant+ "UNIFY-CONSTANT"))) + (+opcode-unify-constant+ "UNIFY-CONSTANT") + + (+opcode-get-list+ "GET-LIST") + (+opcode-put-list+ "PUT-LIST"))) (defun* opcode-short-name ((opcode opcode)) (:returns string) (eswitch (opcode) (+opcode-noop+ "NOOP") - (+opcode-get-structure-local+ "GETS") + (+opcode-get-structure+ "GETS") (+opcode-unify-variable-local+ "UVAR") (+opcode-unify-variable-stack+ "UVAR") (+opcode-unify-value-local+ "UVLU") @@ -99,7 +106,7 @@ (+opcode-get-value-local+ "GVLU") (+opcode-get-value-stack+ "GVLU") - (+opcode-put-structure-local+ "PUTS") + (+opcode-put-structure+ "PUTS") (+opcode-set-variable-local+ "SVAR") (+opcode-set-variable-stack+ "SVAR") (+opcode-set-value-local+ "SVLU") @@ -121,5 +128,8 @@ (+opcode-get-constant+ "GCON") (+opcode-set-constant+ "SCON") (+opcode-put-constant+ "PCON") - (+opcode-unify-constant+ "UCON"))) + (+opcode-unify-constant+ "UCON") + (+opcode-get-list+ "GLST") + (+opcode-put-list+ "PLST"))) + diff -r a696be29e830 -r e8934091b7bb src/wam/cells.lisp --- a/src/wam/cells.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/cells.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -67,7 +67,8 @@ cell-reference-p cell-functor-p cell-structure-p - cell-constant-p)) + cell-constant-p + cell-list-p)) (defun* cell-null-p ((cell cell)) (:returns boolean) (= (cell-type cell) +tag-null+)) @@ -88,13 +89,18 @@ (:returns boolean) (= (cell-type cell) +tag-constant+)) +(defun* cell-list-p ((cell cell)) + (:returns boolean) + (= (cell-type cell) +tag-list+)) + (declaim (inline make-cell make-cell-null make-cell-structure make-cell-reference make-cell-functor - make-cell-constant)) + make-cell-constant + make-cell-list)) (defun* make-cell ((tag cell-tag) (value cell-value)) (:returns cell) (values @@ -121,3 +127,8 @@ (:returns cell) (make-cell +tag-constant+ functor-index)) +(defun* make-cell-list ((value cell-value)) + (:returns cell) + (make-cell +tag-list+ value)) + + diff -r a696be29e830 -r e8934091b7bb src/wam/compiler.lisp --- a/src/wam/compiler.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/compiler.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -1,6 +1,9 @@ (in-package #:bones.wam) (named-readtables:in-readtable :fare-quasiquote) +;; TODO: Thoroughly document the data formats between each phase. +;; TODO: actually just rewrite this hole fuckin thing. + ;;;; Registers (deftype register-type () '(member :argument :local :permanent)) @@ -87,6 +90,13 @@ (:returns boolean) (keywordp term)) +(defun* prolog-list-p (term) + (:returns boolean) + ;; TODO: is this how we wanna do this? + (and (consp term) + (eql 'quote (car term)) + (consp (cdr term)))) + (defun* variable-assignment-p ((assignment register-assignment)) "Return whether the register assigment is a simple variable assignment. @@ -122,7 +132,8 @@ (defun* structure-assignment-p ((assignment register-assignment)) (:returns boolean) "Return whether the given assignment pair is a structure assignment." - (listp (cdr assignment))) + (and (listp (cdr assignment)) + (eql (cadr assignment) :structure))) (defun* structure-register-p ((register register) (assignments register-assignment-list)) @@ -131,6 +142,19 @@ (structure-assignment-p (find-assignment register assignments))) +(defun* list-assignment-p ((assignment register-assignment)) + (:returns boolean) + "Return whether the given assignment pair is a (Prolog) list assignment." + (and (listp (cdr assignment)) + (eql (cadr assignment) :list))) + +(defun* list-register-p ((register register) + (assignments register-assignment-list)) + (:returns boolean) + "Return whether the given register contains a (Prolog) list assignment." + (list-assignment-p (find-assignment register assignments))) + + ;;;; Parsing ;;; You might want to grab a coffee for this one. ;;; @@ -299,25 +323,41 @@ (make-temporary-register (vector-push-extend var local-registers) arity)) + (store-temporary (contents preallocated-register) + ;; If we've been given a register to hold this thing (i.e. we're + ;; parsing a top-level argument) use it. Otherwise allocate a fresh + ;; one. + ;; + ;; Note that structures/lists always live in local registers, never + ;; permanent ones. + (let ((reg (or preallocated-register + (vector-push-extend nil local-registers)))) + (setf (aref local-registers reg) contents) + (make-temporary-register reg arity))) (parse-variable (var) ;; If we've already seen this variable just return the register it's ;; in, otherwise allocate a register for it and return that. (or (find-variable var) (store-variable var))) - (parse-structure (structure reg) + (parse-structure (structure register) (destructuring-bind (functor . arguments) structure - ;; If we've been given a register to hold this structure (i.e. - ;; we're parsing a top-level argument) use it. Otherwise allocate - ;; a fresh one. Note that structures always live in local - ;; registers, never permanent ones. - (let ((reg (or reg (vector-push-extend nil local-registers)))) - (setf (aref local-registers reg) - (cons functor (mapcar #'parse arguments))) - (make-temporary-register reg arity)))) + (store-temporary + (list* :structure functor (mapcar #'parse arguments)) + register))) + (parse-list (list &optional register) + (destructuring-bind (head . tail) list + (store-temporary + (list :list + (parse head) + (if (consp tail) + (parse-list tail) ; [a, ...] + (parse tail))) ; [a | END] + register))) (parse (term &optional register) (cond ((variablep term) (parse-variable term)) ((symbolp term) (parse (list term) register)) ; f -> f/0 + ((prolog-list-p term) (parse-list (second term) register)) ((listp term) (parse-structure term register)) (t (error "Cannot parse term ~S." term)))) (make-assignment-list (registers register-maker) @@ -360,7 +400,8 @@ ;;; ;;; into something like: ;;; -;;; X2 <- q(X1, X3), X0 <- p(X1, X2) +;;; X2 <- q(X1, X3) +;;; X0 <- p(X1, X2) (defun find-dependencies (assignments) "Return a list of dependencies amongst the given registers. @@ -371,20 +412,27 @@ (mapcan (lambda (assignment) (cond - ; Variable assignments (X1 <- Foo) don't depend on anything else. + ;; Variable assignments (X1 <- Foo) don't depend on anything else. ((variable-assignment-p assignment) ()) - ; Register assignments (A0 <- X5) have one obvious dependency. + ;; Register assignments (A0 <- X5) have one obvious dependency. ((register-assignment-p assignment) (destructuring-bind (argument . contents) assignment (list `(,contents . ,argument)))) - ; Structure assignments depend on all the functor's arguments. + ;; Structure assignments depend on all the functor's arguments. ((structure-assignment-p assignment) - (destructuring-bind (target . (functor . reqs)) + (destructuring-bind (target . (tag functor . reqs)) assignment - (declare (ignore functor)) + (declare (ignore tag functor)) (loop :for req :in reqs :collect (cons req target)))) + ;; Prolog lists/pairs depend on their contents. + ((list-assignment-p assignment) + (destructuring-bind (target . (tag head tail)) + assignment + (declare (ignore tag)) + (list (cons head target) + (cons tail target)))) (t (error "Cannot find dependencies for assignment ~S." assignment)))) assignments)) @@ -429,21 +477,29 @@ (mapcan (lambda (ass) ;; Take a single assignment like: - ;; X1 = f(X4, Y1) (X1 . (f X4 Y1)) + ;; X1 = f(X4, Y1) (X1 . (:structure f X4 Y1)) ;; A0 = X5 (A0 . X5) + ;; X2 = [X3, Y2] (X2 . (:list X3 Y2)) ;; ;; And turn it into a stream of tokens: ;; (X1 = f/2), X4, Y1 ((:structure X1 f 2) X4 Y1 - ;; (A0 = X5) (:argument A0 X5)) + ;; (A0 = X5) (:argument A0 X5) + ;; (X2 = LIST), X3, Y2 (:list X2) X3 Y2) (if (register-assignment-p ass) ;; It might be a register assignment for an argument register. (destructuring-bind (argument-register . target-register) ass (list (list :argument argument-register target-register))) - ;; Otherwise it's a structure assignment. We know the others have - ;; gotten flattened away by now. - (destructuring-bind (register . (functor . arguments)) ass - (cons (list :structure register functor (length arguments)) - arguments)))) + ;; Otherwise it's a structure or list. + (destructuring-bind (register . (tag . body)) ass + (ecase tag + (:structure + (destructuring-bind (functor . arguments) body + (cons (list :structure register functor (length arguments)) + arguments))) + (:list + (list `(:list ,register) + (first body) + (second body))))))) assignments)) @@ -518,9 +574,11 @@ ('(:argument nil :program :stack) :get-value-stack) ('(:argument nil :query :local) :put-value-local) ('(:argument nil :query :stack) :put-value-stack) - ;; Structures can only live locally, they never go on the stack - ('(:structure nil :program :local) :get-structure-local) - ('(:structure nil :query :local) :put-structure-local) + ;; Structures and lists can only live locally, they never go on the stack + ('(:structure nil :program :local) :get-structure) + ('(:structure nil :query :local) :put-structure) + ('(:list nil :program :local) :get-list) + ('(:list nil :query :local) :put-list) ('(:register t :program :local) :unify-variable-local) ('(:register t :program :stack) :unify-variable-stack) ('(:register t :query :local) :set-variable-local) @@ -561,6 +619,10 @@ (push-instruction (find-opcode :structure nil mode destination-register) (wam-ensure-functor-index wam (cons functor arity)) destination-register)) + (handle-list (register) + (push register seen) + (push-instruction (find-opcode :list nil mode register) + register)) (handle-call (functor arity) ;; CALL functor (push-instruction :call @@ -582,6 +644,8 @@ (member (register-type destination-register) '(:local :argument))) (handle-structure destination-register functor arity)) + (`(:list ,register) + (handle-list register)) (`(:call ,functor ,arity) (handle-call functor arity)) ((guard register @@ -810,14 +874,14 @@ :do (match (circle-value node) - ((guard `(:put-structure-local ,functor ,register) + ((guard `(:put-structure ,functor ,register) (constant-p functor)) (setf node (if (register-argument-p register) (optimize-put-constant node functor register) (optimize-set-constant node functor register)))) - ((guard `(:get-structure-local ,functor ,register) + ((guard `(:get-structure ,functor ,register) (constant-p functor)) (setf node (if (register-argument-p register) @@ -836,7 +900,7 @@ (defun render-opcode (opcode) (ecase opcode - (:get-structure-local +opcode-get-structure-local+) + (:get-structure +opcode-get-structure+) (:unify-variable-local +opcode-unify-variable-local+) (:unify-variable-stack +opcode-unify-variable-stack+) (:unify-value-local +opcode-unify-value-local+) @@ -845,7 +909,7 @@ (:get-variable-stack +opcode-get-variable-stack+) (:get-value-local +opcode-get-value-local+) (:get-value-stack +opcode-get-value-stack+) - (:put-structure-local +opcode-put-structure-local+) + (:put-structure +opcode-put-structure+) (:set-variable-local +opcode-set-variable-local+) (:set-variable-stack +opcode-set-variable-stack+) (:set-value-local +opcode-set-value-local+) @@ -857,6 +921,8 @@ (:put-constant +opcode-put-constant+) (:get-constant +opcode-get-constant+) (:set-constant +opcode-set-constant+) + (:get-list +opcode-get-list+) + (:put-list +opcode-put-list+) (:unify-constant +opcode-unify-constant+) (:call +opcode-call+) (:proceed +opcode-proceed+) diff -r a696be29e830 -r e8934091b7bb src/wam/constants.lisp --- a/src/wam/constants.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/constants.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -39,6 +39,9 @@ (define-constant +tag-constant+ #b100 :documentation "A constant (i.e. a 0-arity functor).") +(define-constant +tag-list+ #b101 + :documentation "A Prolog list.") + (define-constant +register-count+ 2048 :documentation "The number of local registers the WAM has available.") @@ -101,7 +104,7 @@ ;;; Program -(define-constant +opcode-get-structure-local+ 1) +(define-constant +opcode-get-structure+ 1) (define-constant +opcode-unify-variable-local+ 2) (define-constant +opcode-unify-variable-stack+ 3) (define-constant +opcode-unify-value-local+ 4) @@ -113,7 +116,7 @@ ;;; Query -(define-constant +opcode-put-structure-local+ 10) +(define-constant +opcode-put-structure+ 10) (define-constant +opcode-set-variable-local+ 11) (define-constant +opcode-set-variable-stack+ 12) (define-constant +opcode-set-value-local+ 13) @@ -134,11 +137,17 @@ (define-constant +opcode-retry+ 25) (define-constant +opcode-trust+ 26) + ;;; Constants (define-constant +opcode-get-constant+ 27) (define-constant +opcode-set-constant+ 28) (define-constant +opcode-put-constant+ 29) (define-constant +opcode-unify-constant+ 30) +;;; Lists +(define-constant +opcode-get-list+ 31) +(define-constant +opcode-put-list+ 32) + + ;;;; Debug Config (defparameter *off-by-one* nil) diff -r a696be29e830 -r e8934091b7bb src/wam/dump.lisp --- a/src/wam/dump.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/dump.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -172,13 +172,13 @@ (pretty-arguments arguments) (first arguments))) -(defmethod instruction-details ((opcode (eql +opcode-get-structure-local+)) arguments functor-list) +(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list) (format nil "GETS~A ; X~A = ~A" (pretty-arguments arguments) (second arguments) (pretty-functor (first arguments) functor-list))) -(defmethod instruction-details ((opcode (eql +opcode-put-structure-local+)) arguments functor-list) +(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list) (format nil "PUTS~A ; X~A <- new ~A" (pretty-arguments arguments) (second arguments) @@ -259,6 +259,16 @@ (pretty-arguments arguments) (pretty-functor (first arguments) functor-list))) +(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments functor-list) + (format nil "GLST~A ; X~A = [vvv | vvv]" + (pretty-arguments arguments) + (first arguments))) + +(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments functor-list) + (format nil "PLST~A ; X~A = [vvv | vvv]" + (pretty-arguments arguments) + (first arguments))) + (defun dump-code-store (wam code-store &optional diff -r a696be29e830 -r e8934091b7bb src/wam/types.lisp --- a/src/wam/types.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/types.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -45,7 +45,7 @@ (deftype opcode () - '(integer 0 30)) + '(integer 0 32)) (deftype stack-frame-size () diff -r a696be29e830 -r e8934091b7bb src/wam/vm.lisp --- a/src/wam/vm.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/vm.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -1,5 +1,4 @@ (in-package #:bones.wam) -(named-readtables:in-readtable :fare-quasiquote) ;;;; Config (defparameter *break-on-fail* nil) @@ -22,6 +21,16 @@ " (wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam))))) +(defun* push-new-list! ((wam wam)) + (:returns (values cell heap-index)) + "Push a new list cell onto the heap. + + The list cell's value will point at the next address, so make sure you push + something there too! + + " + (wam-heap-push! wam (make-cell-list (1+ (wam-heap-pointer wam))))) + (defun* push-new-functor! ((wam wam) (functor functor-index)) (:returns (values cell heap-index)) "Push a new functor cell onto the heap." @@ -66,6 +75,13 @@ (cell-value constant-cell-2))) +(defmacro with-cell ((address-symbol cell-symbol) wam target &body body) + (once-only (wam target) + `(let* ((,address-symbol (deref ,wam ,target)) + (,cell-symbol (wam-store-cell ,wam ,address-symbol))) + ,@body))) + + ;;;; "Ancillary" Functions (defun* backtrack! ((wam wam)) (:returns :void) @@ -176,6 +192,13 @@ (when (not (constants-match-p cell-1 cell-2)) (backtrack! wam))) + ;; Otherwise if they're both lists, make sure their contents match. + ((and (cell-list-p cell-1) (cell-list-p cell-2)) + (wam-unification-stack-push! wam (cell-value cell-1)) + (wam-unification-stack-push! wam (cell-value cell-2)) + (wam-unification-stack-push! wam (1+ (cell-value cell-1))) + (wam-unification-stack-push! wam (1+ (cell-value cell-2)))) + ;; Otherwise if they're both structure cells, make sure they match ;; and then schedule their subterms to be unified. ((and (cell-structure-p cell-1) (cell-structure-p cell-2)) @@ -261,7 +284,7 @@ ;;;; Query Instructions -(define-instruction %put-structure-local +(define-instruction %put-structure ((wam wam) (functor functor-index) (register register-index)) @@ -269,6 +292,12 @@ (make-cell-structure (nth-value 1 (push-new-functor! wam functor))))) +(define-instruction %put-list + ((wam wam) + (register register-index)) + (setf (wam-local-register wam register) + (make-cell-list (wam-heap-pointer wam)))) + (define-instructions (%set-variable-local %set-variable-stack) ((wam wam) (register register-index)) @@ -297,26 +326,26 @@ ;;;; Program Instructions -(define-instruction %get-structure-local ((wam wam) - (functor functor-index) - (register register-index)) +(define-instruction %get-structure ((wam wam) + (functor functor-index) + (register register-index)) (with-accessors ((mode wam-mode) (s wam-subterm)) wam - (let* ((addr (deref wam register)) - (cell (wam-store-cell wam addr))) + (with-cell (addr cell) wam register (cond - ;; If the register points at a reference cell, we push two new cells onto - ;; the heap: + ;; If the register points at a reference cell, we push two new cells + ;; onto the heap: ;; ;; | N | STR | N+1 | ;; | N+1 | FUN | f/n | ;; | | | | <- S ;; - ;; Then we bind this reference cell to point at the new structure, set the - ;; S register to point beneath it and flip over to write mode. + ;; Then we bind this reference cell to point at the new structure, set + ;; the S register to point beneath it and flip over to write mode. ;; ;; It seems a bit confusing that we don't push the rest of the structure - ;; stuff on the heap after it too. But that's going to happen in the next - ;; few instructions (which will be unify-*'s, executed in write mode). + ;; stuff on the heap after it too. But that's going to happen in the + ;; next few instructions (which will be unify-*'s, executed in write + ;; mode). ((cell-reference-p cell) (let ((structure-address (nth-value 1 (push-new-structure! wam))) (functor-address (nth-value 1 (push-new-functor! wam functor)))) @@ -348,8 +377,27 @@ (setf mode :read s (1+ functor-address)) (backtrack! wam)))) + (t (backtrack! wam)))))) +(define-instruction %get-list ((wam wam) + (register register-index)) + (with-cell (addr cell) wam register + (cond + ;; If the register points at a reference (unbound, because we deref'ed) we + ;; bind it to a list and flip into write mode to write the upcoming two + ;; things as its contents. + ((cell-reference-p cell) + (bind! wam addr (push-new-list! wam)) + (setf (wam-mode wam) :write)) + + ;; If this is a list, we need to unify its subterms. + ((cell-list-p cell) + (setf (wam-mode wam) :read + (wam-subterm wam) (cell-value cell))) + + (t (backtrack! wam))))) + (define-instructions (%unify-variable-local %unify-variable-stack) ((wam wam) (register register-index)) @@ -484,8 +532,7 @@ (defun* %%match-constant ((wam wam) (constant functor-index) (address store-index)) - (let* ((addr (deref wam address)) - (cell (wam-store-cell wam addr))) + (with-cell (addr cell) wam address (cond ((cell-reference-p cell) (setf (wam-store-cell wam addr) @@ -561,6 +608,8 @@ ((cell-null-p cell) "NULL?!") ((cell-reference-p cell) (extract-var (cell-value cell))) ((cell-structure-p cell) (recur (cell-value cell))) + ((cell-list-p cell) (cons (recur (cell-value cell)) + (recur (1+ (cell-value cell))))) ((cell-constant-p cell) (wam-functor-symbol wam (cell-value cell))) ((cell-functor-p cell) @@ -598,7 +647,7 @@ (break "About to execute instruction at ~4,'0X" pc)) (eswitch (opcode) ;; Query - (+opcode-put-structure-local+ (instruction %put-structure-local 2)) + (+opcode-put-structure+ (instruction %put-structure 2)) (+opcode-set-variable-local+ (instruction %set-variable-local 1)) (+opcode-set-variable-stack+ (instruction %set-variable-stack 1)) (+opcode-set-value-local+ (instruction %set-value-local 1)) @@ -608,7 +657,7 @@ (+opcode-put-value-local+ (instruction %put-value-local 2)) (+opcode-put-value-stack+ (instruction %put-value-stack 2)) ;; Program - (+opcode-get-structure-local+ (instruction %get-structure-local 2)) + (+opcode-get-structure+ (instruction %get-structure 2)) (+opcode-unify-variable-local+ (instruction %unify-variable-local 1)) (+opcode-unify-variable-stack+ (instruction %unify-variable-stack 1)) (+opcode-unify-value-local+ (instruction %unify-value-local 1)) @@ -622,6 +671,9 @@ (+opcode-get-constant+ (instruction %get-constant 2)) (+opcode-set-constant+ (instruction %set-constant 1)) (+opcode-unify-constant+ (instruction %unify-constant 1)) + ;; List + (+opcode-put-list+ (instruction %put-list 1)) + (+opcode-get-list+ (instruction %get-list 1)) ;; Choice (+opcode-try+ (instruction %try 1)) (+opcode-retry+ (instruction %retry 1)) diff -r a696be29e830 -r e8934091b7bb src/wam/wam.lisp --- a/src/wam/wam.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/src/wam/wam.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -127,7 +127,8 @@ wam-heap-cell (setf wam-heap-cell) wam-heap-pointer - (setf wam-heap-pointer))) + (setf wam-heap-pointer) + wam-heap-push!)) (defun* wam-heap-pointer-unset-p ((wam wam) (address heap-index)) (:returns boolean) @@ -220,7 +221,7 @@ (defun* assert-inside-stack ((wam wam) (address store-index)) (:returns :void) - (declare (ignore wam address)) + (declare (ignorable wam address)) (policy-cond:policy-cond ((>= debug 2) (progn diff -r a696be29e830 -r e8934091b7bb test/wam.lisp --- a/test/wam.lisp Thu Jun 02 10:36:29 2016 +0000 +++ b/test/wam.lisp Thu Jun 02 13:42:58 2016 +0000 @@ -50,7 +50,11 @@ (likes :who cats))) (rules ((narcissist :person) - (likes :person :person)))) + (likes :person :person))) + + (rules ((member :x '(:x . :rest))) + ((member :x '(:y . :rest)) + (member :x :rest)))) db)) (defparameter *test-database* (make-test-database)) @@ -69,9 +73,16 @@ `(with-database *test-database* (return-all ,@query))) -(defmacro check (query) - `(with-database *test-database* - (nth-value 1 (return-one ,query)))) + +(defmacro should-fail (&body queries) + `(progn + ,@(loop :for query :in queries :collect + `(is (results= nil (q ,query)))))) + +(defmacro should-return (&body queries) + `(progn + ,@(loop :for (query results) :in queries :collect + `(is (results= ',results (q ,query)))))) ;;;; Tests @@ -107,27 +118,46 @@ (drinks :who :what))))) (test basic-rules - (is (results= '((:what snakes) - (:what cats)) - (q (pets alice :what)))) + (should-fail + (pets candace :what)) + + (should-return + ((pets alice :what) + ((:what snakes) (:what cats))) + + ((pets bob :what) + ((:what cats))) - (is (results= '((:what cats)) - (q (pets bob :what)))) + ((pets :who snakes) + ((:who alice))) - (is (results= '() - (q (pets candace :what)))) + ((likes kim :who) + ((:who tom) + (:who alice) + (:who kim) + (:who cats))) + + ((likes sally :who) + ((:who tom))) - (is (results= '((:who alice)) - (q (pets :who snakes)))) + ((narcissist :person) + ((:person kim))))) - (is (results= '((:who tom) - (:who alice) - (:who kim) - (:who cats)) - (q (likes kim :who)))) - - (is (results= '((:who tom)) - (q (likes sally :who)))) - - (is (results= '((:person kim)) - (q (narcissist :person))))) +(test lists + (should-fail + (member :anything nil) + (member a nil) + (member b '(a)) + (member '(a) '(a)) + (member a '('(a)))) + (should-return + ((member :m '(a)) + ((:m a))) + ((member :m '(a b)) + ((:m a) (:m b))) + ((member :m '(a b a)) + ((:m a) (:m b))) + ((member a '(a)) + (nil)) + ((member '(foo) '(a '(foo) b)) + (nil))))