# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1463270813 0
# Node ID 95d0602ff36b1cc41421727255bfc6764caf2b8a
# Parent  27f037427ad30c4fd39ecfaf3195ec79115a96be
Begin inlining things

Things seemed a bit slow, so I decided to start poking around the guts of this
thing I've built.  After a couple hours of profiling, poring over disassembly,
tweaking the hottest functions, and inlining things once their bodies were small
enough, I can say it's definitely faster.

diff -r 27f037427ad3 -r 95d0602ff36b examples/bench.lisp
--- 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)~%")
diff -r 27f037427ad3 -r 95d0602ff36b examples/profile.lisp
--- 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)~%")
diff -r 27f037427ad3 -r 95d0602ff36b src/wam/cells.lisp
--- 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
diff -r 27f037427ad3 -r 95d0602ff36b src/wam/compiler.lisp
--- 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."
diff -r 27f037427ad3 -r 95d0602ff36b src/wam/vm.lisp
--- 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))
diff -r 27f037427ad3 -r 95d0602ff36b src/wam/wam.lisp
--- 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.