--- a/Makefile Sat May 14 18:52:14 2016 +0000
+++ b/Makefile Sat May 14 22:42:31 2016 +0000
@@ -1,4 +1,4 @@
-.PHONY: test pubdocs bench
+.PHONY: test pubdocs bench profile
sourcefiles = $(shell ffind --full-path --dir src --literal .lisp)
docfiles = $(shell ls docs/*.markdown)
@@ -26,3 +26,6 @@
bench:
sbcl-rlwrap --noinform --load examples/bench.lisp --eval '(quit)'
+
+profile:
+ sbcl-rlwrap --noinform --load examples/profile.lisp --eval '(quit)'
--- a/bones.asd Sat May 14 18:52:14 2016 +0000
+++ b/bones.asd Sat May 14 22:42:31 2016 +0000
@@ -12,6 +12,7 @@
#:optima
#:trivial-types
#:cl-arrows
+ #:policy-cond
#:fare-quasiquote-optima
#:fare-quasiquote-readtable)
--- a/examples/bench.lisp Sat May 14 18:52:14 2016 +0000
+++ b/examples/bench.lisp Sat May 14 22:42:31 2016 +0000
@@ -21,6 +21,11 @@
(format t "WAM -------------------------------~%")
(time (bones.wam::dfs-exhaust)))
+; (format t "~%~%====================================~%")
+; (format t "(speed 0) (safety 3) (debug 3)~%")
+; (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)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/examples/profile.lisp Sat May 14 22:42:31 2016 +0000
@@ -0,0 +1,43 @@
+(ql:quickload 'bones)
+
+(require :sb-sprof)
+
+(load "examples/ggp.lisp")
+
+(in-package :bones)
+
+(defun reload ()
+ (let ((*standard-output* (make-broadcast-stream))
+ (*debug-io* (make-broadcast-stream))
+ (*terminal-io* (make-broadcast-stream))
+ (*error-output* (make-broadcast-stream)))
+ (asdf:load-system 'bones :force t)))
+
+
+(defun run-profile ()
+ (reload)
+
+ (format t "PROFILING -------------------------------~%")
+
+ (sb-sprof:profile-call-counts "BONES.WAM")
+
+ (sb-sprof:with-profiling (:max-samples 5000
+ :sample-interval 0.001
+ :report :flat
+ :loop nil)
+ (bones.wam::dfs-exhaust)))
+
+; (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)~%")
+; (declaim (optimize (speed 3) (safety 1) (debug 0)))
+; (run-test)
+
+(format t "~%~%====================================~%")
+(format t "(speed 3) (safety 0) (debug 0)~%")
+(declaim (optimize (speed 3) (safety 0) (debug 0)))
+(run-profile)
--- a/package.lisp Sat May 14 18:52:14 2016 +0000
+++ b/package.lisp Sat May 14 22:42:31 2016 +0000
@@ -23,6 +23,8 @@
#:circle-prepend-circle
#:circle-append
#:circle-append-circle
+ #:circle-next
+ #:circle-prev
#:circle-forward
#:circle-backward
#:circle-value
--- a/src/circle.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/circle.lisp Sat May 14 22:42:31 2016 +0000
@@ -227,7 +227,7 @@
(defun* circle-replace ((circle circle) value)
- (:returns :void)
+ (:returns circle)
(assert (not (circle-sentinel-p circle)) ()
"Cannot replace sentinel.")
;; L new R
@@ -235,8 +235,8 @@
(r (circle-next circle))
(new (make-circle :value value)))
(circle-tie l new)
- (circle-tie new r))
- (values))
+ (circle-tie new r)
+ new))
(defun* circle-backward-replace ((circle circle) value)
(:returns (or circle null))
--- a/src/wam/bytecode.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/wam/bytecode.lisp Sat May 14 22:42:31 2016 +0000
@@ -38,7 +38,12 @@
(+opcode-done+ 1)
(+opcode-try+ 2)
(+opcode-retry+ 2)
- (+opcode-trust+ 1)))
+ (+opcode-trust+ 1)
+
+ (+opcode-get-constant+ 3)
+ (+opcode-set-constant+ 2)
+ (+opcode-put-constant+ 3)
+ (+opcode-unify-constant+ 2)))
(defun* opcode-name ((opcode opcode))
@@ -72,7 +77,12 @@
(+opcode-done+ "DONE")
(+opcode-try+ "TRY")
(+opcode-retry+ "RETRY")
- (+opcode-trust+ "TRUST")))
+ (+opcode-trust+ "TRUST")
+
+ (+opcode-get-constant+ "GET-CONSTANT")
+ (+opcode-set-constant+ "SET-CONSTANT")
+ (+opcode-put-constant+ "PUT-CONSTANT")
+ (+opcode-unify-constant+ "UNIFY-CONSTANT")))
(defun* opcode-short-name ((opcode opcode))
(:returns string)
@@ -106,5 +116,10 @@
(+opcode-done+ "DONE")
(+opcode-try+ "TRYM")
(+opcode-retry+ "RTRY")
- (+opcode-trust+ "TRST")))
+ (+opcode-trust+ "TRST")
+ (+opcode-get-constant+ "GCON")
+ (+opcode-set-constant+ "SCON")
+ (+opcode-put-constant+ "PCON")
+ (+opcode-unify-constant+ "UCON")))
+
--- a/src/wam/compiler.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/wam/compiler.lisp Sat May 14 22:42:31 2016 +0000
@@ -49,6 +49,9 @@
(format stream (register-to-string object))))
+(defun* register-argument-p ((register register))
+ (eql (register-type register) :argument))
+
(defun* register-temporary-p ((register register))
(member (register-type register) '(:argument :local)))
@@ -770,6 +773,81 @@
arity)))
+;;;; Optimization
+;;; Optimization of the WAM instructions happens between the precompilation
+;;; phase and the rendering phase. We perform a number of passes over the
+;;; circle of instructions, doing one optimization each time.
+
+(defun optimize-get-constant (node constant register)
+ ;; 1. get_structure c/0, Ai -> get_constant c, Ai
+ (circle-replace node `(:get-constant ,constant ,register)))
+
+(defun optimize-put-constant (node constant register)
+ ;; 2. put_structure c/0, Ai -> put_constant c, Ai
+ (circle-replace node `(:put-constant ,constant ,register)))
+
+(defun optimize-set-constant (node constant register)
+ ;; 3. put_structure c/0, Xi *** WE ARE HERE
+ ;; ...
+ ;; set_value Xi -> set_constant c
+ (loop
+ :with previous = (circle-prev node)
+ ;; Search forward for the corresponding set-value instruction
+ :for n = (circle-forward-remove node) :then (circle-forward n)
+ :while n
+ :for (opcode . arguments) = (circle-value n)
+ :when (and (eql opcode :set-value-local)
+ (register= register (first arguments)))
+ :do
+ (circle-replace n `(:set-constant ,constant))
+ (return previous)))
+
+(defun optimize-unify-constant (node constant register)
+ ;; 4. unify_variable Xi -> unify_constant c
+ ;; ...
+ ;; get_structure c/0, Xi *** WE ARE HERE
+ (loop
+ ;; Search backward for the corresponding unify-variable instruction
+ :for n = (circle-backward node) :then (circle-backward n)
+ :while n
+ :for (opcode . arguments) = (circle-value n)
+ :when (and (eql opcode :unify-variable-local)
+ (register= register (first arguments)))
+ :do
+ (circle-replace n `(:unify-constant ,constant))
+ (return (circle-backward-remove node))))
+
+(defun optimize-constants (wam instructions)
+ ;; From the book and the erratum, there are four optimizations we can do for
+ ;; constants (0-arity structures).
+ (flet ((constant-p (functor)
+ (zerop (wam-functor-arity wam functor))))
+ (loop :for node = (circle-forward instructions) :then (circle-forward node)
+ :while node
+ :for (opcode . arguments) = (circle-value node)
+ :do
+ (match (circle-value node)
+
+ ((guard `(:put-structure-local ,functor ,register)
+ (constant-p functor))
+ (setf node
+ (if (register-argument-p register)
+ (optimize-put-constant node functor register)
+ (optimize-set-constant node functor register))))
+
+ ((guard `(:get-structure-local ,functor ,register)
+ (constant-p functor))
+ (setf node
+ (if (register-argument-p register)
+ (optimize-get-constant node functor register)
+ (optimize-unify-constant node functor register))))))
+ instructions))
+
+
+(defun optimize-instructions (wam instructions)
+ (optimize-constants wam instructions))
+
+
;;;; Rendering
;;; Rendering is the act of taking the friendly list-of-instructions format and
;;; actually converting it to raw-ass bytes and storing it in an array.
@@ -794,6 +872,10 @@
(:put-variable-stack +opcode-put-variable-stack+)
(:put-value-local +opcode-put-value-local+)
(:put-value-stack +opcode-put-value-stack+)
+ (:put-constant +opcode-put-constant+)
+ (:get-constant +opcode-get-constant+)
+ (:set-constant +opcode-set-constant+)
+ (:unify-constant +opcode-unify-constant+)
(:call +opcode-call+)
(:proceed +opcode-proceed+)
(:allocate +opcode-allocate+)
@@ -866,6 +948,7 @@
"
(multiple-value-bind (instructions permanent-variables)
(precompile-query wam query)
+ (optimize-instructions wam instructions)
(values
(render-query instructions)
permanent-variables)))
@@ -879,4 +962,5 @@
"
(multiple-value-bind (instructions functor arity)
(precompile-rules wam rules)
+ (optimize-instructions wam instructions)
(render-rules wam functor arity instructions)))
--- a/src/wam/constants.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/wam/constants.lisp Sat May 14 22:42:31 2016 +0000
@@ -97,8 +97,10 @@
;;;; Opcodes
+(define-constant +opcode-noop+ 0)
+
+
;;; Program
-(define-constant +opcode-noop+ 0)
(define-constant +opcode-get-structure-local+ 1)
(define-constant +opcode-unify-variable-local+ 2)
(define-constant +opcode-unify-variable-stack+ 3)
@@ -132,6 +134,11 @@
(define-constant +opcode-retry+ 25)
(define-constant +opcode-trust+ 26)
+;;; Constants
+(define-constant +opcode-get-constant+ 27)
+(define-constant +opcode-set-constant+ 28)
+(define-constant +opcode-put-constant+ 29)
+(define-constant +opcode-unify-constant+ 30)
;;;; Debug Config
(defparameter *off-by-one* nil)
--- a/src/wam/dump.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/wam/dump.lisp Sat May 14 22:42:31 2016 +0000
@@ -237,6 +237,28 @@
(pretty-arguments arguments)
(pretty-functor (first arguments) functor-list)))
+(defmethod instruction-details ((opcode (eql +opcode-get-constant+)) arguments functor-list)
+ (format nil "GCON~A ; X~A = CONSTANT ~A"
+ (pretty-arguments arguments)
+ (second arguments)
+ (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-constant+)) arguments functor-list)
+ (format nil "PCON~A ; X~A <- CONSTANT ~A"
+ (pretty-arguments arguments)
+ (second arguments)
+ (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-set-constant+)) arguments functor-list)
+ (format nil "SCON~A ; SET CONSTANT ~A"
+ (pretty-arguments arguments)
+ (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-unify-constant+)) arguments functor-list)
+ (format nil "UCON~A ; UNIFY CONSTANT ~A"
+ (pretty-arguments arguments)
+ (pretty-functor (first arguments) functor-list)))
+
(defun dump-code-store (wam code-store
&optional
@@ -330,9 +352,9 @@
(dump-labels wam)
(dump-code wam))
-(defun dump-wam-query-code (wam)
+(defun dump-wam-query-code (wam &optional (max +maximum-query-size+))
(with-slots (code) wam
- (dump-code-store wam code 0 +maximum-query-size+)))
+ (dump-code-store wam code 0 max)))
(defun dump-wam-code (wam)
(with-slots (code) wam
--- a/src/wam/types.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/wam/types.lisp Sat May 14 22:42:31 2016 +0000
@@ -45,7 +45,7 @@
(deftype opcode ()
- '(integer 0 26))
+ '(integer 0 30))
(deftype stack-frame-size ()
--- a/src/wam/vm.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/wam/vm.lisp Sat May 14 22:42:31 2016 +0000
@@ -59,9 +59,16 @@
(= (cell-value functor-cell-1)
(cell-value functor-cell-2)))
+(defun* constants-match-p ((constant-cell-1 cell)
+ (constant-cell-2 cell))
+ (:returns boolean)
+ "Return whether the two constant cells represent the same functor."
+ (= (cell-value constant-cell-1)
+ (cell-value constant-cell-2)))
+
;;;; "Ancillary" Functions
-(defun* backtrack! ((wam wam) (reason string))
+(defun* backtrack! ((wam wam))
(:returns :void)
"Backtrack after a failure.
@@ -69,7 +76,7 @@
"
(when *break-on-fail*
- (break "FAIL: ~A" reason))
+ (break "Backtracked."))
(if (wam-backtrack-pointer-unset-p wam)
(setf (wam-fail wam) t)
(setf (wam-program-counter wam) (wam-stack-choice-bp wam)
@@ -157,27 +164,39 @@
(when (not (= d1 d2))
(let ((cell-1 (wam-store-cell wam d1))
(cell-2 (wam-store-cell wam d2)))
- (if (or (cell-reference-p cell-1)
- (cell-reference-p cell-2))
+ (cond
;; If at least one is a reference, bind them.
;;
- ;; We know that any references we see here will be unbound,
- ;; because we deref'ed them above.
- (bind! wam d1 d2)
- ;; Otherwise we're looking at two structures (hopefully, lol).
- (let* ((structure-1-addr (cell-value cell-1)) ; find where they
- (structure-2-addr (cell-value cell-2)) ; start on the heap
- (functor-1 (wam-store-cell wam structure-1-addr)) ; grab the
- (functor-2 (wam-store-cell wam structure-2-addr))) ; functors
- (if (functors-match-p functor-1 functor-2)
- ;; If the functors match, push their pairs of arguments onto
- ;; the stack to be unified.
- (loop :with arity = (cdr (wam-functor-lookup wam (cell-value functor-1)))
- :for i :from 1 :to arity :do
- (wam-unification-stack-push! wam (+ structure-1-addr i))
- (wam-unification-stack-push! wam (+ structure-2-addr i)))
- ;; Otherwise we're hosed.
- (backtrack! wam "Functors don't match in unify!")))))))))
+ ;; We know that any references we see here will be unbound, because
+ ;; we deref'ed them above.
+ ((or (cell-reference-p cell-1) (cell-reference-p cell-2))
+ (bind! wam d1 d2))
+
+ ;; Otherwise if they're both constants, make sure they match.
+ ((and (cell-constant-p cell-1) (cell-constant-p cell-2))
+ (when (not (constants-match-p cell-1 cell-2))
+ (backtrack! wam)))
+
+ ;; Otherwise if they're both structure cells, make sure they match
+ ;; and then schedule their subterms to be unified.
+ ((and (cell-structure-p cell-1) (cell-structure-p cell-2))
+ (let* ((structure-1-addr (cell-value cell-1)) ; find where they
+ (structure-2-addr (cell-value cell-2)) ; start on the heap
+ (functor-1 (wam-store-cell wam structure-1-addr)) ; grab the
+ (functor-2 (wam-store-cell wam structure-2-addr))) ; functors
+ (if (functors-match-p functor-1 functor-2)
+ ;; If the functors match, push their pairs of arguments onto
+ ;; the stack to be unified.
+ (loop :with arity = (wam-functor-arity wam (cell-value functor-1))
+ :for i :from 1 :to arity :do
+ (wam-unification-stack-push! wam (+ structure-1-addr i))
+ (wam-unification-stack-push! wam (+ structure-2-addr i)))
+ ;; Otherwise we're hosed.
+ (backtrack! wam))))
+
+ ;; Otherwise we're looking at two different kinds of cells, and are
+ ;; just totally hosed. Backtrack.
+ (t (backtrack! wam))))))))
;;;; Instruction Definition
@@ -329,9 +348,8 @@
(if (matching-functor-p functor-cell functor)
(setf mode :read
s (1+ functor-address))
- (backtrack! wam "Functors don't match in get-struct"))))
- (t (backtrack! wam (format nil "get-struct on a non-ref/struct cell ~A"
- (cell-aesthetic cell))))))))
+ (backtrack! wam))))
+ (t (backtrack! wam))))))
(define-instructions (%unify-variable-local %unify-variable-stack)
((wam wam)
@@ -377,7 +395,8 @@
(wam-program-counter wam) ; jump
target)
- (backtrack! wam "Tried to call unknown procedure."))))
+ ;; Trying to call an unknown procedure.
+ (backtrack! wam))))
(define-instruction %proceed ((wam wam))
(setf (wam-program-counter wam) ; P <- CP
@@ -462,6 +481,47 @@
(wam-stack-choice-h wam old-b)))))
+;;;; Constant Instructions
+(defun* %%match-constant ((wam wam)
+ (constant functor-index)
+ (address store-index))
+ (let* ((addr (deref wam address))
+ (cell (wam-store-cell wam addr)))
+ (cond
+ ((cell-reference-p cell)
+ (setf (wam-store-cell wam addr)
+ (make-cell-constant constant))
+ (trail! wam addr))
+
+ ((cell-constant-p cell)
+ (when (not (= constant (cell-value cell)))
+ (backtrack! wam)))
+
+ (t
+ (backtrack! wam)))))
+
+(define-instruction %put-constant ((wam wam)
+ (constant functor-index)
+ (register register-index))
+ (setf (wam-local-register wam register)
+ (make-cell-constant constant)))
+
+(define-instruction %get-constant ((wam wam)
+ (constant functor-index)
+ (register register-index))
+ (%%match-constant wam constant register))
+
+(define-instruction %set-constant ((wam wam)
+ (constant functor-index))
+ (wam-heap-push! wam (make-cell-constant constant)))
+
+(define-instruction %unify-constant ((wam wam)
+ (constant functor-index))
+ (ecase (wam-mode wam)
+ (:read (%%match-constant wam constant (wam-subterm wam)))
+ (:write (wam-heap-push! wam (make-cell-constant constant)))))
+
+
;;;; Running
(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
"Expand into a call of the appropriate machine instruction.
@@ -502,15 +562,15 @@
((cell-null-p cell) "NULL?!")
((cell-reference-p cell) (extract-var (cell-value cell)))
((cell-structure-p cell) (recur (cell-value cell)))
+ ((cell-constant-p cell)
+ (wam-functor-symbol wam (cell-value cell)))
((cell-functor-p cell)
(destructuring-bind (functor . arity)
(wam-functor-lookup wam (cell-value cell))
- (if (zerop arity)
- functor
- (list* functor
- (mapcar #'recur
- (range (+ address 1)
- (+ address arity 1)))))))
+ (list* functor
+ (mapcar #'recur
+ (range (+ address 1)
+ (+ address arity 1))))))
(t (error "What to heck is this?"))))))
(mapcar #'recur addresses))))
@@ -558,6 +618,11 @@
(+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))
+ ;; Constant
+ (+opcode-put-constant+ (instruction %put-constant 2))
+ (+opcode-get-constant+ (instruction %get-constant 2))
+ (+opcode-set-constant+ (instruction %set-constant 1))
+ (+opcode-unify-constant+ (instruction %unify-constant 1))
;; Choice
(+opcode-try+ (instruction %try 1))
(+opcode-retry+ (instruction %retry 1))
@@ -578,7 +643,7 @@
(+opcode-done+
(if (funcall done-thunk)
(return-from run)
- (backtrack! wam "done-function returned false"))))
+ (backtrack! wam))))
;; Only increment the PC when we didn't backtrack
(if (wam-backtracked wam)
(setf (wam-backtracked wam) nil)
--- a/src/wam/wam.lisp Sat May 14 18:52:14 2016 +0000
+++ b/src/wam/wam.lisp Sat May 14 22:42:31 2016 +0000
@@ -447,7 +447,9 @@
(wam-truncate-heap! wam)
(wam-truncate-trail! wam)
(wam-truncate-unification-stack! wam)
- (wam-reset-local-registers! wam)
+ (policy-cond:policy-if (>= debug 2)
+ (wam-reset-local-registers! wam)
+ nil) ; fuck it
(setf (wam-program-counter wam) 0
(wam-continuation-pointer wam) 0
(wam-environment-pointer wam) +stack-start+