--- 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
--- 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))))