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