ce87039ad178

Make L2 work properly

This changes a lot of things.

First, we split apart all the register-using opcodes into local and stack
variants, and tear out the register designator stuff.  This is ugly, but will be
way faster because the check doesn't need to happen at runtime any more.  It's
made slightly less ugly with a real nasty macro.

We also change how the head and first body term in clauses interact.  It turns
out the head needs to respect the arity of the first body clause (if it's
larger), and the two clauses need to share local variable register assignments.
Apparently when HAK says "compiled as one unit" in the book he means this.
Would have been nice if he could have explained that, or at least showed an
example that makes use of it so I have a chance of noticing it.

Still to do before we move on to L3:

* Add a few comments to document the stuff added in this commit.
* Rework the query code store to fall at the beginning of the `CODE` section so
  we can just have one program counter and interpreter function to rule them
  all.
* Consider figuring out the answer extraction process (we basically need to
  modify the query compiler to treat all variables as permanent, and keep that
  mapping so we can extract them from the stack at the very end).
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Sun, 17 Apr 2016 21:36:15 +0000
parents 15db57524dd3
children 902d171a1a85
branches/tags (none)
files .lispwords src/wam/bytecode.lisp src/wam/compiler.lisp src/wam/constants.lisp src/wam/dump.lisp src/wam/interpreter.lisp src/wam/types.lisp src/wam/ui.lisp src/wam/wam.lisp

Changes

--- a/.lispwords	Sat Apr 16 13:50:36 2016 +0000
+++ b/.lispwords	Sun Apr 17 21:36:15 2016 +0000
@@ -1,2 +1,3 @@
 (2 code-push-instruction!)
 (1 repeat)
+(2 define-instruction define-instructions)
--- a/src/wam/bytecode.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/bytecode.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -9,17 +9,27 @@
 
   "
   (eswitch (opcode)
-    (+opcode-get-structure+ 3)
-    (+opcode-unify-variable+ 2)
-    (+opcode-unify-value+ 2)
-    (+opcode-get-variable+ 3)
-    (+opcode-get-value+ 3)
+    (+opcode-get-structure-local+ 3)
+    (+opcode-get-structure-stack+ 3)
+    (+opcode-unify-variable-local+ 2)
+    (+opcode-unify-variable-stack+ 2)
+    (+opcode-unify-value-local+ 2)
+    (+opcode-unify-value-stack+ 2)
+    (+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-set-variable+ 2)
-    (+opcode-set-value+ 2)
-    (+opcode-put-variable+ 3)
-    (+opcode-put-value+ 3)
+    (+opcode-put-structure-local+ 3)
+    (+opcode-put-structure-stack+ 3)
+    (+opcode-set-variable-local+ 2)
+    (+opcode-set-variable-stack+ 2)
+    (+opcode-set-value-local+ 2)
+    (+opcode-set-value-stack+ 2)
+    (+opcode-put-variable-local+ 3)
+    (+opcode-put-variable-stack+ 3)
+    (+opcode-put-value-local+ 3)
+    (+opcode-put-value-stack+ 3)
 
     (+opcode-call+ 2)
     (+opcode-proceed+ 1)
@@ -30,17 +40,27 @@
 (defun* opcode-name ((opcode opcode))
   (:returns string)
   (eswitch (opcode)
-    (+opcode-get-structure+ "GET-STRUCTURE")
-    (+opcode-unify-variable+ "UNIFY-VARIABLE")
-    (+opcode-unify-value+ "UNIFY-VALUE")
-    (+opcode-get-variable+ "GET-VARIABLE")
-    (+opcode-get-value+ "GET-VALUE")
+    (+opcode-get-structure-local+ "GET-STRUCTURE")
+    (+opcode-get-structure-stack+ "GET-STRUCTURE")
+    (+opcode-unify-variable-local+ "UNIFY-VARIABLE")
+    (+opcode-unify-variable-stack+ "UNIFY-VARIABLE")
+    (+opcode-unify-value-local+ "UNIFY-VALUE")
+    (+opcode-unify-value-stack+ "UNIFY-VALUE")
+    (+opcode-get-variable-local+ "GET-VARIABLE")
+    (+opcode-get-variable-stack+ "GET-VARIABLE")
+    (+opcode-get-value-local+ "GET-VALUE")
+    (+opcode-get-value-stack+ "GET-VALUE")
 
-    (+opcode-put-structure+ "PUT-STRUCTURE")
-    (+opcode-set-variable+ "SET-VARIABLE")
-    (+opcode-set-value+ "SET-VALUE")
-    (+opcode-put-variable+ "PUT-VARIABLE")
-    (+opcode-put-value+ "PUT-VALUE")
+    (+opcode-put-structure-local+ "PUT-STRUCTURE")
+    (+opcode-put-structure-stack+ "PUT-STRUCTURE")
+    (+opcode-set-variable-local+ "SET-VARIABLE")
+    (+opcode-set-variable-stack+ "SET-VARIABLE")
+    (+opcode-set-value-local+ "SET-VALUE")
+    (+opcode-set-value-stack+ "SET-VALUE")
+    (+opcode-put-variable-local+ "PUT-VARIABLE")
+    (+opcode-put-variable-stack+ "PUT-VARIABLE")
+    (+opcode-put-value-local+ "PUT-VALUE")
+    (+opcode-put-value-stack+ "PUT-VALUE")
 
     (+opcode-call+ "CALL")
     (+opcode-proceed+ "PROCEED")
@@ -50,76 +70,30 @@
 (defun* opcode-short-name ((opcode opcode))
   (:returns string)
   (eswitch (opcode)
-    (+opcode-get-structure+ "GETS")
-    (+opcode-unify-variable+ "UVAR")
-    (+opcode-unify-value+ "UVLU")
-    (+opcode-get-variable+ "GVAR")
-    (+opcode-get-value+ "GVLU")
+    (+opcode-get-structure-local+ "GETS")
+    (+opcode-get-structure-stack+ "GETS")
+    (+opcode-unify-variable-local+ "UVAR")
+    (+opcode-unify-variable-stack+ "UVAR")
+    (+opcode-unify-value-local+ "UVLU")
+    (+opcode-unify-value-stack+ "UVLU")
+    (+opcode-get-variable-local+ "GVAR")
+    (+opcode-get-variable-stack+ "GVAR")
+    (+opcode-get-value-local+ "GVLU")
+    (+opcode-get-value-stack+ "GVLU")
 
-    (+opcode-put-structure+ "PUTS")
-    (+opcode-set-variable+ "SVAR")
-    (+opcode-set-value+ "SVLU")
-    (+opcode-put-variable+ "PVAR")
-    (+opcode-put-value+ "PVLU")
+    (+opcode-put-structure-local+ "PUTS")
+    (+opcode-put-structure-stack+ "PUTS")
+    (+opcode-set-variable-local+ "SVAR")
+    (+opcode-set-variable-stack+ "SVAR")
+    (+opcode-set-value-local+ "SVLU")
+    (+opcode-set-value-stack+ "SVLU")
+    (+opcode-put-variable-local+ "PVAR")
+    (+opcode-put-variable-stack+ "PVAR")
+    (+opcode-put-value-local+ "PVLU")
+    (+opcode-put-value-stack+ "PVLU")
 
     (+opcode-call+ "CALL")
     (+opcode-proceed+ "PROC")
     (+opcode-allocate+ "ALOC")
     (+opcode-deallocate+ "DEAL")))
 
-
-;;;; Register Designators
-;;; A register designator is a number that specifies a particular register.
-;;;
-;;; The register might be a local register (A_n or X_n in WAMspeak) for holding
-;;; temporary things or a stack register (Y_n) for holding permanent variables.
-;;;
-;;; Internally register designators are implemented as a bitmasked value/tag:
-;;;
-;;;    value          tag bit
-;;;    rrrrrrrrrrrrrrrT
-;;;
-;;; But you should probably just use this interface to interact with them.
-
-(defun* register-designator-tag ((register-designator register-designator))
-  (:returns register-designator-tag)
-  (logand register-designator +register-designator-tag-bitmask+))
-
-(defun* register-designator-value ((register-designator register-designator))
-  (:returns register-index)
-  (ash register-designator -1))
-
-
-(defun* register-designator-local-p ((register-designator register-designator))
-  (:returns boolean)
-  (= +tag-local-register+
-     (register-designator-tag register-designator)))
-
-(defun* register-designator-stack-p ((register-designator register-designator))
-  (:returns boolean)
-  (= +tag-stack-register+
-     (register-designator-tag register-designator)))
-
-
-(defun* make-register-designator ((register register-index)
-                                  (tag register-designator-tag))
-  (:returns register-designator)
-  (logior (ash register 1)
-          tag))
-
-(defun* make-local-register-designator ((register register-index))
-  (:returns register-designator)
-  (make-register-designator register +tag-local-register+))
-
-(defun* make-stack-register-designator ((register register-index))
-  (:returns register-designator)
-  (make-register-designator register +tag-stack-register+))
-
-(defun* register-designator-to-string ((register-designator register-designator))
-  (format nil
-          (if (register-designator-local-p register-designator)
-            ;; Unfortunately we've lost the X/A distinction by this point.
-            "X~D"
-            "Y~D")
-          (+ (register-designator-value register-designator)
-             (if *off-by-one* 1 0))))
--- a/src/wam/compiler.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/compiler.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -35,13 +35,6 @@
   (make-register :permanent number))
 
 
-(defun* register-to-designator ((register register))
-  (:returns register-designator)
-  (with-slots (type number) register
-    (if (eql type :permanent)
-      (make-stack-register-designator number)
-      (make-local-register-designator number))))
-
 (defun* register-to-string ((register register))
   (format nil "~A~D"
           (ecase (register-type register)
@@ -56,6 +49,13 @@
     (format stream (register-to-string object))))
 
 
+(defun* register-temporary-p ((register register))
+  (member (register-type register) '(:argument :local)))
+
+(defun* register-permanent-p ((register register))
+  (eql (register-type register) :permanent))
+
+
 (defun* register= ((r1 register) (r2 register))
   (:returns boolean)
   (ensure-boolean
@@ -71,8 +71,8 @@
                   (register-type r2))
              ;; local and argument registers are actually the same register,
              ;; just named differently
-             (and (member (register-type r1) '(:local :argument))
-                  (member (register-type r2) '(:local :argument))))
+             (and (register-temporary-p r1)
+                  (register-temporary-p r2)))
          (= (register-number r1)
             (register-number r2)))))
 
@@ -161,7 +161,9 @@
 ;;;   A1 -> q(A1, X3)
 ;;;   X2 -> B
 
-(defun parse-term (term permanent-variables)
+(defun parse-term (term permanent-variables
+                   ;; JESUS TAKE THE WHEEL
+                   &optional reserved-variables reserved-arity)
   "Parse a term into a series of register assignments.
 
   Returns:
@@ -171,25 +173,15 @@
     * The root functor's arity
 
   "
-  ;; A term is a Lispy representation of the raw Prolog.  A register assignment
-  ;; is a cons of (register . assigned-to), e.g.:
-  ;;
-  ;;   (p :foo (f :foo :bar))
-  ;;   ->
-  ;;   (0 . 2)       ; A0 = X2
-  ;;   (1 . 4)       ; A1 = X3
-  ;;   (2 . :foo)    ; X2 = Foo
-  ;;   (3 . (f 2 4)) ; X3 = f(X2, X4)
-  ;;   (4 . :bar)    ; X4 = Bar
   (let* ((predicate (first term))
          (arguments (rest term))
          (arity (length arguments))
          ;; Preallocate enough registers for all of the arguments.  We'll fill
          ;; them in later.
          (local-registers (make-array 64
-                                      :fill-pointer arity
-                                      :adjustable t
-                                      :initial-element nil))
+                            :fill-pointer (or reserved-arity arity)
+                            :adjustable t
+                            :initial-element nil))
          ;; We essentially "preallocate" all the permanent variables up front
          ;; because we need them to always be in the same stack registers across
          ;; all the terms of our clause.
@@ -197,7 +189,10 @@
          ;; The ones that won't get used in this term will end up getting
          ;; flattened away anyway.
          (stack-registers (make-array (length permanent-variables)
-                                      :initial-contents permanent-variables)))
+                            :initial-contents permanent-variables)))
+    ;; TODO: document this clusterfuck
+    (loop :for variable :in reserved-variables :do
+          (vector-push-extend variable local-registers))
     (labels
         ((find-variable (var)
            (let ((r (position var local-registers))
@@ -234,7 +229,7 @@
          (make-assignment-list (registers register-maker)
            (loop :for i :from 0
                  :for contents :across registers
-                 :collect
+                 :when contents :collect ; don't include unused reserved regs
                  (cons (funcall register-maker i arity)
                        contents))))
       ;; Arguments are handled specially.  We parse the children as normal,
@@ -356,23 +351,34 @@
     assignments))
 
 
-(defun tokenize-term (term permanent-variables flattener)
+(defun tokenize-term
+    (term permanent-variables reserved-variables reserved-arity flattener)
   (multiple-value-bind (assignments functor arity)
-      (parse-term term permanent-variables)
+      (parse-term term permanent-variables reserved-variables reserved-arity)
     (values (->> assignments
               (funcall flattener)
               tokenize-assignments)
             functor
             arity)))
 
-(defun tokenize-program-term (term permanent-variables)
+(defun tokenize-program-term
+    (term permanent-variables reserved-variables reserved-arity)
   "Tokenize `term` as a program term, returning its tokens, functor, and arity."
-  (tokenize-term term permanent-variables #'flatten-program))
+  (tokenize-term term
+                 permanent-variables
+                 reserved-variables
+                 reserved-arity
+                 #'flatten-program))
 
-(defun tokenize-query-term (term permanent-variables)
+(defun tokenize-query-term
+    (term permanent-variables &optional reserved-variables reserved-arity)
   "Tokenize `term` as a query term, returning its stream of tokens."
   (multiple-value-bind (tokens functor arity)
-      (tokenize-term term permanent-variables #'flatten-query)
+      (tokenize-term term
+                     permanent-variables
+                     reserved-variables
+                     reserved-arity
+                     #'flatten-query)
     ;; We need to shove a CALL token onto the end.
     (append tokens `((:call ,functor ,arity)))))
 
@@ -394,6 +400,35 @@
 ;;;   (#'%set-value 1)
 ;;;   (#'%set-value 2)
 
+(defun find-opcode (opcode newp mode &optional register)
+  (flet ((find-variant (register)
+           (when register
+             (if (register-temporary-p register)
+               :local
+               :stack))))
+    (eswitch ((list opcode newp mode (find-variant register)) :test #'equal)
+      ('(:argument t   :program :local) +opcode-get-variable-local+)
+      ('(:argument t   :program :stack) +opcode-get-variable-stack+)
+      ('(:argument t   :query   :local) +opcode-put-variable-local+)
+      ('(:argument t   :query   :stack) +opcode-put-variable-stack+)
+      ('(:argument nil :program :local) +opcode-get-value-local+)
+      ('(:argument nil :program :stack) +opcode-get-value-stack+)
+      ('(:argument nil :query   :local) +opcode-put-value-local+)
+      ('(:argument nil :query   :stack) +opcode-put-value-stack+)
+      ('(:structure nil :program :local) +opcode-get-structure-local+)
+      ('(:structure nil :program :stack) +opcode-get-structure-stack+)
+      ('(:structure nil :query   :local) +opcode-put-structure-local+)
+      ('(:structure nil :query   :stack) +opcode-put-structure-stack+)
+      ('(:register t   :program :local) +opcode-unify-variable-local+)
+      ('(:register t   :program :stack) +opcode-unify-variable-stack+)
+      ('(:register t   :query   :local) +opcode-set-variable-local+)
+      ('(:register t   :query   :stack) +opcode-set-variable-stack+)
+      ('(:register nil :program :local) +opcode-unify-value-local+)
+      ('(:register nil :program :stack) +opcode-unify-value-stack+)
+      ('(:register nil :query   :local) +opcode-set-value-local+)
+      ('(:register nil :query   :stack) +opcode-set-value-stack+))))
+
+
 (defun compile-tokens (wam head-tokens body-tokens store)
   "Generate a series of machine instructions from a stream of head and body
   tokens.
@@ -413,25 +448,18 @@
     (labels
         ((handle-argument (argument-register source-register)
            ;; OP X_n A_i
-           (code-push-instruction! store
-               (if (push-if-new source-register seen :test #'register=)
-                 (ecase mode
-                   (:program +opcode-get-variable+)
-                   (:query +opcode-put-variable+))
-                 (ecase mode
-                   (:program +opcode-get-value+)
-                   (:query +opcode-put-value+)))
-             (register-to-designator source-register)
-             (register-to-designator argument-register)))
+           (let ((newp (push-if-new source-register seen :test #'register=)))
+             (code-push-instruction! store
+                 (find-opcode :argument newp mode source-register)
+               (register-number source-register)
+               (register-number argument-register))))
          (handle-structure (destination-register functor arity)
            ;; OP functor reg
            (push destination-register seen)
            (code-push-instruction! store
-               (ecase mode
-                 (:program +opcode-get-structure+)
-                 (:query +opcode-put-structure+))
+               (find-opcode :structure nil mode destination-register)
              (wam-ensure-functor-index wam (cons functor arity))
-             (register-to-designator destination-register)))
+             (register-number destination-register)))
          (handle-call (functor arity)
            ;; CALL functor
            (code-push-instruction! store
@@ -439,15 +467,10 @@
              (wam-ensure-functor-index wam (cons functor arity))))
          (handle-register (register)
            ;; OP reg
-           (code-push-instruction! store
-               (if (push-if-new register seen :test #'register=)
-                 (ecase mode
-                   (:program +opcode-unify-variable+)
-                   (:query +opcode-set-variable+))
-                 (ecase mode
-                   (:program +opcode-unify-value+)
-                   (:query +opcode-set-value+)))
-             (register-to-designator register)))
+           (let ((newp (push-if-new register seen :test #'register=)))
+             (code-push-instruction! store
+                 (find-opcode :register newp mode register)
+               (register-number register))))
          (handle-stream (tokens)
            (loop :for token :in tokens :collect
                  (ematch token
@@ -473,6 +496,16 @@
 
 
 ;;;; UI
+(defun find-shared-variables (terms)
+  "Return a list of all variables shared by two or more terms."
+  (let* ((variables (remove-duplicates (tree-collect #'variable-p terms))))
+    (flet ((permanent-p (variable)
+             "Permanent variables are those contained in more than 1 term."
+             (> (count-if (curry #'tree-member-p variable)
+                          terms)
+                1)))
+      (remove-if-not #'permanent-p variables))))
+
 (defun find-permanent-variables (clause)
   "Return a list of all the 'permanent' variables in `clause`.
 
@@ -480,19 +513,19 @@
   where the head of the clause is considered to be a part of the first goal.
 
   "
-  (if (< (length clause) 2)
+  (if (<= (length clause) 2)
     (list) ; facts and chain rules have no permanent variables at all
     (destructuring-bind (head body-first . body-rest) clause
       ;; the head is treated as part of the first goal for the purposes of
       ;; finding permanent variables
-      (let* ((goals (cons (cons head body-first) body-rest))
-             (variables (remove-duplicates (tree-collect #'variable-p goals))))
-        (flet ((permanent-p (variable)
-                 "Permanent variables are those contained in more than 1 goal."
-                 (> (count-if (curry #'tree-member-p variable)
-                              goals)
-                    1)))
-          (remove-if-not #'permanent-p variables))))))
+      (find-shared-variables (cons (cons head body-first) body-rest)))))
+
+(defun find-head-variables (clause)
+  (if (<= (length clause) 1)
+    (list)
+    (destructuring-bind (head body-first . body-rest) clause
+      (declare (ignore body-rest))
+      (find-shared-variables (list head body-first)))))
 
 
 (defun mark-label (wam functor arity store)
@@ -504,9 +537,9 @@
 
 (defun make-query-code-store ()
   (make-array 64
-              :fill-pointer 0
-              :adjustable t
-              :element-type 'code-word))
+    :fill-pointer 0
+    :adjustable t
+    :element-type 'code-word))
 
 
 (defun compile-clause (wam store head body)
@@ -518,15 +551,31 @@
   "
   (let* ((permanent-variables
            (find-permanent-variables (cons head body)))
+         (head-variables
+           (set-difference (find-head-variables (cons head body))
+                           permanent-variables))
+         (head-arity
+           (max (1- (length head))
+                (1- (length (car body)))))
          (head-tokens
            (when head
              (multiple-value-bind (tokens functor arity)
-                 (tokenize-program-term head permanent-variables)
+                 (tokenize-program-term head
+                                        permanent-variables
+                                        head-variables
+                                        head-arity)
                (mark-label wam functor arity store) ; TODO: this is ugly
                tokens)))
          (body-tokens
-           (loop :for term :in body :append
-                 (tokenize-query-term term permanent-variables))))
+           (when body
+             (append
+               (tokenize-query-term (first body)
+                                    permanent-variables
+                                    head-variables
+                                    head-arity)
+               (loop :for term :in (rest body) :append
+                     (tokenize-query-term term
+                                          permanent-variables))))))
     (flet ((compile% () (compile-tokens wam head-tokens body-tokens store)))
       ;; We need to compile facts and rules differently.  Facts end with
       ;; a PROCEED and rules are wrapped in ALOC/DEAL.
--- a/src/wam/constants.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/constants.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -66,9 +66,6 @@
 (define-constant +tag-stack-register+ #b1
   :documentation "A stack register (Y_n).")
 
-(define-constant +register-designator-tag-bitmask+ #b1
-  :documentation "Bitmask for the type tag of a register designator.")
-
 
 (define-constant +stack-word-size+ 16
   :documentation "Size (in bits) of each word in WAM stack.")
@@ -88,26 +85,36 @@
 
 ;;;; Opcodes
 ;;; Program
-(define-constant +opcode-get-structure+ 1)
-(define-constant +opcode-unify-variable+ 2)
-(define-constant +opcode-unify-value+ 3)
-(define-constant +opcode-get-variable+ 4)
-(define-constant +opcode-get-value+ 5)
+(define-constant +opcode-get-structure-local+ 0)
+(define-constant +opcode-get-structure-stack+ 1)
+(define-constant +opcode-unify-variable-local+ 2)
+(define-constant +opcode-unify-variable-stack+ 3)
+(define-constant +opcode-unify-value-local+ 4)
+(define-constant +opcode-unify-value-stack+ 5)
+(define-constant +opcode-get-variable-local+ 6)
+(define-constant +opcode-get-variable-stack+ 7)
+(define-constant +opcode-get-value-local+ 8)
+(define-constant +opcode-get-value-stack+ 9)
 
 
 ;;; Query
-(define-constant +opcode-put-structure+ 6)
-(define-constant +opcode-set-variable+ 7)
-(define-constant +opcode-set-value+ 8)
-(define-constant +opcode-put-variable+ 9)
-(define-constant +opcode-put-value+ 10)
+(define-constant +opcode-put-structure-local+ 10)
+(define-constant +opcode-put-structure-stack+ 11)
+(define-constant +opcode-set-variable-local+ 12)
+(define-constant +opcode-set-variable-stack+ 13)
+(define-constant +opcode-set-value-local+ 14)
+(define-constant +opcode-set-value-stack+ 15)
+(define-constant +opcode-put-variable-local+ 16)
+(define-constant +opcode-put-variable-stack+ 17)
+(define-constant +opcode-put-value-local+ 18)
+(define-constant +opcode-put-value-stack+ 19)
 
 
 ;;; Control
-(define-constant +opcode-call+ 11)
-(define-constant +opcode-proceed+ 12)
-(define-constant +opcode-allocate+ 13)
-(define-constant +opcode-deallocate+ 14)
+(define-constant +opcode-call+ 20)
+(define-constant +opcode-proceed+ 21)
+(define-constant +opcode-allocate+ 22)
+(define-constant +opcode-deallocate+ 23)
 
 
 ;;;; Debug Config
--- a/src/wam/dump.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/dump.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -117,52 +117,98 @@
           (pretty-arguments arguments)))
 
 
-(defmethod instruction-details ((opcode (eql +opcode-set-variable+)) arguments functor-list)
-  (format nil "SVAR~A      ; ~A <- new unbound REF"
+(defmethod instruction-details ((opcode (eql +opcode-set-variable-local+)) arguments functor-list)
+  (format nil "SVAR~A      ; X~A <- new unbound REF"
           (pretty-arguments arguments)
-          (register-designator-to-string (first arguments))))
+          (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-set-variable-stack+)) arguments functor-list)
+  (format nil "SVAR~A      ; Y~A <- new unbound REF"
+          (pretty-arguments arguments)
+          (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list)
-  (format nil "SVLU~A      ; new REF to ~A"
+(defmethod instruction-details ((opcode (eql +opcode-set-value-local+)) arguments functor-list)
+  (format nil "SVLU~A      ; new REF to X~A"
           (pretty-arguments arguments)
-          (register-designator-to-string (first arguments))))
+          (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
-  (format nil "GETS~A ; ~A = ~A"
+(defmethod instruction-details ((opcode (eql +opcode-set-value-stack+)) arguments functor-list)
+  (format nil "SVLU~A      ; new REF to Y~A"
           (pretty-arguments arguments)
-          (register-designator-to-string (second arguments))
+          (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-get-structure-local+)) arguments functor-list)
+  (format nil "GETS~A ; X~A = ~A"
+          (pretty-arguments arguments)
+          (second arguments)
           (pretty-functor (first arguments) functor-list)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
-  (format nil "PUTS~A ; ~A <- new ~A"
+(defmethod instruction-details ((opcode (eql +opcode-get-structure-stack+)) arguments functor-list)
+  (format nil "GETS~A ; Y~A = ~A"
           (pretty-arguments arguments)
-          (register-designator-to-string (second arguments))
+          (second arguments)
+          (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-structure-local+)) arguments functor-list)
+  (format nil "PUTS~A ; X~A <- new ~A"
+          (pretty-arguments arguments)
+          (second arguments)
+          (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-structure-stack+)) arguments functor-list)
+  (format nil "PUTS~A ; Y~A <- new ~A"
+          (pretty-arguments arguments)
+          (second arguments)
           (pretty-functor (first arguments) functor-list)))
 
 
-(defmethod instruction-details ((opcode (eql +opcode-get-variable+)) arguments functor-list)
-  (format nil "GVAR~A ; ~A <- ~A"
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-local+)) arguments functor-list)
+  (format nil "GVAR~A ; X~A <- A~A"
           (pretty-arguments arguments)
-          (register-designator-to-string (first arguments))
-          (register-designator-to-string (second arguments))))
+          (first arguments)
+          (second arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-get-variable-stack+)) arguments functor-list)
+  (format nil "GVAR~A ; Y~A <- A~A"
+          (pretty-arguments arguments)
+          (first arguments)
+          (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-get-value+)) arguments functor-list)
-  (format nil "GVLU~A ; ~A = ~A"
+(defmethod instruction-details ((opcode (eql +opcode-get-value-local+)) arguments functor-list)
+  (format nil "GVLU~A ; X~A = A~A"
           (pretty-arguments arguments)
-          (register-designator-to-string (second arguments))
-          (register-designator-to-string (first arguments))))
+          (first arguments)
+          (second arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-get-value-stack+)) arguments functor-list)
+  (format nil "GVLU~A ; Y~A = A~A"
+          (pretty-arguments arguments)
+          (first arguments)
+          (second arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)
-  (format nil "PVAR~A ; ~A <- ~A <- new unbound REF"
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-local+)) arguments functor-list)
+  (format nil "PVAR~A ; X~A <- A~A <- new unbound REF"
           (pretty-arguments arguments)
-          (register-designator-to-string (second arguments))
-          (register-designator-to-string (first arguments))))
+          (first arguments)
+          (second arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-variable-stack+)) arguments functor-list)
+  (format nil "PVAR~A ; Y~A <- A~A <- new unbound REF"
+          (pretty-arguments arguments)
+          (second arguments)
+          (first arguments)))
 
-(defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list)
-  (format nil "PVLU~A ; ~A <- ~A"
+(defmethod instruction-details ((opcode (eql +opcode-put-value-local+)) arguments functor-list)
+  (format nil "PVLU~A ; A~A <- X~A"
           (pretty-arguments arguments)
-          (register-designator-to-string (second arguments))
-          (register-designator-to-string (first arguments))))
+          (second arguments)
+          (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-value-stack+)) arguments functor-list)
+  (format nil "PVLU~A ; A~A <- Y~A"
+          (pretty-arguments arguments)
+          (second arguments)
+          (first arguments)))
 
 
 (defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
@@ -182,7 +228,11 @@
         (when lbl
           (format t ";;;; BEGIN ~A~%"
                   (pretty-functor lbl (wam-functors wam)))))
-      (format t "; ~4,'0X: " addr)
+      (format t ";~A~4,'0X: "
+              (if (= (wam-program-counter wam) addr)
+                ">>"
+                "  ")
+              addr)
       (let ((instruction (retrieve-instruction code-store addr)))
         (format t "~A~%" (instruction-details (aref instruction 0)
                                               (rest (coerce instruction 'list))
--- a/src/wam/interpreter.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/interpreter.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -142,54 +142,73 @@
                 (fail! wam "Functors don't match in unify!")))))))))
 
 
+;;;; Instruction Definition
+(defmacro define-instruction (name lambda-list &body body)
+  `(defun* ,name ,lambda-list
+     (:returns :void)
+     ,@body
+     (values)))
+
+(defmacro define-instructions ((local-name stack-name) lambda-list &body body)
+  `(progn
+    (macrolet ((%wam-register% (wam register)
+                 `(wam-local-register ,wam ,register)))
+      (define-instruction ,local-name ,lambda-list
+        ,@body))
+    (macrolet ((%wam-register% (wam register)
+                 `(wam-stack-register ,wam ,register)))
+      (define-instruction ,stack-name ,lambda-list
+        ,@body))))
+
+
 ;;;; Query Instructions
-(defun* %put-structure ((wam wam)
-                        (functor functor-index)
-                        (register register-designator))
-  (:returns :void)
+(define-instructions (%put-structure-local %put-structure-stack)
+    ((wam wam)
+     (functor functor-index)
+     (register register-index))
   (->> (push-new-structure! wam)
     (nth-value 1)
-    (setf (wam-register wam register)))
-  (push-new-functor! wam functor)
-  (values))
+    (setf (%wam-register% wam register)))
+  (push-new-functor! wam functor))
 
-(defun* %set-variable ((wam wam) (register register-designator))
-  (:returns :void)
+(define-instructions (%set-variable-local %set-variable-stack)
+    ((wam wam)
+     (register register-index))
   (->> (push-unbound-reference! wam)
     (nth-value 1)
-    (setf (wam-register wam register)))
-  (values))
+    (setf (%wam-register% wam register))))
 
-(defun* %set-value ((wam wam) (register register-designator))
-  (:returns :void)
-  (wam-heap-push! wam (wam-register-cell wam register))
-  (values))
+(define-instructions (%set-value-local %set-value-stack)
+    ((wam wam)
+     (register register-index))
+  (wam-heap-push! wam (->> register
+                        (%wam-register% wam)
+                        (wam-heap-cell wam))))
 
-(defun* %put-variable ((wam wam)
-                       (register register-designator)
-                       (argument register-designator))
-  (:returns :void)
+(define-instructions (%put-variable-local %put-variable-stack)
+    ((wam wam)
+     (register register-index)
+     (argument register-index))
   (->> (push-unbound-reference! wam)
     (nth-value 1)
-    (setf (wam-register wam register))
-    (setf (wam-register wam argument)))
-  (values))
+    (setf (%wam-register% wam register))
+    (setf (wam-local-register wam argument))))
 
-(defun* %put-value ((wam wam)
-                    (register register-designator)
-                    (argument register-designator))
-  (:returns :void)
-  (setf (wam-register wam argument)
-        (wam-register wam register))
-  (values))
+(define-instructions (%put-value-local %put-value-stack)
+    ((wam wam)
+     (register register-index)
+     (argument register-index))
+  (setf (wam-local-register wam argument)
+        (%wam-register% wam register)))
 
 
 ;;;; Program Instructions
-(defun* %get-structure ((wam wam)
-                        (functor functor-index)
-                        (register register-designator))
-  (:returns :void)
-  (let* ((addr (deref wam (wam-register wam register)))
+;; TODO: do we really need both of these variants?
+(define-instructions (%get-structure-local %get-structure-stack)
+    ((wam wam)
+     (functor functor-index)
+     (register register-index))
+  (let* ((addr (deref wam (%wam-register% wam register)))
          (cell (wam-heap-cell wam addr)))
     (cond
       ;; If the register points at a reference cell, we push two new cells onto
@@ -236,51 +255,50 @@
              (setf (wam-mode wam) :read))
            (fail! wam "Functors don't match in get-struct"))))
       (t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A"
-                            (cell-aesthetic cell))))))
-  (values))
+                            (cell-aesthetic cell)))))))
 
-(defun* %unify-variable ((wam wam) (register register-designator))
-  (:returns :void)
+(define-instructions (%unify-variable-local %unify-variable-stack)
+    ((wam wam)
+     (register register-index))
   (ecase (wam-mode wam)
-    (:read (setf (wam-register wam register)
+    (:read (setf (%wam-register% wam register)
                  (wam-s wam)))
     (:write (->> (push-unbound-reference! wam)
               (nth-value 1)
-              (setf (wam-register wam register)))))
-  (incf (wam-s wam))
-  (values))
+              (setf (%wam-register% wam register)))))
+  (incf (wam-s wam)))
 
-(defun* %unify-value ((wam wam) (register register-designator))
-  (:returns :void)
+(define-instructions (%unify-value-local %unify-value-stack)
+    ((wam wam)
+     (register register-index))
   (ecase (wam-mode wam)
     (:read (unify! wam
-                   (wam-register wam register)
+                   (%wam-register% wam register)
                    (wam-s wam)))
-    (:write (wam-heap-push! wam (wam-register-cell wam register))))
-  (incf (wam-s wam))
-  (values))
+    (:write (wam-heap-push! wam
+                            (->> register
+                              (%wam-register% wam)
+                              (wam-heap-cell wam)))))
+  (incf (wam-s wam)))
 
-(defun* %get-variable ((wam wam)
-                       (register register-designator)
-                       (argument register-designator))
-  (:returns :void)
-  (setf (wam-register wam register)
-        (wam-register wam argument))
-  (values))
+(define-instructions (%get-variable-local %get-variable-stack)
+    ((wam wam)
+     (register register-index)
+     (argument register-index))
+  (setf (%wam-register% wam register)
+        (wam-local-register wam argument)))
 
-(defun* %get-value ((wam wam)
-                    (register register-designator)
-                    (argument register-designator))
-  (:returns :void)
+(define-instructions (%get-value-local %get-value-stack)
+    ((wam wam)
+     (register register-index)
+     (argument register-index))
   (unify! wam
-          (wam-register wam register)
-          (wam-register wam argument))
-  (values))
+          (%wam-register% wam register)
+          (wam-local-register wam argument)))
 
 
 ;;;; Control Instructions
-(defun* %call ((wam wam) (functor functor-index))
-  (:returns :void)
+(define-instruction %call ((wam wam) (functor functor-index))
   (let ((target (wam-code-label wam functor)))
     (if target
       (progn
@@ -289,17 +307,13 @@
                  (instruction-size +opcode-call+))
               (wam-program-counter wam) ; PC <- target
               target))
-      (fail! wam "Tried to call unknown procedure.")))
-  (values))
+      (fail! wam "Tried to call unknown procedure."))))
 
-(defun* %proceed ((wam wam))
-  (:returns :void)
+(define-instruction %proceed ((wam wam))
   (setf (wam-program-counter wam) ; P <- CP
-        (wam-continuation-pointer wam))
-  (values))
+        (wam-continuation-pointer wam)))
 
-(defun* %allocate ((wam wam) (n stack-frame-argcount))
-  (:returns :void)
+(define-instruction %allocate ((wam wam) (n stack-frame-argcount))
   (setf (wam-environment-pointer wam) ; E <- new E
         (->> wam
           wam-environment-pointer
@@ -309,8 +323,7 @@
   (wam-stack-push! wam n) ; N
   (wam-stack-extend! wam n)) ; Y_n (TODO: this sucks)
 
-(defun* %deallocate ((wam wam))
-  (:returns :void)
+(define-instruction %deallocate ((wam wam))
   (setf (wam-program-counter wam)
         (wam-stack-frame-cp wam))
   (wam-stack-pop-environment! wam))
@@ -358,41 +371,52 @@
 
 (defun run-program (wam functor &optional (step nil))
   (with-slots (code program-counter fail) wam
-    (setf program-counter (wam-code-label wam functor))
-    (loop
-      :while (and (not fail) ; failure
-                  (not (= program-counter +code-sentinal+))) ; finished
-      :for opcode = (aref code program-counter)
-      :do
-      (block op
-        (when step
-          (break "About to execute instruction at ~4,'0X" program-counter))
-        (eswitch (opcode)
-          ;; Query
-          (+opcode-put-structure+  (instruction-call wam %put-structure code program-counter 2))
-          (+opcode-set-variable+   (instruction-call wam %set-variable code program-counter 1))
-          (+opcode-set-value+      (instruction-call wam %set-value code program-counter 1))
-          (+opcode-put-variable+   (instruction-call wam %put-variable code program-counter 2))
-          (+opcode-put-value+      (instruction-call wam %put-value code program-counter 2))
-          ;; Program
-          (+opcode-get-structure+  (instruction-call wam %get-structure code program-counter 2))
-          (+opcode-unify-variable+ (instruction-call wam %unify-variable code program-counter 1))
-          (+opcode-unify-value+    (instruction-call wam %unify-value code program-counter 1))
-          (+opcode-get-variable+   (instruction-call wam %get-variable code program-counter 2))
-          (+opcode-get-value+      (instruction-call wam %get-value code program-counter 2))
-          ;; Control
-          (+opcode-allocate+       (instruction-call wam %allocate code program-counter 1))
-          ;; need to skip the PC increment for PROC/CALL/DEAL
-          ;; TODO: this is ugly
-          (+opcode-deallocate+ (instruction-call wam %deallocate code program-counter 0)
-                               (return-from op))
-          (+opcode-proceed+ (instruction-call wam %proceed code program-counter 0)
-                            (return-from op))
-          (+opcode-call+ (instruction-call wam %call code program-counter 1)
-                         (return-from op)))
-        (incf program-counter (instruction-size opcode))
-        (when (>= program-counter (fill-pointer code))
-          (error "Fell off the end of the program code store!"))))
+    (macrolet ((instruction (inst args &body body)
+                 `(progn
+                    (instruction-call wam ,inst code program-counter ,args)
+                   ,@body)))
+      (setf program-counter (wam-code-label wam functor))
+      (loop
+        :while (and (not fail) ; failure
+                    (not (= program-counter +code-sentinal+))) ; finished
+        :for opcode = (aref code program-counter)
+        :do
+        (block op
+          (when step
+            (break "About to execute instruction at ~4,'0X" program-counter))
+          (eswitch (opcode)
+            ;; Query
+            (+opcode-put-structure-local+  (instruction %put-structure-local 2))
+            (+opcode-put-structure-stack+  (instruction %put-structure-stack 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-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-local+  (instruction %get-structure-local 2))
+            (+opcode-get-structure-stack+  (instruction %get-structure-stack 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-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))
+            ;; Control
+            (+opcode-allocate+             (instruction %allocate 1))
+            ;; need to skip the PC increment for PROC/CALL/DEAL
+            ;; TODO: this is ugly
+            (+opcode-deallocate+   (instruction %deallocate 0 (return-from op)))
+            (+opcode-proceed+      (instruction %proceed 0 (return-from op)))
+            (+opcode-call+         (instruction %call 1 (return-from op))))
+          (incf program-counter (instruction-size opcode))
+          (when (>= program-counter (fill-pointer code))
+            (error "Fell off the end of the program code store!")))))
     (values)))
 
 (defun run-query (wam term &optional (step nil))
@@ -404,31 +428,42 @@
 
   "
   ;; TODO: dedupe this interpreter code
-  (let ((code (compile-query wam term)))
-    (wam-reset! wam)
-    (loop
-      :with pc = 0 ; local program counter for this hunk of query code
-      :for opcode = (aref code pc)
-      :do
-      (progn
-        (eswitch (opcode)
-          (+opcode-put-structure+ (instruction-call wam %put-structure code pc 2))
-          (+opcode-set-variable+ (instruction-call wam %set-variable code pc 1))
-          (+opcode-set-value+ (instruction-call wam %set-value code pc 1))
-          (+opcode-put-variable+ (instruction-call wam %put-variable code pc 2))
-          (+opcode-put-value+ (instruction-call wam %put-value code pc 2))
-          (+opcode-call+
-            (when step (break))
-            (setf (wam-continuation-pointer wam) +code-sentinal+)
-            (run-program wam (aref code (+ pc 1)) step)
-            (return)))
-        (incf pc (instruction-size opcode))
-        (when (>= pc (length code)) ; queries SHOULD always end in a CALL...
-          (error "Fell off the end of the query code store!")))))
+  (macrolet ((instruction (inst args &body body)
+               `(progn
+                 (instruction-call wam ,inst code pc ,args)
+                 ,@body)))
+    (let ((code (compile-query wam term)))
+      (when step
+        (dump-code-store wam code))
+      (wam-reset! wam)
+      (loop
+        :with pc = 0 ; local program counter for this hunk of query code
+        :for opcode = (aref code pc)
+        :do
+        (progn
+          (eswitch (opcode)
+            (+opcode-put-structure-local+  (instruction %put-structure-local 2))
+            (+opcode-put-structure-stack+  (instruction %put-structure-stack 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-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-call+
+              (when step
+                (break "Built query on the heap, about to call program code."))
+              (setf (wam-continuation-pointer wam) +code-sentinal+)
+              (run-program wam (aref code (+ pc 1)) step)
+              (return)))
+          (incf pc (instruction-size opcode))
+          (when (>= pc (length code)) ; queries SHOULD always end in a CALL...
+            (error "Fell off the end of the query code store!"))))))
   (if (wam-fail wam)
     (princ "No.")
-    (loop :for (var . val) :in (extract-query-results wam (first term))
-          :do (format t "~S -> ~S~%" var val)))
+    (princ "Yes."))
   (values))
 
 
--- a/src/wam/types.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/types.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -39,16 +39,7 @@
 
 
 (deftype opcode ()
-  '(integer 0 14))
-
-
-(deftype register-designator ()
-  'code-word)
-
-(deftype register-designator-tag ()
-  `(member
-    ,+tag-stack-register+
-    ,+tag-local-register+))
+  '(integer 0 23))
 
 
 (deftype stack-frame-size ()
--- a/src/wam/ui.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/ui.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -2,20 +2,25 @@
 
 
 (defparameter *database* nil)
+(defparameter *debug* nil)
 
 (defmacro with-database (&body body)
   `(let ((*database* (make-wam)))
      ,@body))
 
+
 (defun add-rule (rule)
   (compile-program *database* rule))
 
+(defun perform-query (query)
+  (run-query *database* query *debug*))
+
+
 (defmacro rule (&body body)
   `(add-rule ',body))
 
-(defun perform-query (query)
-  (run-query *database* query))
-
 (defmacro query (&body body)
   `(perform-query ',body))
 
+(defun dump ()
+  (dump-wam-full *database*))
--- a/src/wam/wam.lisp	Sat Apr 16 13:50:36 2016 +0000
+++ b/src/wam/wam.lisp	Sun Apr 17 21:36:15 2016 +0000
@@ -4,25 +4,25 @@
 (defclass wam ()
   ((heap
      :initform (make-array 1024
-                           :fill-pointer 0
-                           :adjustable t
-                           :initial-element (make-cell-null)
-                           :element-type 'heap-cell)
+                 :fill-pointer 0
+                 :adjustable t
+                 :initial-element (make-cell-null)
+                 :element-type 'heap-cell)
      :reader wam-heap
      :documentation "The actual heap (stack).")
    (code
      :initform (make-array 1024
-                           :adjustable t
-                           :fill-pointer 0
-                           :initial-element 0
-                           :element-type 'code-word)
+                 :adjustable t
+                 :fill-pointer 0
+                 :initial-element 0
+                 :element-type 'code-word)
      :reader wam-code
      :documentation "The code store.")
    (functors
      :initform (make-array 64
-                           :fill-pointer 0
-                           :adjustable t
-                           :element-type 'functor)
+                 :fill-pointer 0
+                 :adjustable t
+                 :element-type 'functor)
      :accessor wam-functors
      :documentation "The array of functors in this WAM.")
    (code-labels
@@ -32,22 +32,20 @@
    (registers
      :reader wam-local-registers
      :initform (make-array +register-count+
-                           ;; Initialize to the last element in the heap for
-                           ;; debugging purposes.
-                           ;; todo: don't do this
-                           :initial-element (1- +heap-limit+)
-                           :element-type 'heap-index)
+                 ;; Initialize to the last element in the heap for debugging.
+                 ;; todo: don't do this
+                 :initial-element (1- +heap-limit+)
+                 :element-type 'heap-index)
      :documentation "An array of the local X_i registers.")
    (stack
      :reader wam-stack
      :initform (make-array 1024
-                           :adjustable t
-                           :fill-pointer 0
-                           ;; Initialize to the last element in the heap for
-                           ;; debugging purposes.
-                           ;; todo: don't do this
-                           :initial-element (1- +heap-limit+)
-                           :element-type 'stack-word)
+                 :adjustable t
+                 :fill-pointer 0
+                 ;; Initialize to the last element in the heap for debugging.
+                 ;; todo: don't do this
+                 :initial-element (1- +heap-limit+)
+                 :element-type 'stack-word)
      :documentation "The local stack for storing stack frames.")
    (fail
      :accessor wam-fail
@@ -57,9 +55,9 @@
    (unification-stack
      :reader wam-unification-stack
      :initform (make-array 16
-                           :fill-pointer 0
-                           :adjustable t
-                           :element-type 'heap-index)
+                 :fill-pointer 0
+                 :adjustable t
+                 :element-type 'heap-index)
      :documentation "The unification stack.")
    (s
      :accessor wam-s
@@ -235,7 +233,7 @@
   "Pop an environment (stack frame) off the WAM stack."
   (let ((frame-size (wam-stack-frame-size wam)))
     (with-slots (stack environment-pointer) wam
-      (decf environment-pointer frame-size) ; lol
+      (setf environment-pointer (wam-stack-frame-ce wam)) ; E <- CE
       (decf (fill-pointer stack) frame-size)))) ; its fine
 
 
@@ -267,10 +265,10 @@
 (defun* retrieve-instruction (code-store (address code-index))
   "Return the full instruction at the given address in the code store."
   (make-array (instruction-size (aref code-store address))
-              :displaced-to code-store
-              :displaced-index-offset address
-              :adjustable nil
-              :element-type 'code-word))
+    :displaced-to code-store
+    :displaced-index-offset address
+    :adjustable nil
+    :element-type 'code-word))
 
 
 (defun* wam-code-word ((wam wam) (address code-index))
@@ -338,12 +336,9 @@
 ;;;
 ;;; Registers are typically denoted by their "register index", which is just
 ;;; their number.  Hoever, the bytecode needs to be able to distinguish between
-;;; local and stack registers.  To do this we use "register designators" (see
-;;; bytecode.lisp for more information on those).
-;;;
-;;; `wam-register` and `wam-register-cell` provide an interface to pass in
-;;; a register designator and get out "the right thing", so you should probably
-;;; just use those and not worry about the other functions here.
+;;; local and stack registers.  To do this we just make separate opcodes for
+;;; each kind.  This is ugly, but it lets us figure things out at compile time
+;;; instead of runtime, and register references happen A LOT at runtime.
 
 (defun* wam-local-register ((wam wam) (register register-index))
   (:returns heap-index)
@@ -363,29 +358,6 @@
   (setf (wam-stack-frame-arg wam register) new-value))
 
 
-(defun* wam-register ((wam wam) (register-designator register-designator))
-  (:returns heap-index)
-  "Return the heap index the designated register is pointing at."
-  (if (register-designator-local-p register-designator) ; ugly but fast
-    (wam-local-register wam (register-designator-value register-designator))
-    (wam-stack-register wam (register-designator-value register-designator))))
-
-(defun (setf wam-register) (new-value wam register-designator)
-  (if (register-designator-local-p register-designator) ; ugly but fast
-    (setf (wam-local-register wam (register-designator-value register-designator)) new-value)
-    (setf (wam-stack-register wam (register-designator-value register-designator)) new-value)))
-
-
-(defun* wam-register-cell ((wam wam) (register-designator register-designator))
-  (:returns heap-cell)
-  "Return the heap cell the designated register is pointing at."
-  (wam-heap-cell
-    wam
-    (if (register-designator-local-p register-designator)
-      (wam-local-register wam (register-designator-value register-designator))
-      (wam-stack-register wam (register-designator-value register-designator)))))
-
-
 (defun* wam-s-cell ((wam wam))
   "Retrieve the cell the S register is pointing at.