# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1463265751 0
# Node ID 27f037427ad30c4fd39ecfaf3195ec79115a96be
# Parent  0b8e6d6401c2908e21b3ec65a162bf73ec044b84
Add the first optimization pass: constants

diff -r 0b8e6d6401c2 -r 27f037427ad3 Makefile
--- 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)'
diff -r 0b8e6d6401c2 -r 27f037427ad3 bones.asd
--- 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)
 
diff -r 0b8e6d6401c2 -r 27f037427ad3 examples/bench.lisp
--- 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)))
diff -r 0b8e6d6401c2 -r 27f037427ad3 examples/profile.lisp
--- /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)
diff -r 0b8e6d6401c2 -r 27f037427ad3 package.lisp
--- 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
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/circle.lisp
--- 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))
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/wam/bytecode.lisp
--- 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")))
+
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/wam/compiler.lisp
--- 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)))
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/wam/constants.lisp
--- 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)
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/wam/dump.lisp
--- 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
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/wam/types.lisp
--- 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 ()
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/wam/vm.lisp
--- 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)
diff -r 0b8e6d6401c2 -r 27f037427ad3 src/wam/wam.lisp
--- 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+