# HG changeset patch # User Steve Losh # Date 1468253838 0 # Node ID 3b0161d2100d14fc128e9e86737294c19b816ddf # Parent 23d4dc2900a1f4329191f5637a3bd46077c54f30 Refactor the main WAM store into a `simple-array` Well that was easy. And now `hairy-data-vector-ref` isn't taking 15% of our runtime. Yay! diff -r 23d4dc2900a1 -r 3b0161d2100d package.lisp --- a/package.lisp Mon Jul 11 14:15:14 2016 +0000 +++ b/package.lisp Mon Jul 11 16:17:18 2016 +0000 @@ -15,6 +15,7 @@ #:when-let #:unique-items #:dis + #:megabytes #:gethash-or-init #:define-lookup #:make-queue diff -r 23d4dc2900a1 -r 3b0161d2100d src/utils.lisp --- a/src/utils.lisp Mon Jul 11 14:15:14 2016 +0000 +++ b/src/utils.lisp Mon Jul 11 16:17:18 2016 +0000 @@ -136,6 +136,10 @@ (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). diff -r 23d4dc2900a1 -r 3b0161d2100d src/wam/types.lisp --- a/src/wam/types.lisp Mon Jul 11 14:15:14 2016 +0000 +++ b/src/wam/types.lisp Mon Jul 11 16:17:18 2016 +0000 @@ -10,6 +10,10 @@ `(unsigned-byte ,+cell-value-width+)) +(deftype store () + '(simple-array cell (*))) + + (deftype store-index () `(integer 0 ,(1- +store-limit+))) diff -r 23d4dc2900a1 -r 3b0161d2100d src/wam/vm.lisp --- a/src/wam/vm.lisp Mon Jul 11 14:15:14 2016 +0000 +++ b/src/wam/vm.lisp Mon Jul 11 16:17:18 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) @@ -635,6 +642,7 @@ ;;;; Constant Instructions +(declaim (inline %%match-constant)) (defun* %%match-constant ((wam wam) (constant functor-index) (address store-index)) diff -r 23d4dc2900a1 -r 3b0161d2100d src/wam/wam.lisp --- a/src/wam/wam.lisp Mon Jul 11 14:15:14 2016 +0000 +++ b/src/wam/wam.lisp Mon Jul 11 16:17:18 2016 +0000 @@ -17,6 +17,7 @@ wam-number-of-arguments wam-subterm wam-program-counter + wam-heap-pointer wam-continuation-pointer wam-environment-pointer wam-backtrack-pointer @@ -34,6 +35,21 @@ :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 @@ -44,22 +60,8 @@ (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 (allocate-wam-code 0) @@ -102,6 +104,7 @@ (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 @@ -115,9 +118,11 @@ (mode nil :type (or null (member :read :write)))) -(defun* make-wam (&key (code-size (* 1024 1024))) +(defun* make-wam (&key (store-size (megabytes 10)) + (code-size (megabytes 1))) (:returns wam) - (make-wam% :code (allocate-wam-code code-size))) + (make-wam% :code (allocate-wam-code code-size) + :store (allocate-wam-store store-size))) ;;;; Store @@ -166,19 +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 heap-index) - (wam 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)) @@ -521,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))