# HG changeset patch # User Steve Losh # Date 1468254365 0 # Node ID abffacd7848a5735cb58519f47d93c3d3f1f8afd # Parent 3b0161d2100d14fc128e9e86737294c19b816ddf# Parent 8cd3257c58e3c821211401965c8ef78c082d096c Merge the code I accidentally branched off because I'm an idiot diff -r 8cd3257c58e3 -r abffacd7848a examples/ggp-wam.lisp --- a/examples/ggp-wam.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/examples/ggp-wam.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -221,13 +221,21 @@ (pop-logic-frame)) -(defvar *count* 0) +(defun perform-move (joint-move) + (prog2 + (apply-moves joint-move) + (next-state) + (clear-moves))) -; (declaim (optimize (speed 0) (debug 3))) +(defvar *count* 0) +(defvar *role* nil) + + ;; nodes: (state . path) (defun depth-first-search (&key exhaust) (let ((*count* 0) + (*role* (first (roles))) (nodes (make-queue))) (enqueue (cons (initial-state) nil) nodes) (pprint @@ -237,18 +245,16 @@ (dequeue nodes) (apply-state state) ; (format t "Searching: ~S (~D remaining)~%" state (length remaining)) - (if (and (not exhaust) (eql 'num100 (goal-value 'robot))) - (progn - (clear-state) - (return (list state (reverse path)))) + (if (terminalp) + (prog1 + (if (and (not exhaust) (eq 'num100 (goal-value *role*))) + (list state (reverse path)) + nil) + (clear-state)) (let ((children - (when (not (terminalp)) - (loop :for joint-move :in (legal-moves) - :collect (prog2 - (apply-moves joint-move) - (cons (next-state) - (cons joint-move path)) - (clear-moves)))))) + (loop :for joint-move :in (legal-moves) + :collect (cons (perform-move joint-move) + (cons joint-move path))))) (clear-state) (queue-append nodes children)))))) (format t "~%Searched ~D nodes.~%" *count*))) diff -r 8cd3257c58e3 -r abffacd7848a package-test.lisp --- a/package-test.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/package-test.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -29,6 +29,7 @@ #:fact #:facts #:call + #:dump-wam-full #:? #:query #:query-all) diff -r 8cd3257c58e3 -r abffacd7848a package.lisp --- a/package.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/package.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -1,4 +1,3 @@ - (defpackage #:bones.utils (:use #:cl @@ -6,15 +5,19 @@ #:cl-arrows #:bones.quickutils) (:export + #:yolo #:repeat #:hex #:push-if-new + #:array-push #:recursively #:recur #:when-let #:unique-items #:dis + #:megabytes #:gethash-or-init + #:define-lookup #:make-queue #:enqueue #:dequeue @@ -27,6 +30,7 @@ (defpackage #:bones.circle (:use #:cl #:defstar) (:export + #:circle #:make-circle-with #:make-empty-circle #:circle-to-list @@ -144,8 +148,6 @@ #:query-all)) - - (defpackage #:bones (:use #:cl #:bones.wam) (:export diff -r 8cd3257c58e3 -r abffacd7848a src/utils.lisp --- a/src/utils.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/src/utils.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -112,6 +112,34 @@ ,value (setf (gethash ,key ,hash-table) ,default-form)))))) +(defmacro array-push (value array pointer &environment env) + "Push `value` onto `array` at `pointer`, incrementing `pointer` afterword. + + Returns the index the value was pushed to. + + " + (multiple-value-bind (temp-vars temp-vals stores store access) + (get-setf-expansion pointer env) + (with-gensyms (address) + `(let* (,@(mapcar #'list temp-vars temp-vals) + (,address ,access) + (,(car stores) (1+ ,address))) + (setf (aref ,array ,address) ,value) + ,store + ,address)))) + +(defmacro yolo (&body body) + `(locally + #+sbcl (declare (optimize (sb-c::insert-array-bounds-checks 0) + (speed 3) + (debug 0) + (safety 0))) + ,@body)) + +(defun megabytes (n) + "Return the number of 64-bit words in `n` megabytes." + (* 1024 1024 1/8 n)) + ;;;; Queues ;;; From PAIP (thanks, Norvig). @@ -158,4 +186,52 @@ q) +;;;; Lookup Tables +(defmacro define-lookup + (name (key key-type value-type default) documentation &rest entries) + "Define a lookup function. + This macro defines a function that looks up a result in a constant array. + It's useful for things where you're looking up keys that are small integers, + like opcodes. + + The function should be compiled to a few ASM instructions to read from a bit + of memory in O(1) time, instead of a huge list of CMP instructions that's + O(n) on the number of possibilities. + + `name` should be a symbol that will become the name of the function. It will + be munged to make a name for the constant table too, but you shouldn't mess + with that. + + `key` should be a symbol that will be used as the argument for the lookup + function. `key-type` should be its type and should be a subtype of + (integer 0 some-small-number) if you want this to be efficient. + + `value-type` should be the type of your results. + + `default` should be a value that will be returned from your function if a key + that does not exist is requested. Note that this same `eq` value will always + be returned. + + `entries` should be the list of `(key value)` entries for the table. + + Note that `key`, `default`, and all the keys of `entries` must be + macroexpansion-time constants! + + " + (let ((max (reduce #'max entries :key #'car)) + (entries (apply #'append entries))) + (let ((table (intern (format nil "+~A-TABLE+" name)))) + `(progn + (define-constant ,table + (make-array (1+ ,max) + :element-type ',value-type + :initial-contents + (list ,@(loop :for i :from 0 :to max + :collect (getf entries i default)))) + :test (lambda (x y) (declare (ignore x y)) t)) ; what could go wrong + (declaim (inline ,name)) + (defun* ,name ((,key ,key-type)) + (:returns ,value-type) + ,documentation + (aref ,table ,key)))))) diff -r 8cd3257c58e3 -r abffacd7848a src/wam/bytecode.lisp --- a/src/wam/bytecode.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/src/wam/bytecode.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -1,54 +1,51 @@ (in-package #:bones.wam) -;;;; Opcodes -(declaim (inline instruction-size)) -(defun* instruction-size ((opcode opcode)) - (:returns (integer 1 3)) +(define-lookup instruction-size (opcode opcode instruction-size 0) "Return the size of an instruction for the given opcode. The size includes one word for the opcode itself and one for each argument. " - (eswitch (opcode) - ;; TODO: make this thing a jump table somehow... - (+opcode-noop+ 1) + (#.+opcode-noop+ 1) + + (#.+opcode-get-structure+ 3) + (#.+opcode-get-variable-local+ 3) + (#.+opcode-get-variable-stack+ 3) + (#.+opcode-get-value-local+ 3) + (#.+opcode-get-value-stack+ 3) - (+opcode-get-structure+ 3) - (+opcode-get-variable-local+ 3) - (+opcode-get-variable-stack+ 3) - (+opcode-get-value-local+ 3) - (+opcode-get-value-stack+ 3) + (#.+opcode-put-structure+ 3) + (#.+opcode-put-variable-local+ 3) + (#.+opcode-put-variable-stack+ 3) + (#.+opcode-put-value-local+ 3) + (#.+opcode-put-value-stack+ 3) - (+opcode-put-structure+ 3) - (+opcode-put-variable-local+ 3) - (+opcode-put-variable-stack+ 3) - (+opcode-put-value-local+ 3) - (+opcode-put-value-stack+ 3) + (#.+opcode-subterm-variable-local+ 2) + (#.+opcode-subterm-variable-stack+ 2) + (#.+opcode-subterm-value-local+ 2) + (#.+opcode-subterm-value-stack+ 2) + (#.+opcode-subterm-void+ 2) - (+opcode-subterm-variable-local+ 2) - (+opcode-subterm-variable-stack+ 2) - (+opcode-subterm-value-local+ 2) - (+opcode-subterm-value-stack+ 2) - (+opcode-subterm-void+ 2) + (#.+opcode-call+ 2) + (#.+opcode-dynamic-call+ 1) + (#.+opcode-proceed+ 1) + (#.+opcode-allocate+ 2) + (#.+opcode-deallocate+ 1) + (#.+opcode-done+ 1) + (#.+opcode-try+ 2) + (#.+opcode-retry+ 2) + (#.+opcode-trust+ 1) + (#.+opcode-cut+ 1) - (+opcode-call+ 2) - (+opcode-dynamic-call+ 1) - (+opcode-proceed+ 1) - (+opcode-allocate+ 2) - (+opcode-deallocate+ 1) - (+opcode-done+ 1) - (+opcode-try+ 2) - (+opcode-retry+ 2) - (+opcode-trust+ 1) - (+opcode-cut+ 1) + (#.+opcode-get-constant+ 3) + (#.+opcode-put-constant+ 3) + (#.+opcode-subterm-constant+ 2) - (+opcode-get-constant+ 3) - (+opcode-put-constant+ 3) - (+opcode-subterm-constant+ 2) + (#.+opcode-get-list+ 2) + (#.+opcode-put-list+ 2)) - (+opcode-get-list+ 2) - (+opcode-put-list+ 2))) +;;;; Opcodes (defun* opcode-name ((opcode opcode)) (:returns string) diff -r 8cd3257c58e3 -r abffacd7848a src/wam/compiler.lisp --- a/src/wam/compiler.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/src/wam/compiler.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -788,7 +788,6 @@ (defclass cut-token (token) ()) - (defun make-register-token (register) (make-instance 'register-token :register register)) @@ -1347,6 +1346,34 @@ ;;; Rendering is the act of taking the friendly list-of-instructions format and ;;; actually converting it to raw-ass bytes and storing it in an array. +(defun check-instruction (opcode arguments) + (assert (= (length arguments) + (1- (instruction-size opcode))) + () + "Cannot push opcode ~A with ~D arguments ~S, it requires exactly ~D." + (opcode-name opcode) + (length arguments) + arguments + (1- (instruction-size opcode)))) + +(defun* code-push-instruction ((store generic-code-store) + (opcode opcode) + (arguments list) + (address code-index)) + "Push the given instruction into `store` at `address`. + + `arguments` should be a list of `code-word`s. + + Returns how many words were pushed. + + " + (:returns instruction-size) + (check-instruction opcode arguments) + (setf (aref store address) opcode + (subseq store (1+ address)) arguments) + (instruction-size opcode)) + + (defun render-opcode (opcode) (ecase opcode (:get-structure +opcode-get-structure+) @@ -1386,8 +1413,17 @@ (register (register-number argument)) ; bytecode just needs register numbers (number argument))) ; just a numeric argument, e.g. alloc 0 -(defun render-bytecode (code instructions) - "Render `instructions` (a circle) into `code` (a bytecode array)." +(defun* render-bytecode ((code generic-code-store) + (instructions circle) + (start code-index) + (limit code-index)) + "Render `instructions` (a circle) into `code` starting at `start`. + + Bail if ever pushed beyond `limit`. + + Return the total number of code words rendered. + + " (let ((previous-jump nil)) (flet ((fill-previous-jump (address) @@ -1395,29 +1431,37 @@ (setf (aref code (1+ previous-jump)) address)) (setf previous-jump address))) (loop + :with address = start + + ;; Render the next instruction :for (opcode . arguments) :in (circle-to-list instructions) - :for address = (code-push-instruction! code - (render-opcode opcode) - (mapcar #'render-argument arguments)) + :for size = (code-push-instruction code + (render-opcode opcode) + (mapcar #'render-argument arguments) + address) + :summing size + ;; We need to fill in the addresses for the choice point jumping ;; instructions. For example, when we have TRY ... TRUST, the TRUST ;; needs to patch its address into the TRY instruction. ;; ;; I know, this is ugly, sorry. :when (member opcode '(:try :retry :trust)) - :do (fill-previous-jump address))))) + :do (fill-previous-jump address) + + ;; look, don't judge me, i told you i know its bad + :do (incf address size) + + ;; Make sure we don't run past the end of our section. + ;; + ;; TODO: move this check up higher so we don't accidentally + ;; push past the query boundary + :when (>= address limit) + :do (error "Code store exhausted, game over."))))) -(defun make-query-code-store () - (make-array 512 - :fill-pointer 0 - :adjustable t - :element-type 'code-word)) - -(defun render-query (instructions) - (let ((code (make-query-code-store))) - (render-bytecode code instructions) - code)) +(defun render-query (wam instructions) + (render-bytecode (wam-code wam) instructions 0 +maximum-query-size+)) (defun mark-label (wam functor arity address) @@ -1427,26 +1471,29 @@ (defun render-rules (wam functor arity instructions) ;; Before we render the instructions, make the label point at where they're ;; about to go. - (mark-label wam functor arity (fill-pointer (wam-code wam))) - (render-bytecode (wam-code wam) instructions)) + (mark-label wam functor arity (wam-code-pointer wam)) + (incf (wam-code-pointer wam) + (render-bytecode (wam-code wam) + instructions + (wam-code-pointer wam) + (array-total-size (wam-code wam))))) ;;;; Compilation ;;; The compilation phase wraps everything else up into a sane UI. (defun compile-query (wam query) - "Compile `query` into a fresh array of bytecode. + "Compile `query` into the query section of the WAM's code store. `query` should be a list of goal terms. - Returns the fresh code array and the permanent variables. + Returns the permanent variables. " (multiple-value-bind (instructions permanent-variables) (precompile-query wam query) (optimize-instructions wam instructions) - (values - (render-query instructions) - permanent-variables))) + (render-query wam instructions) + permanent-variables)) (defun compile-rules (wam rules) "Compile `rules` into the WAM's code store. diff -r 8cd3257c58e3 -r abffacd7848a src/wam/constants.lisp --- a/src/wam/constants.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/src/wam/constants.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -1,6 +1,6 @@ (in-package #:bones.wam) -(define-constant +cell-width+ 16 +(define-constant +cell-width+ 60 :documentation "Number of bits in each cell.") (define-constant +cell-tag-width+ 3 @@ -13,10 +13,10 @@ :documentation "Bitmask for masking the cell type tags.") -(define-constant +code-word-size+ 16 +(define-constant +code-word-size+ 60 :documentation "Size (in bits) of each word in the code store.") -(define-constant +code-limit+ (expt 2 +code-word-size+) +(define-constant +code-limit+ (expt 2 +cell-width+) :documentation "Maximum size of the WAM code store.") (define-constant +code-sentinel+ (1- +code-limit+) @@ -54,6 +54,10 @@ :documentation "The maximum size (in bytes of bytecode) a query may compile to.") +(define-constant +maximum-instruction-size+ 3 + :documentation + "The maximum number of code words an instruction (including opcode) might be.") + (define-constant +stack-limit+ 2048 :documentation "Maximum size of the WAM stack.") diff -r 8cd3257c58e3 -r abffacd7848a src/wam/types.lisp --- a/src/wam/types.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/src/wam/types.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -10,6 +10,10 @@ `(unsigned-byte ,+cell-value-width+)) +(deftype store () + '(simple-array cell (*))) + + (deftype store-index () `(integer 0 ,(1- +store-limit+))) @@ -43,6 +47,15 @@ ;; either an address or the sentinel `(integer 0 ,(1- +code-limit+))) +(deftype generic-code-store () + `(simple-array code-word (*))) + +(deftype query-code-holder () + `(simple-array code-word (,+maximum-query-size+))) + +(deftype instruction-size () + `(integer 1 ,+maximum-instruction-size+)) + (deftype opcode () `(integer 0 ,(1- +number-of-opcodes+))) diff -r 8cd3257c58e3 -r abffacd7848a src/wam/vm.lisp --- a/src/wam/vm.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/src/wam/vm.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -42,13 +42,16 @@ matching-functor-p functors-match-p constants-match-p)) + (defun* bound-reference-p ((wam wam) (address store-index)) + (:returns boolean) "Return whether the cell at `address` is a bound reference." (let ((cell (wam-store-cell wam address))) (and (cell-reference-p cell) (not (= (cell-value cell) address))))) (defun* unbound-reference-p ((wam wam) (address store-index)) + (:returns boolean) "Return whether the cell at `address` is an unbound reference." (let ((cell (wam-store-cell wam address))) (and (cell-reference-p cell) @@ -56,6 +59,7 @@ (defun* matching-functor-p ((cell cell) (functor functor-index)) + (:returns boolean) "Return whether `cell` is a functor cell containing `functor`." (and (cell-functor-p cell) (= (cell-value cell) functor))) @@ -91,6 +95,8 @@ ;;;; "Ancillary" Functions +(declaim (inline deref)) + (defun* backtrack! ((wam wam)) (:returns :void) "Backtrack after a failure. @@ -169,9 +175,10 @@ will be returned. " - (if (bound-reference-p wam address) - (deref wam (cell-value (wam-store-cell wam address))) - address)) + ;; SBCL won't inline recursive functions :( + (while (bound-reference-p wam address) + (setf address (cell-value (wam-store-cell wam address)))) + address) (defun* bind! ((wam wam) (address-1 store-index) (address-2 store-index)) (:returns :void) @@ -315,10 +322,11 @@ make sure it actually does return void. " - `(defun* ,name ,lambda-list - (:returns :void) - ,@body - (values))) + `(progn + (defun* ,name ,lambda-list + (:returns :void) + ,@body + (values)))) (defmacro define-instructions ((local-name stack-name) lambda-list &body body) "Define a local/stack pair of instructions." @@ -484,9 +492,11 @@ ;;;; Control Instructions -(define-instruction %call ((wam wam) (functor functor-index) - &optional (program-counter-increment - (instruction-size +opcode-call+))) +(define-instruction %call + ((wam wam) + (functor functor-index) + &optional ((program-counter-increment instruction-size) + (instruction-size +opcode-call+))) (let ((target (wam-code-label wam functor))) (if target (setf (wam-continuation-pointer wam) ; CP <- next instruction @@ -626,6 +636,7 @@ ;;;; Constant Instructions +(declaim (inline %%match-constant)) (defun* %%match-constant ((wam wam) (constant functor-index) (address store-index)) @@ -725,7 +736,7 @@ (weave vars results))) -(defun run (wam done-thunk) +(defun* run ((wam wam) (done-thunk function)) (with-accessors ((pc wam-program-counter)) wam (let ((code (wam-code wam))) (macrolet ((instruction (inst args) @@ -734,60 +745,60 @@ :with increment-pc = t :while (and (not (wam-fail wam)) ; failure (not (= pc +code-sentinel+))) ; finished - :for opcode = (aref code pc) + :for opcode = (aref code pc) ; todo switch this to wam-code-word... :do (block op (when *step* (dump) ; todo: make this saner (break "About to execute instruction at ~4,'0X" pc)) - (eswitch (opcode) + (ecase opcode ;; Query - (+opcode-put-structure+ (instruction %put-structure 2)) - (+opcode-put-variable-local+ (instruction %put-variable-local 2)) - (+opcode-put-variable-stack+ (instruction %put-variable-stack 2)) - (+opcode-put-value-local+ (instruction %put-value-local 2)) - (+opcode-put-value-stack+ (instruction %put-value-stack 2)) + (#.+opcode-put-structure+ (instruction %put-structure 2)) + (#.+opcode-put-variable-local+ (instruction %put-variable-local 2)) + (#.+opcode-put-variable-stack+ (instruction %put-variable-stack 2)) + (#.+opcode-put-value-local+ (instruction %put-value-local 2)) + (#.+opcode-put-value-stack+ (instruction %put-value-stack 2)) ;; Program - (+opcode-get-structure+ (instruction %get-structure 2)) - (+opcode-get-variable-local+ (instruction %get-variable-local 2)) - (+opcode-get-variable-stack+ (instruction %get-variable-stack 2)) - (+opcode-get-value-local+ (instruction %get-value-local 2)) - (+opcode-get-value-stack+ (instruction %get-value-stack 2)) + (#.+opcode-get-structure+ (instruction %get-structure 2)) + (#.+opcode-get-variable-local+ (instruction %get-variable-local 2)) + (#.+opcode-get-variable-stack+ (instruction %get-variable-stack 2)) + (#.+opcode-get-value-local+ (instruction %get-value-local 2)) + (#.+opcode-get-value-stack+ (instruction %get-value-stack 2)) ;; Subterm - (+opcode-subterm-variable-local+ (instruction %subterm-variable-local 1)) - (+opcode-subterm-variable-stack+ (instruction %subterm-variable-stack 1)) - (+opcode-subterm-value-local+ (instruction %subterm-value-local 1)) - (+opcode-subterm-value-stack+ (instruction %subterm-value-stack 1)) - (+opcode-subterm-void+ (instruction %subterm-void 1)) + (#.+opcode-subterm-variable-local+ (instruction %subterm-variable-local 1)) + (#.+opcode-subterm-variable-stack+ (instruction %subterm-variable-stack 1)) + (#.+opcode-subterm-value-local+ (instruction %subterm-value-local 1)) + (#.+opcode-subterm-value-stack+ (instruction %subterm-value-stack 1)) + (#.+opcode-subterm-void+ (instruction %subterm-void 1)) ;; Constant - (+opcode-put-constant+ (instruction %put-constant 2)) - (+opcode-get-constant+ (instruction %get-constant 2)) - (+opcode-subterm-constant+ (instruction %subterm-constant 1)) + (#.+opcode-put-constant+ (instruction %put-constant 2)) + (#.+opcode-get-constant+ (instruction %get-constant 2)) + (#.+opcode-subterm-constant+ (instruction %subterm-constant 1)) ;; List - (+opcode-put-list+ (instruction %put-list 1)) - (+opcode-get-list+ (instruction %get-list 1)) + (#.+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)) - (+opcode-trust+ (instruction %trust 0)) - (+opcode-cut+ (instruction %cut 0)) + (#.+opcode-try+ (instruction %try 1)) + (#.+opcode-retry+ (instruction %retry 1)) + (#.+opcode-trust+ (instruction %trust 0)) + (#.+opcode-cut+ (instruction %cut 0)) ;; Control - (+opcode-allocate+ (instruction %allocate 1)) + (#.+opcode-allocate+ (instruction %allocate 1)) ;; need to skip the PC increment for PROC/CALL/DEAL/DONE ;; TODO: this is still ugly - (+opcode-deallocate+ + (#.+opcode-deallocate+ (instruction %deallocate 0) (setf increment-pc nil)) - (+opcode-proceed+ + (#.+opcode-proceed+ (instruction %proceed 0) (setf increment-pc nil)) - (+opcode-call+ + (#.+opcode-call+ (instruction %call 1) (setf increment-pc nil)) - (+opcode-dynamic-call+ + (#.+opcode-dynamic-call+ (instruction %dynamic-call 0) (setf increment-pc nil)) - (+opcode-done+ + (#.+opcode-done+ (if (funcall done-thunk) (return-from run) (backtrack! wam)))) @@ -799,14 +810,17 @@ (incf pc (instruction-size opcode))) (setf (wam-backtracked wam) nil increment-pc t) - (when (>= pc (fill-pointer code)) + (when (>= pc (wam-code-pointer wam)) (error "Fell off the end of the program code store.")))))) (values))) -(defun run-query (wam term - &key - (result-function (lambda (results) (declare (ignore results)))) - (status-function (lambda (failp) (declare (ignore failp))))) +(defun* run-query ((wam wam) + term + &key + ((result-function function) + (lambda (results) (declare (ignore results)))) + ((status-function function) + (lambda (failp) (declare (ignore failp))))) "Compile query `term` and run the instructions on the `wam`. Resets the heap, etc before running. @@ -815,15 +829,10 @@ after each instruction. " - (multiple-value-bind (code vars) - (compile-query wam term) + (let ((vars (compile-query wam term))) (wam-reset! wam) - (wam-load-query-code! wam code) (setf (wam-program-counter wam) 0 (wam-continuation-pointer wam) +code-sentinel+) - (when *step* - (format *debug-io* "Built query code:~%") - (dump-code-store wam code)) (run wam (lambda () (funcall result-function (extract-query-results wam vars)))) diff -r 8cd3257c58e3 -r abffacd7848a src/wam/wam.lisp --- a/src/wam/wam.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/src/wam/wam.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -1,5 +1,6 @@ (in-package #:bones.wam) + ;;;; WAM (declaim ;; Inline all these struct accessors, otherwise things get REAL slow. @@ -16,6 +17,7 @@ wam-number-of-arguments wam-subterm wam-program-counter + wam-heap-pointer wam-continuation-pointer wam-environment-pointer wam-backtrack-pointer @@ -23,42 +25,47 @@ wam-heap-backtrack-pointer wam-mode)) + +(defun allocate-wam-code (size) + ;; The WAM bytecode is all stored in this array. The first + ;; `+maximum-query-size+` words are reserved for query bytecode, which will + ;; get loaded in (overwriting the previous query) when making a query. + ;; Everything after that is for the actual database. + (make-array (+ +maximum-query-size+ size) + :initial-element 0 + :element-type 'code-word)) + +(defun allocate-wam-store (size) + ;; The main WAM store contains three separate blocks of values: + ;; + ;; [0, +register-count+) -> the local X_n registers + ;; [+stack-start+, +stack-end+) -> the stack + ;; [+heap-start+, ...) -> the heap + ;; + ;; `+register-count+` and `+stack-start+` are the same number, and + ;; `+stack-end+` and `+heap-start+` are the same number as well. + (make-array (+ +register-count+ + +stack-limit+ + size) + :initial-element (make-cell-null) + :element-type 'cell)) + + (defstruct (wam (:print-function (lambda (wam stream depth) (declare (ignore depth)) (print-unreadable-object (wam stream :type t :identity t) - (format stream "an wam"))))) + (format stream "an wam")))) + (:constructor make-wam%)) (store - ;; The main WAM store contains three separate blocks of values: - ;; - ;; [0, +register-count+) -> the local X_n registers - ;; [+stack-start+, +stack-end+) -> the stack - ;; [+heap-start+, ...) -> the heap - ;; - ;; `+register-count+` and `+stack-start+` are the same number, and - ;; `+stack-end+` and `+heap-start+` are the same number as well. - (make-array (+ +register-count+ ; TODO: make all these configurable per-WAM - +stack-limit+ - 4096) - :fill-pointer (1+ +stack-end+) - :adjustable t - :initial-element (make-cell-null) - :element-type 'cell) - :type (vector cell) + (allocate-wam-store 0) + :type store :read-only t) (code - ;; The WAM bytecode is all stored in this array. The first - ;; `+maximum-query-size+` words are reserved for query bytecode, which will - ;; get loaded in (overwriting the previous query) when making a query. - ;; Everything after that is for the actual database. - (make-array (+ +maximum-query-size+ 1024) - :adjustable t - :fill-pointer +maximum-query-size+ - :initial-element 0 - :element-type 'code-word) - :type (vector code-word) + (allocate-wam-code 0) + :type (simple-array code-word (*)) :read-only t) (code-labels (make-hash-table) @@ -93,15 +100,17 @@ :read-only t) ;; Unique registers - (number-of-arguments 0 :type arity) ; NARGS - (subterm +heap-start+ :type heap-index) ; S - (program-counter 0 :type code-index) ; P - (stack-pointer +stack-start+ :type stack-index) ; SP - (continuation-pointer 0 :type code-index) ; CP - (environment-pointer +stack-start+ :type environment-pointer) ; E - (backtrack-pointer +stack-start+ :type backtrack-pointer) ; B - (cut-pointer +stack-start+ :type backtrack-pointer) ; B0 - (heap-backtrack-pointer +heap-start+ :type heap-index) ; HB + (number-of-arguments 0 :type arity) ; NARGS + (subterm +heap-start+ :type heap-index) ; S + (program-counter 0 :type code-index) ; P + (code-pointer +maximum-query-size+ :type code-index) ; CODE + (heap-pointer (1+ +heap-start+) :type heap-index) ; H + (stack-pointer +stack-start+ :type stack-index) ; SP + (continuation-pointer 0 :type code-index) ; CP + (environment-pointer +stack-start+ :type environment-pointer) ; E + (backtrack-pointer +stack-start+ :type backtrack-pointer) ; B + (cut-pointer +stack-start+ :type backtrack-pointer) ; B0 + (heap-backtrack-pointer +heap-start+ :type heap-index) ; HB ;; Other global "registers" (fail nil :type boolean) @@ -109,6 +118,13 @@ (mode nil :type (or null (member :read :write)))) +(defun* make-wam (&key (store-size (megabytes 10)) + (code-size (megabytes 1))) + (:returns wam) + (make-wam% :code (allocate-wam-code code-size) + :store (allocate-wam-store store-size))) + + ;;;; Store (declaim (inline wam-store-cell (setf wam-store-cell))) (defun* wam-store-cell ((wam wam) (address store-index)) @@ -121,7 +137,9 @@ " (aref (wam-store wam) address)) -(defun (setf wam-store-cell) (new-value wam address) +(defun* (setf wam-store-cell) ((new-value cell) + (wam wam) + (address store-index)) (setf (aref (wam-store wam) address) new-value)) @@ -153,18 +171,9 @@ Returns the cell and the address it was pushed to. " - (let ((store (wam-store wam))) - (if (= +store-limit+ (fill-pointer store)) - (error "WAM heap exhausted.") - (values cell (vector-push-extend cell store))))) - -(defun* wam-heap-pointer ((wam wam)) - (:returns heap-index) - "Return the current heap pointer of the WAM." - (fill-pointer (wam-store wam))) - -(defun (setf wam-heap-pointer) (new-value wam) - (setf (fill-pointer (wam-store wam)) new-value)) + (if (>= (wam-heap-pointer wam) +store-limit+) ; todo: respect actual size... + (error "WAM heap exhausted.") + (values cell (array-push cell (wam-store wam) (wam-heap-pointer wam))))) (defun* wam-heap-cell ((wam wam) (address heap-index)) @@ -174,7 +183,9 @@ (error "Cannot read from heap address zero.")) (aref (wam-store wam) address)) -(defun (setf wam-heap-cell) (new-value wam address) +(defun* (setf wam-heap-cell) ((new-value cell) + (wam wam) + (address heap-index)) (when (wam-heap-pointer-unset-p wam address) (error "Cannot write to heap address zero.")) (setf (aref (wam-store wam) address) new-value)) @@ -186,7 +197,8 @@ "Return the current trail pointer of the WAM." (fill-pointer (wam-trail wam))) -(defun (setf wam-trail-pointer) (new-value wam) +(defun* (setf wam-trail-pointer) ((new-value trail-index) + (wam wam)) (setf (fill-pointer (wam-trail wam)) new-value)) @@ -214,7 +226,9 @@ "Return the element (a heap index) in the WAM trail at `address`." (aref (wam-trail wam) address)) -(defun (setf wam-trail-value) (new-value wam address) +(defun* (setf wam-trail-value) ((new-value store-index) + (wam wam) + (address trail-index)) (setf (aref (wam-trail wam) address) new-value)) @@ -262,7 +276,9 @@ (assert-inside-stack wam address) (aref (wam-store wam) address)) -(defun (setf wam-stack-word) (new-value wam address) +(defun* (setf wam-stack-word) ((new-value stack-word) + (wam wam) + (address stack-index)) (assert-inside-stack wam address) (setf (aref (wam-store wam) address) new-value)) @@ -346,11 +362,11 @@ (:returns cell) (wam-stack-word wam (+ 4 n e))) -(defun* (setf wam-stack-frame-arg) - ((new-value cell) - (wam wam) - (n register-index) - &optional ((e environment-pointer) (wam-environment-pointer wam))) +(defun* (setf wam-stack-frame-arg) ((new-value cell) + (wam wam) + (n register-index) + &optional ((e environment-pointer) + (wam-environment-pointer wam))) (setf (wam-stack-word wam (+ e 4 n)) new-value)) @@ -457,11 +473,11 @@ (:returns cell) (wam-stack-word wam (+ b 7 n))) -(defun* (setf wam-stack-choice-arg) - ((new-value cell) - (wam wam) - (n arity) - &optional ((b backtrack-pointer) (wam-backtrack-pointer wam))) +(defun* (setf wam-stack-choice-arg) ((new-value cell) + (wam wam) + (n arity) + &optional ((b backtrack-pointer) + (wam-backtrack-pointer wam))) (setf (wam-stack-word wam (+ b 7 n)) new-value)) @@ -500,8 +516,7 @@ ;;;; Resetting (defun* wam-truncate-heap! ((wam wam)) - (setf (fill-pointer (wam-store wam)) - (1+ +heap-start+))) + (setf (wam-heap-pointer wam) (1+ +heap-start+))) (defun* wam-truncate-trail! ((wam wam)) (setf (fill-pointer (wam-trail wam)) 0)) @@ -541,74 +556,25 @@ :adjustable nil :element-type 'code-word)) - -(defun* wam-code-word ((wam wam) (address code-index)) - (:returns code-word) - "Return the word at the given address in the code store." - (aref (wam-code wam) address)) - -(defun (setf wam-code-word) (word wam address) - (setf (aref (wam-code wam) address) word)) - - -(defun* wam-code-instruction ((wam wam) (address code-index)) - "Return the full instruction at the given address in the code store." - (retrieve-instruction (wam-code wam) address)) - - -(defun* code-push-word! ((store (array code-word)) - (word code-word)) - "Push the given word into the code store and return its new address." - (:returns code-index) - (vector-push-extend word store)) - -(defun* code-push-instruction! ((store (array code-word)) - (opcode opcode) - (arguments list)) - "Push the given instruction into the code store and return its new address. - - The address will be the address of the start of the instruction (i.e. the - address of the opcode). - - `arguments` should be a list of `code-word`s. - - " - (:returns code-index) - (assert (= (length arguments) - (1- (instruction-size opcode))) - (arguments) - "Cannot push opcode ~A with ~D arguments ~S, it requires exactly ~D." - (opcode-name opcode) - (length arguments) - arguments - (1- (instruction-size opcode))) - (prog1 - (code-push-word! store opcode) - (dolist (arg arguments) - (code-push-word! store arg)))) - - (defun* wam-code-label ((wam wam) (functor functor-index)) (:returns (or null code-index)) (gethash functor (wam-code-labels wam))) -(defun (setf wam-code-label) (new-value wam functor arity) +(defun* (setf wam-code-label) ((new-value code-index) + (wam wam) + (functor symbol) + (arity arity)) ;; Note that this takes a functor/arity and not a cons. (setf (gethash (wam-ensure-functor-index wam (cons functor arity)) (wam-code-labels wam)) new-value)) -(defun* wam-load-query-code! ((wam wam) query-code) +(defun* wam-load-query-code! ((wam wam) + (query-code query-code-holder)) (:returns :void) - (when (> (length query-code) +maximum-query-size+) - (error "WAM query store exhausted.")) - ;; TODO: there must be a better way to do this - (loop :for word :across query-code - :for addr :from 0 - :do (setf (aref (wam-code wam) addr) - word)) + (setf (subseq (wam-code wam) 0) query-code) (values)) @@ -658,7 +624,7 @@ "Cannot push logic frame unless the logic stack is closed.") (let ((frame (wam-logic-pool-request wam))) (setf (logic-frame-start frame) - (fill-pointer (wam-code wam))) + (wam-code-pointer wam)) (push frame (wam-logic-stack wam))) (values)) @@ -670,7 +636,7 @@ (assert (logic-frame-final (first logic-stack)) () "Cannot pop unfinalized logic frame.") (let ((frame (pop logic-stack))) - (setf (fill-pointer (wam-code wam)) + (setf (wam-code-pointer wam) (logic-frame-start frame)) (loop :for label :being :the hash-keys :of (logic-frame-predicates frame) :do (remhash label (wam-code-labels wam))) @@ -780,7 +746,9 @@ "Return the value stored in the WAM local register with the given index." (aref (wam-store wam) register)) -(defun (setf wam-local-register) (new-value wam register) +(defun* (setf wam-local-register) ((new-value cell) + (wam wam) + (register register-index)) (setf (aref (wam-store wam) register) new-value)) @@ -789,7 +757,9 @@ "Return the value stored in the WAM stack register with the given index." (wam-stack-frame-arg wam register)) -(defun (setf wam-stack-register) (new-value wam register) +(defun* (setf wam-stack-register) ((new-value cell) + (wam wam) + (register register-index)) (setf (wam-stack-frame-arg wam register) new-value)) diff -r 8cd3257c58e3 -r abffacd7848a test/run.lisp --- a/test/run.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/test/run.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -1,4 +1,8 @@ -(let ((*standard-output* (make-broadcast-stream))) +(declaim (optimize (debug 3) (safety 3) (speed 0))) + +(let ((*standard-output* (make-broadcast-stream)) + (*error-output* (make-broadcast-stream))) + (asdf:load-system 'bones :force t) (ql:quickload "bones-test")) diff -r 8cd3257c58e3 -r abffacd7848a test/wam.lisp --- a/test/wam.lisp Sun Jul 10 14:28:48 2016 +0000 +++ b/test/wam.lisp Mon Jul 11 16:26:05 2016 +0000 @@ -443,3 +443,8 @@ (should-return ((foo (s ?x ?y ?z)) (?x a ?y b ?z c))))) + +(test dump + (is (not (string= "" + (with-output-to-string (*standard-output*) + (dump-wam-full *test-database*))))))