# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1462216060 0
# Node ID 5503ccfaae6509b6ca4c936705b80a36c984f14d
# Parent  1fea3b65a964f5a7ed41f248c0915fd05a735a9b
THE STRUCTENING

diff -r 1fea3b65a964 -r 5503ccfaae65 src/wam/vm.lisp
--- a/src/wam/vm.lisp	Mon May 02 17:56:08 2016 +0000
+++ b/src/wam/vm.lisp	Mon May 02 19:07:40 2016 +0000
@@ -386,7 +386,7 @@
             (+ (wam-program-counter wam)
                (instruction-size +opcode-call+))
 
-            (wam-nargs wam) ; set NARGS
+            (wam-number-of-arguments wam) ; set NARGS
             (wam-functor-arity wam functor)
 
             (wam-program-counter wam) ; jump
@@ -398,14 +398,14 @@
         (wam-continuation-pointer wam)))
 
 (define-instruction %allocate ((wam wam) (n stack-frame-argcount))
-  ;; We use the slots directly here for speed.  I know this sucks.  I'm sorry.
-  (with-slots (stack environment-pointer) wam
-    (let ((new-e (wam-stack-top wam)))
-      (wam-stack-ensure-size! wam (+ new-e 3 n))
-      (setf (aref stack new-e) environment-pointer ; CE
-            (aref stack (+ new-e 1)) (wam-continuation-pointer wam) ; CP
-            (aref stack (+ new-e 2)) n ; N
-            environment-pointer new-e)))) ; E <- new-e
+  (let ((stack (wam-stack wam))
+        (old-e (wam-environment-pointer wam))
+        (new-e (wam-stack-top wam)))
+    (wam-stack-ensure-size! wam (+ new-e 3 n))
+    (setf (aref stack new-e) old-e ; CE
+          (aref stack (+ new-e 1)) (wam-continuation-pointer wam) ; CP
+          (aref stack (+ new-e 2)) n ; N
+          (wam-environment-pointer wam) new-e))) ; E <- new-e
 
 (define-instruction %deallocate ((wam wam))
   (setf (wam-program-counter wam)
@@ -416,22 +416,22 @@
 
 ;;;; Choice Instructions
 (define-instruction %try ((wam wam) (next-clause code-index))
-  (with-slots (stack backtrack-pointer) wam
-    (let ((new-b (wam-stack-top wam))
-          (nargs (wam-nargs wam)))
-      (wam-stack-ensure-size! wam (+ new-b 7 nargs))
-      (setf (aref stack new-b) nargs ; N
-            (aref stack (+ new-b 1)) (wam-environment-pointer wam) ; CE
-            (aref stack (+ new-b 2)) (wam-continuation-pointer wam) ; CP
-            (aref stack (+ new-b 3)) (wam-backtrack-pointer wam) ; CB
-            (aref stack (+ new-b 4)) next-clause ; BP
-            (aref stack (+ new-b 5)) (wam-trail-pointer wam) ; TR
-            (aref stack (+ new-b 6)) (wam-heap-pointer wam) ; H
-            (wam-heap-backtrack-pointer wam) (wam-heap-pointer wam) ; HB
-            (wam-backtrack-pointer wam) new-b) ; B
-      (loop :for i :from 0 :below nargs :do ; A_i
-            (setf (wam-stack-choice-arg wam i new-b)
-                  (wam-local-register wam i))))))
+  (let ((stack (wam-stack wam))
+        (new-b (wam-stack-top wam))
+        (nargs (wam-number-of-arguments wam)))
+    (wam-stack-ensure-size! wam (+ new-b 7 nargs))
+    (setf (aref stack new-b) nargs ; N
+          (aref stack (+ new-b 1)) (wam-environment-pointer wam) ; CE
+          (aref stack (+ new-b 2)) (wam-continuation-pointer wam) ; CP
+          (aref stack (+ new-b 3)) (wam-backtrack-pointer wam) ; CB
+          (aref stack (+ new-b 4)) next-clause ; BP
+          (aref stack (+ new-b 5)) (wam-trail-pointer wam) ; TR
+          (aref stack (+ new-b 6)) (wam-heap-pointer wam) ; H
+          (wam-heap-backtrack-pointer wam) (wam-heap-pointer wam) ; HB
+          (wam-backtrack-pointer wam) new-b) ; B
+    (loop :for i :from 0 :below nargs :do ; A_i
+          (setf (wam-stack-choice-arg wam i new-b)
+                (wam-local-register wam i)))))
 
 (define-instruction %retry ((wam wam) (next-clause code-index))
   (let ((b (wam-backtrack-pointer wam)))
@@ -529,66 +529,67 @@
 
 
 (defun run (wam done-thunk)
-  (with-slots (code program-counter fail backtrack) wam
-    (macrolet ((instruction (inst args)
-                 `(instruction-call wam ,inst code program-counter ,args)))
-      (loop
-        :while (and (not fail) ; failure
-                    (not (= program-counter +code-sentinal+))) ; finished
-        :for opcode = (aref code program-counter)
-        :do
-        (block op
-          (when *step*
-            (dump) ; todo: make this saner
-            (break "About to execute instruction at ~4,'0X" program-counter))
-          (eswitch (opcode)
-            ;; Query
-            (+opcode-put-structure-local+  (instruction %put-structure-local 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-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))
-            ;; Choice
-            (+opcode-try+                  (instruction %try 1))
-            (+opcode-retry+                (instruction %retry 1))
-            (+opcode-trust+                (instruction %trust 0))
-            ;; Control
-            (+opcode-allocate+             (instruction %allocate 1))
-            ;; need to skip the PC increment for PROC/CALL/DEAL/DONE
-            ;; 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))
-            (+opcode-done+
-              (if (funcall done-thunk)
-                (return-from run)
-                (backtrack! wam "done-function returned false"))))
-          ;; Only increment the PC when we didn't backtrack
-          (if (wam-backtracked wam)
-            (setf (wam-backtracked wam) nil)
-            (incf program-counter (instruction-size opcode)))
-          (when (>= program-counter (fill-pointer code))
-            (error "Fell off the end of the program code store!")))))
+  (with-accessors ((pc wam-program-counter)) wam
+    (let ((code (wam-code wam)))
+      (macrolet ((instruction (inst args)
+                   `(instruction-call wam ,inst code pc ,args)))
+        (loop
+          :while (and (not (wam-fail wam)) ; failure
+                      (not (= pc +code-sentinal+))) ; finished
+          :for opcode = (aref code pc)
+          :do
+          (block op
+            (when *step*
+              (dump) ; todo: make this saner
+              (break "About to execute instruction at ~4,'0X" pc))
+            (eswitch (opcode)
+              ;; Query
+              (+opcode-put-structure-local+  (instruction %put-structure-local 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-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))
+              ;; Choice
+              (+opcode-try+                  (instruction %try 1))
+              (+opcode-retry+                (instruction %retry 1))
+              (+opcode-trust+                (instruction %trust 0))
+              ;; Control
+              (+opcode-allocate+             (instruction %allocate 1))
+              ;; need to skip the PC increment for PROC/CALL/DEAL/DONE
+              ;; 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))
+              (+opcode-done+
+                (if (funcall done-thunk)
+                  (return-from run)
+                  (backtrack! wam "done-function returned false"))))
+            ;; Only increment the PC when we didn't backtrack
+            (if (wam-backtracked wam)
+              (setf (wam-backtracked wam) nil)
+              (incf pc (instruction-size opcode)))
+            (when (>= pc (fill-pointer code))
+              (error "Fell off the end of the program code store!"))))))
     (values)))
 
 (defun run-query (wam term
diff -r 1fea3b65a964 -r 5503ccfaae65 src/wam/wam.lisp
--- a/src/wam/wam.lisp	Mon May 02 17:56:08 2016 +0000
+++ b/src/wam/wam.lisp	Mon May 02 19:07:40 2016 +0000
@@ -1,121 +1,122 @@
 (in-package #:bones.wam)
 
 ;;;; WAM
-(defclass wam ()
-  ((heap
-     :initform (make-array 1024
-                 :fill-pointer 0
-                 :adjustable t
-                 :initial-element (make-cell-null)
-                 :element-type 'heap-cell)
-     :reader wam-heap
-     :documentation "The actual heap (stack).")
-   (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.
-     :initform (make-array (+ +maximum-query-size+ 1024)
-                 :adjustable t
-                 :fill-pointer +maximum-query-size+
-                 :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)
-     :accessor wam-functors
-     :documentation "The array of functors in this WAM.")
-   (code-labels
-     :initform (make-hash-table)
-     :accessor wam-code-labels
-     :documentation "The mapping of functor indices -> code store addresses.")
-   (registers
-     :reader wam-local-registers
-     :initform (make-array +register-count+
-                 ;; 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
-                 :initial-element 0
-                 :element-type 'stack-word)
-     :documentation "The local stack for storing stack frames.")
-   (fail
-     :accessor wam-fail
-     :initform nil
-     :type boolean
-     :documentation "The failure register.")
-   (backtracked
-     :accessor wam-backtracked
-     :initform nil
-     :type boolean
-     :documentation "The backtracked register.")
-   (unification-stack
-     :reader wam-unification-stack
-     :initform (make-array 16
-                 :fill-pointer 0
-                 :adjustable t
-                 :element-type 'heap-index)
-     :documentation "The unification stack.")
-   (trail
-     :reader wam-trail
-     :initform (make-array 64
-                 :fill-pointer 0
-                 :adjustable t
-                 :element-type 'heap-index)
-     :documentation "The trail of variables to unbind on backtracking.")
-   (number-of-arguments
-     :accessor wam-nargs
-     :initform 0
-     :type arity
-     :documentation "The Number of Arguments register (global var).")
-   (subterm
-     :accessor wam-subterm
-     :initform nil
-     :type (or null heap-index)
-     :documentation "The Subterm register (S).")
-   (program-counter
-     :accessor wam-program-counter
-     :initform 0
-     :type code-index
-     :documentation "The Program Counter (P) into the WAM code store.")
-   (continuation-pointer
-     :accessor wam-continuation-pointer
-     :initform 0
-     :type code-index
-     :documentation "The Continuation Pointer (CP) into the WAM code store.")
-   (environment-pointer
-     :accessor wam-environment-pointer
-     :initform 0
-     :type environment-pointer
-     :documentation "The Environment Pointer (E) into the WAM stack.")
-   (backtrack-pointer
-     :accessor wam-backtrack-pointer
-     :initform 0
-     :type backtrack-pointer
-     :documentation "The Backtrack Pointer (B) into the WAM stack.")
-   (heap-backtrack-pointer
-     :accessor wam-heap-backtrack-pointer
-     :initform 0
-     :type heap-index
-     :documentation "The Heap Backtrack Pointer (HB) into the WAM heap.")
-   (mode
-     :accessor wam-mode
-     :initform nil
-     :type (or null (member :read :write))
-     :documentation "Current unification mode (:READ or :WRITE (or NIL)).")))
+(declaim
+  ;; Inline all these struct accessors, otherwise things get REAL slow.
+  (inline wam-heap
+          wam-code
+          wam-functors
+          wam-code-labels
+          wam-local-registers
+          wam-stack
+          wam-fail
+          wam-backtracked
+          wam-unification-stack
+          wam-trail
+          wam-number-of-arguments
+          wam-subterm
+          wam-program-counter
+          wam-continuation-pointer
+          wam-environment-pointer
+          wam-backtrack-pointer
+          wam-heap-backtrack-pointer
+          wam-mode))
 
+(defstruct (wam (:type vector) :named)
+  (heap
+    (make-array 1024
+      :fill-pointer 0
+      :adjustable t
+      :initial-element (make-cell-null)
+      :element-type 'heap-cell)
+    :type (vector heap-cell)
+    :read-only t)
+  (code
+    ;; The WAM bytecode is all stored in this array.  The first
+    ;; `+maximum-query-size+` words are reserved for query bytecode, which will
+    ;; get loaded in (overwriting the previous query) when making a query.
+    ;; Everything after that is for the actual database.
+    (make-array (+ +maximum-query-size+ 1024)
+      :adjustable t
+      :fill-pointer +maximum-query-size+
+      :initial-element 0
+      :element-type 'code-word)
+    :type (vector code-word)
+    :read-only t)
+  (functors
+    (make-array 64
+      :fill-pointer 0
+      :adjustable t
+      :element-type 'functor)
+    :type (vector functor)
+    :read-only t)
+  (code-labels
+    (make-hash-table)
+    :read-only t)
+  (local-registers
+    (make-array +register-count+
+      ;; Initialize to the last element in the heap for debugging.
+      ;; todo: don't do this
+      :initial-element (1- +heap-limit+)
+      :element-type 'heap-index)
+    :type (simple-array heap-index)
+    :read-only t)
+  (stack
+    (make-array 1024
+      :adjustable t
+      :initial-element 0
+      :element-type 'stack-word)
+    :type (vector stack-word)
+    :read-only t)
+  (fail
+    nil
+    :type boolean)
+  (backtracked
+    nil
+    :type boolean)
+  (unification-stack
+    (make-array 16
+      :fill-pointer 0
+      :adjustable t
+      :element-type 'heap-index)
+    :type (vector heap-index)
+    :read-only t)
+  (trail
+    (make-array 64
+      :fill-pointer 0
+      :adjustable t
+      :initial-element 0
+      :element-type 'heap-index)
+    :type (vector heap-index)
+    :read-only t)
+  (number-of-arguments
+    0
+    :type arity)
+  (subterm
+    nil
+    :type (or null heap-index))
+  (program-counter ; P
+    0
+    :type code-index)
+  (continuation-pointer ; CP
+    0
+    :type code-index)
+  (environment-pointer ; E
+    0
+    :type environment-pointer)
+  (backtrack-pointer ; B
+    0
+    :type backtrack-pointer)
+  (heap-backtrack-pointer ; HB
+    0
+    :type heap-index)
+  (mode
+    nil
+    :type (or null (member :read :write))))
 
-(defun make-wam ()
-  (make-instance 'wam))
+(deftype wam ()
+  ; todo lol
+  '(simple-vector 19))
 
 
 ;;;; Heap
@@ -126,7 +127,7 @@
   Returns the cell and the address it was pushed to.
 
   "
-  (with-slots (heap) wam
+  (let ((heap (wam-heap wam)))
     (if (= +heap-limit+ (fill-pointer heap))
       (error "WAM heap exhausted.")
       (values cell (vector-push-extend cell heap)))))
@@ -166,7 +167,7 @@
   Returns the address and the trail address it was pushed to.
 
   "
-  (with-slots (trail) wam
+  (let ((trail (wam-trail wam)))
     (if (= +trail-limit+ (fill-pointer trail))
       (error "WAM trail exhausted.")
       (values address (vector-push-extend address trail)))))
@@ -208,7 +209,7 @@
   It will be adjusted (but not beyond the limit) if necessary.
 
   "
-  (with-slots (stack) wam
+  (let ((stack (wam-stack wam)))
     (if (>= address +stack-limit+)
       (error "WAM stack exhausted.")
       (while (>= address (array-total-size stack))
@@ -401,7 +402,8 @@
   ;; The book is wrong here -- it looks up the "current frame size" to
   ;; determine where the next frame should start, but on the first allocation
   ;; there IS no current frame so it looks at garbage.  Fuckin' great.
-  (with-slots ((e environment-pointer) (b backtrack-pointer)) wam
+  (let ((e (wam-environment-pointer wam))
+        (b (wam-backtrack-pointer wam)))
     (cond
       ((= 0 b e) 1) ; first allocation
       ((> e b) ; the last thing on the stack is a frame
@@ -577,7 +579,7 @@
   If the functor is not already in the table it will be added.
 
   "
-  (with-slots (functors) wam
+  (let ((functors (wam-functors wam)))
     (or (position functor functors :test #'equal)
         (vector-push-extend functor functors))))