--- a/package-test.lisp Mon Jul 11 13:48:06 2016 +0000
+++ b/package-test.lisp Mon Jul 11 14:15:14 2016 +0000
@@ -29,6 +29,7 @@
#:fact
#:facts
#:call
+ #:dump-wam-full
#:?
#:query
#:query-all)
--- a/package.lisp Mon Jul 11 13:48:06 2016 +0000
+++ b/package.lisp Mon Jul 11 14:15:14 2016 +0000
@@ -9,6 +9,7 @@
#:repeat
#:hex
#:push-if-new
+ #:array-push
#:recursively
#:recur
#:when-let
@@ -28,6 +29,7 @@
(defpackage #:bones.circle
(:use #:cl #:defstar)
(:export
+ #:circle
#:make-circle-with
#:make-empty-circle
#:circle-to-list
--- a/src/utils.lisp Mon Jul 11 13:48:06 2016 +0000
+++ b/src/utils.lisp Mon Jul 11 14:15:14 2016 +0000
@@ -112,6 +112,21 @@
,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
--- a/src/wam/compiler.lisp Mon Jul 11 13:48:06 2016 +0000
+++ b/src/wam/compiler.lisp Mon Jul 11 14:15:14 2016 +0000
@@ -788,7 +788,6 @@
(defclass cut-token (token) ())
-
(defun make-register-token (register)
(make-instance 'register-token :register register))
@@ -1357,6 +1356,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+)
@@ -1402,8 +1429,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)
@@ -1411,29 +1447,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)
@@ -1443,26 +1487,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 Mon Jul 11 13:48:06 2016 +0000
+++ b/src/wam/constants.lisp Mon Jul 11 14:15:14 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 Mon Jul 11 13:48:06 2016 +0000
+++ b/src/wam/types.lisp Mon Jul 11 14:15:14 2016 +0000
@@ -43,6 +43,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 Mon Jul 11 13:48:06 2016 +0000
+++ b/src/wam/vm.lisp Mon Jul 11 14:15:14 2016 +0000
@@ -491,9 +491,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
@@ -737,7 +739,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)
@@ -746,65 +748,65 @@
: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-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))
- (+opcode-set-value-stack+ (instruction %set-value-stack 1))
- (+opcode-set-void+ (instruction %set-void 1))
- (+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-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))
+ (#.+opcode-set-value-stack+ (instruction %set-value-stack 1))
+ (#.+opcode-set-void+ (instruction %set-void 1))
+ (#.+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-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))
- (+opcode-unify-value-stack+ (instruction %unify-value-stack 1))
- (+opcode-unify-void+ (instruction %unify-void 1))
- (+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-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))
+ (#.+opcode-unify-value-stack+ (instruction %unify-value-stack 1))
+ (#.+opcode-unify-void+ (instruction %unify-void 1))
+ (#.+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))
;; Constant
- (+opcode-put-constant+ (instruction %put-constant 2))
- (+opcode-get-constant+ (instruction %get-constant 2))
- (+opcode-set-constant+ (instruction %set-constant 1))
- (+opcode-unify-constant+ (instruction %unify-constant 1))
+ (#.+opcode-put-constant+ (instruction %put-constant 2))
+ (#.+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))
+ (#.+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))))
@@ -816,14 +818,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.
@@ -832,15 +837,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 Mon Jul 11 13:48:06 2016 +0000
+++ b/src/wam/wam.lisp Mon Jul 11 14:15:14 2016 +0000
@@ -24,13 +24,25 @@
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))
+
+
(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:
;;
@@ -50,16 +62,8 @@
:type (vector cell)
: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)
@@ -94,15 +98,16 @@
: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
+ (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)
@@ -110,6 +115,11 @@
(mode nil :type (or null (member :read :write))))
+(defun* make-wam (&key (code-size (* 1024 1024)))
+ (:returns wam)
+ (make-wam% :code (allocate-wam-code code-size)))
+
+
;;;; Store
(declaim (inline wam-store-cell (setf wam-store-cell)))
(defun* wam-store-cell ((wam wam) (address store-index))
@@ -552,55 +562,6 @@
: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 code-word)
- (wam wam)
- (address code-index))
- (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))
@@ -616,15 +577,10 @@
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))
@@ -674,7 +630,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))
@@ -686,7 +642,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)))
--- a/test/run.lisp Mon Jul 11 13:48:06 2016 +0000
+++ b/test/run.lisp Mon Jul 11 14:15:14 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 Mon Jul 11 13:48:06 2016 +0000
+++ b/test/wam.lisp Mon Jul 11 14:15:14 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*))))))