# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# 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*))))))