--- 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*)))
--- 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)
--- 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
--- 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))))))
--- 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)
--- 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.
--- 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.")
--- 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+)))
--- 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))))
--- 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))
--- 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"))
--- 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*))))))