--- a/examples/bench.lisp Sat May 14 22:42:31 2016 +0000
+++ b/examples/bench.lisp Sun May 15 00:06:53 2016 +0000
@@ -26,10 +26,10 @@
; (declaim (optimize (speed 0) (safety 3) (debug 3)))
; (run-test)
-(format t "~%~%====================================~%")
-(format t "(speed 3) (safety 1) (debug 1)~%")
-(declaim (optimize (speed 3) (safety 1) (debug 1)))
-(run-test)
+; (format t "~%~%====================================~%")
+; (format t "(speed 3) (safety 1) (debug 1)~%")
+; (declaim (optimize (speed 3) (safety 1) (debug 1)))
+; (run-test)
(format t "~%~%====================================~%")
(format t "(speed 3) (safety 1) (debug 0)~%")
--- a/examples/profile.lisp Sat May 14 22:42:31 2016 +0000
+++ b/examples/profile.lisp Sun May 15 00:06:53 2016 +0000
@@ -23,9 +23,11 @@
(sb-sprof:with-profiling (:max-samples 5000
:sample-interval 0.001
- :report :flat
:loop nil)
- (bones.wam::dfs-exhaust)))
+ (bones.wam::dfs-exhaust))
+
+ (sb-sprof:report :type :flat)
+ )
; (format t "~%~%====================================~%")
; (format t "(speed 3) (safety 1) (debug 1)~%")
--- a/src/wam/cells.lisp Sat May 14 22:42:31 2016 +0000
+++ b/src/wam/cells.lisp Sun May 15 00:06:53 2016 +0000
@@ -26,6 +26,8 @@
;;;
+(declaim (inline cell-type
+ cell-value))
(defun* cell-type ((cell cell))
(:returns cell-tag)
(logand cell +cell-tag-bitmask+))
@@ -61,6 +63,11 @@
(cell-value cell)))
+(declaim (inline cell-null-p
+ cell-reference-p
+ cell-functor-p
+ cell-structure-p
+ cell-constant-p))
(defun* cell-null-p ((cell cell))
(:returns boolean)
(= (cell-type cell) +tag-null+))
@@ -82,6 +89,12 @@
(= (cell-type cell) +tag-constant+))
+(declaim (inline make-cell
+ make-cell-null
+ make-cell-structure
+ make-cell-reference
+ make-cell-functor
+ make-cell-constant))
(defun* make-cell ((tag cell-tag) (value cell-value))
(:returns cell)
(values
--- a/src/wam/compiler.lisp Sat May 14 22:42:31 2016 +0000
+++ b/src/wam/compiler.lisp Sun May 15 00:06:53 2016 +0000
@@ -6,24 +6,15 @@
'(member :argument :local :permanent))
(deftype register-number ()
- '(integer 0))
+ `(integer 0 ,(1- +register-count+)))
-(defclass register ()
- ((type
- :initarg :type
- :reader register-type
- :type register-type)
- (number
- :initarg :number
- :reader register-number
- :type register-number)))
+(declaim (inline register-type register-number))
+(defstruct (register (:constructor make-register (type number)))
+ (type :local :type register-type)
+ (number 0 :type register-number))
-(defun* make-register ((type register-type) (number register-number))
- (:returns register)
- (make-instance 'register :type type :number number))
-
(defun* make-temporary-register ((number register-number) (arity arity))
(:returns register)
(make-register (if (< number arity) :argument :local)
@@ -49,6 +40,9 @@
(format stream (register-to-string object))))
+(declaim (inline register-argument-p
+ register-temporary-p
+ register-permanent-p))
(defun* register-argument-p ((register register))
(eql (register-type register) :argument))
@@ -59,25 +53,12 @@
(eql (register-type register) :permanent))
+(declaim (inline register=))
(defun* register= ((r1 register) (r2 register))
- (:returns boolean)
- (ensure-boolean
- (and (eql (register-type r1)
- (register-type r2))
- (= (register-number r1)
- (register-number r2)))))
-
-(defun* register≈ ((r1 register) (r2 register))
- (:returns boolean)
- (ensure-boolean
- (and (or (eql (register-type r1)
- (register-type r2))
- ;; local and argument registers are actually the same register,
- ;; just named differently
- (and (register-temporary-p r1)
- (register-temporary-p r2)))
- (= (register-number r1)
- (register-number r2)))))
+ (and (eql (register-type r1)
+ (register-type r2))
+ (= (register-number r1)
+ (register-number r2))))
;;;; Register Assignments
@@ -101,9 +82,10 @@
(assoc register assignments))
-(defun* variable-p (term)
+(declaim (inline variablep))
+(defun* variablep (term)
(:returns boolean)
- (ensure-boolean (keywordp term)))
+ (keywordp term))
(defun* variable-assignment-p ((assignment register-assignment))
@@ -116,7 +98,7 @@
"
(:returns boolean)
- (variable-p (cdr assignment)))
+ (variablep (cdr assignment)))
(defun* variable-register-p ((register register)
(assignments register-assignment-list))
@@ -334,7 +316,7 @@
(make-temporary-register reg arity))))
(parse (term &optional register)
(cond
- ((variable-p term) (parse-variable term))
+ ((variablep term) (parse-variable term))
((symbolp term) (parse (list term) register)) ; f -> f/0
((listp term) (parse-structure term register))
(t (error "Cannot parse term ~S." term))))
@@ -615,7 +597,7 @@
(defun find-variables (terms)
"Return the set of variables in `terms`."
- (remove-duplicates (tree-collect #'variable-p terms)))
+ (remove-duplicates (tree-collect #'variablep terms)))
(defun find-shared-variables (terms)
"Return the set of all variables shared by two or more terms."
--- a/src/wam/vm.lisp Sat May 14 22:42:31 2016 +0000
+++ b/src/wam/vm.lisp Sun May 15 00:06:53 2016 +0000
@@ -28,29 +28,28 @@
(wam-heap-push! wam (make-cell-functor functor)))
+(declaim (inline bound-reference-p
+ unbound-reference-p
+ 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."
- (ensure-boolean
- (let ((cell (wam-store-cell wam address)))
- (and (cell-reference-p cell)
- (not (= (cell-value cell) address))))))
+ (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."
- (ensure-boolean
- (let ((cell (wam-store-cell wam address)))
- (and (cell-reference-p cell)
- (= (cell-value cell) address)))))
+ (let ((cell (wam-store-cell wam address)))
+ (and (cell-reference-p cell)
+ (= (cell-value cell) address))))
(defun* matching-functor-p ((cell cell)
(functor functor-index))
- (:returns boolean)
"Return whether `cell` is a functor cell containing `functor`."
- (ensure-boolean
- (and (cell-functor-p cell)
- (= (cell-value cell) functor))))
+ (and (cell-functor-p cell)
+ (= (cell-value cell) functor)))
(defun* functors-match-p ((functor-cell-1 cell)
(functor-cell-2 cell))
--- a/src/wam/wam.lisp Sat May 14 22:42:31 2016 +0000
+++ b/src/wam/wam.lisp Sun May 15 00:06:53 2016 +0000
@@ -100,6 +100,7 @@
;;;; Store
+(declaim (inline wam-store-cell (setf wam-store-cell)))
(defun* wam-store-cell ((wam wam) (address store-index))
(:returns cell)
"Return the cell at the given address.
@@ -122,6 +123,12 @@
;;; We reserve the first address in the heap as a sentinel, as an "unset" value
;;; for various pointers into the heap.
+(declaim (inline wam-heap-pointer-unset-p
+ wam-heap-cell
+ (setf wam-heap-cell)
+ wam-heap-pointer
+ (setf wam-heap-pointer)))
+
(defun* wam-heap-pointer-unset-p ((wam wam) (address heap-index))
(:returns boolean)
(declare (ignore wam))
@@ -152,13 +159,13 @@
(defun* wam-heap-cell ((wam wam) (address heap-index))
(:returns cell)
"Return the heap cell at the given address."
- (assert (not (wam-heap-pointer-unset-p wam address)) ()
- "Cannot read from heap address zero.")
+ (when (wam-heap-pointer-unset-p wam address)
+ (error "Cannot read from heap address zero."))
(aref (wam-store wam) address))
(defun (setf wam-heap-cell) (new-value wam address)
- (assert (not (wam-heap-pointer-unset-p wam address)) ()
- "Cannot write to heap address zero.")
+ (when (wam-heap-pointer-unset-p wam address)
+ (error "Cannot write to heap address zero."))
(setf (aref (wam-store wam) address) new-value))
@@ -203,32 +210,46 @@
;;; first word of the stack (address `+stack-start`) to mean "uninitialized", so
;;; we have a nice sentinel value for the various pointers into the stack.
-(declaim (inline wam-stack-word))
+(declaim (inline assert-inside-stack
+ wam-stack-ensure-size
+ wam-stack-word
+ (setf wam-stack-word)
+ wam-backtrack-pointer-unset-p
+ wam-environment-pointer-unset-p))
+
-(defun assert-inside-stack (wam address action)
- (declare (ignore wam))
- (assert (<= +stack-start+ address (1- +stack-end+)) ()
- "Cannot ~A stack cell at address ~X (outside the stack range ~X to ~X)"
- action address +stack-start+ +stack-end+)
- (assert (not (= +stack-start+ address)) ()
- "Cannot ~A stack address zero."
- action))
+(defun* assert-inside-stack ((wam wam) (address store-index))
+ (:returns :void)
+ (declare (ignore wam address))
+ (policy-cond:policy-cond
+ ((>= debug 2)
+ (progn
+ (assert (<= +stack-start+ address (1- +stack-end+)) ()
+ "Cannot access stack cell at address ~X (outside the stack range ~X to ~X)"
+ address +stack-start+ +stack-end+)
+ (assert (not (= +stack-start+ address)) ()
+ "Cannot access stack address zero.")))
+ ((>= safety 1)
+ (when (not (< +stack-start+ address +stack-end+))
+ (error "Stack bounds crossed. Game over.")))
+ (t nil)) ; wew lads
+ (values))
(defun* wam-stack-ensure-size ((wam wam) (address stack-index))
(:returns :void)
"Ensure the WAM stack is large enough to be able to write to `address`."
- (assert-inside-stack wam address "write")
+ (assert-inside-stack wam address)
(values))
(defun* wam-stack-word ((wam wam) (address stack-index))
(:returns stack-word)
"Return the stack word at the given address."
- (assert-inside-stack wam address "read")
+ (assert-inside-stack wam address)
(aref (wam-store wam) address))
(defun (setf wam-stack-word) (new-value wam address)
- (assert-inside-stack wam address "write")
+ (assert-inside-stack wam address)
(setf (aref (wam-store wam) address) new-value))
@@ -259,6 +280,14 @@
;;; | .. |
;;; | Yn |
;;; |NEXT| <-- fill-pointer
+
+(declaim (inline wam-stack-frame-ce
+ wam-stack-frame-cp
+ wam-stack-frame-n
+ wam-stack-frame-arg
+ (setf wam-stack-frame-arg)
+ wam-stack-frame-size))
+
(defun* wam-stack-frame-ce
((wam wam)
&optional
@@ -293,8 +322,11 @@
(:returns cell)
(wam-stack-word wam (+ 3 n e)))
-(defun (setf wam-stack-frame-arg)
- (new-value wam n &optional (e (wam-environment-pointer wam)))
+(defun* (setf wam-stack-frame-arg)
+ ((new-value cell)
+ (wam wam)
+ (n register-index)
+ &optional ((e environment-pointer) (wam-environment-pointer wam)))
(setf (wam-stack-word wam (+ e 3 n))
new-value))
@@ -324,6 +356,17 @@
;;; 7+n | An |
;;; |NEXT| <-- fill-pointer
+(declaim (inline wam-stack-choice-n
+ wam-stack-choice-ce
+ wam-stack-choice-cp
+ wam-stack-choice-cb
+ wam-stack-choice-bp
+ wam-stack-choice-tr
+ wam-stack-choice-h
+ wam-stack-choice-arg
+ (setf wam-stack-choice-arg)
+ wam-stack-choice-size))
+
(defun* wam-stack-choice-n
((wam wam)
&optional
@@ -390,8 +433,11 @@
(:returns cell)
(wam-stack-word wam (+ b 7 n)))
-(defun (setf wam-stack-choice-arg)
- (new-value wam n &optional (b (wam-backtrack-pointer wam)))
+(defun* (setf wam-stack-choice-arg)
+ ((new-value cell)
+ (wam wam)
+ (n arity)
+ &optional ((b backtrack-pointer) (wam-backtrack-pointer wam)))
(setf (wam-stack-word wam (+ b 7 n))
new-value))
@@ -603,6 +649,11 @@
;;; / _, _/ /___/ /_/ // / ___/ // / / /___/ _, _/___/ / / ___ |/ _, _/ /___ / /___/ /___/ /___/ /______/ /
;;; /_/ |_/_____/\____/___//____//_/ /_____/_/ |_|/____/ /_/ |_/_/ |_/_____/ \____/_____/_____/_____/____/
+(declaim (inline wam-local-register
+ (setf wam-local-register)
+ wam-stack-register
+ (setf wam-stack-register)))
+
(defun* wam-local-register ((wam wam) (register register-index))
(:returns cell)
"Return the value stored in the WAM local register with the given index."
@@ -637,6 +688,10 @@
;;; Functors are stored in an adjustable array. Cells refer to a functor using
;;; the functor's address in this array.
+(declaim (inline wam-functor-lookup
+ wam-functor-symbol
+ wam-functor-arity))
+
(defun* wam-ensure-functor-index ((wam wam) (functor functor))
(:returns functor-index)
"Return the index of the functor in the WAM's functor table.