# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1468246514 0
# Node ID 23d4dc2900a1f4329191f5637a3bd46077c54f30
# Parent  7bd5fdb2151d8a0fb295eb00fc6fb14d1ca0a976
Refactor the code store to use a simple-array

diff -r 7bd5fdb2151d -r 23d4dc2900a1 package-test.lisp
--- 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)
diff -r 7bd5fdb2151d -r 23d4dc2900a1 package.lisp
--- 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
diff -r 7bd5fdb2151d -r 23d4dc2900a1 src/utils.lisp
--- 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
diff -r 7bd5fdb2151d -r 23d4dc2900a1 src/wam/compiler.lisp
--- 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.
diff -r 7bd5fdb2151d -r 23d4dc2900a1 src/wam/constants.lisp
--- 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.")
diff -r 7bd5fdb2151d -r 23d4dc2900a1 src/wam/types.lisp
--- 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+)))
diff -r 7bd5fdb2151d -r 23d4dc2900a1 src/wam/vm.lisp
--- 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))))
diff -r 7bd5fdb2151d -r 23d4dc2900a1 src/wam/wam.lisp
--- 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)))
diff -r 7bd5fdb2151d -r 23d4dc2900a1 test/run.lisp
--- 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"))
 
 
diff -r 7bd5fdb2151d -r 23d4dc2900a1 test/wam.lisp
--- 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*))))))