# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1468536173 0
# Node ID 100ba597fd8575e364a2ec36f754ee6d0129057f
# Parent  5c914fbcb042c256449672360b6e6a21f2da2b29
Add a beast of a macro to clean up/optimize the hot loop

diff -r 5c914fbcb042 -r 100ba597fd85 .lispwords
--- a/.lispwords	Thu Jul 14 13:30:57 2016 +0000
+++ b/.lispwords	Thu Jul 14 22:42:53 2016 +0000
@@ -8,3 +8,4 @@
 (1 rule)
 (0 push-logic-frame-with)
 (1 cell-typecase)
+(1 opcode-case)
diff -r 5c914fbcb042 -r 100ba597fd85 package.lisp
--- a/package.lisp	Thu Jul 14 13:30:57 2016 +0000
+++ b/package.lisp	Thu Jul 14 22:42:53 2016 +0000
@@ -16,6 +16,7 @@
     #:symbolize
     #:dis
     #:megabytes
+    #:ecase/tree
     #:gethash-or-init
     #:define-lookup
     #:queue
diff -r 5c914fbcb042 -r 100ba597fd85 src/utils.lisp
--- a/src/utils.lisp	Thu Jul 14 13:30:57 2016 +0000
+++ b/src/utils.lisp	Thu Jul 14 22:42:53 2016 +0000
@@ -222,3 +222,21 @@
           (:returns ,value-type)
           ,documentation
           (aref ,table ,key))))))
+
+
+;;;; ecase/tree
+;;; See http://www.foldr.org/~michaelw/log/programming/lisp/icfp-contest-2006-vm
+
+(defmacro ecase/tree (keyform &body cases)
+  (labels ((%case/tree (keyform cases)
+             (if (<= (length cases) 4)
+                 `(ecase ,keyform ,@cases)
+                 (loop for rest-cases on cases
+                       repeat (truncate (length cases) 2)
+                       collect (first rest-cases) into first-half
+                       finally (return `(if (< ,keyform ,(caar rest-cases))
+                                            ,(%case/tree keyform first-half)
+                                            ,(%case/tree keyform rest-cases)))))))
+    (let (($keyform (gensym "CASE/TREE-")))
+      `(let ((,$keyform ,keyform))
+         ,(%case/tree $keyform (sort (copy-list cases) #'< :key #'first))))))
diff -r 5c914fbcb042 -r 100ba597fd85 src/wam/vm.lisp
--- a/src/wam/vm.lisp	Thu Jul 14 13:30:57 2016 +0000
+++ b/src/wam/vm.lisp	Thu Jul 14 22:42:53 2016 +0000
@@ -433,7 +433,7 @@
      (argument register-index))
   (%wam-copy-to-register% wam register argument))
 
-(define-instructions (%get-value-local %get-value-stack t)
+(define-instructions (%get-value-local %get-value-stack)
     ((wam wam)
      (register register-index)
      (argument register-index))
@@ -539,7 +539,7 @@
   (%%dynamic-procedure-call wam t))
 
 
-(define-instruction (%proceed t) ((wam wam))
+(define-instruction (%proceed) ((wam wam))
   (setf (wam-program-counter wam) ; P <- CP
         (wam-continuation-pointer wam)))
 
@@ -682,19 +682,6 @@
 
 
 ;;;; Running
-(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
-  "Expand into a call of the appropriate machine instruction.
-
-  `pc` should be a safe place representing the program counter.
-
-  `code-store` should be a safe place representing the instructions.
-
-  "
-  `(,instruction ,wam
-    ,@(loop :for i :from 1 :to number-of-arguments
-            :collect `(aref ,code-store (+ ,pc ,i)))))
-
-
 (defun extract-things (wam addresses)
   "Extract the things at the given store addresses.
 
@@ -740,87 +727,146 @@
     (weave vars results)))
 
 
-(defun* run ((wam wam) (done-thunk function))
-  (with-accessors ((pc wam-program-counter)) wam
-    (let ((code (wam-code wam)))
-      (macrolet ((instruction (inst args)
-                   `(instruction-call wam ,inst code pc ,args)))
-        (loop
-          :with increment-pc = t
-          :while (and (not (wam-fail wam)) ; failure
-                      (not (= pc +code-sentinel+))) ; finished
-          :for opcode = (aref code pc) ; todo switch this to wam-code-word...
-          :do
-          (progn
-            (when *step*
-              (dump) ; todo: make this saner
-              (break "About to execute instruction at ~4,'0X" pc))
-            (ecase opcode
-              ;; Query
-              (#.+opcode-put-structure+          (instruction %put-structure 2))
-              (#.+opcode-put-variable-local+     (instruction %put-variable-local 2))
-              (#.+opcode-put-variable-stack+     (instruction %put-variable-stack 2))
-              (#.+opcode-put-value-local+        (instruction %put-value-local 2))
-              (#.+opcode-put-value-stack+        (instruction %put-value-stack 2))
-              ;; Program
-              (#.+opcode-get-structure+          (instruction %get-structure 2))
-              (#.+opcode-get-variable-local+     (instruction %get-variable-local 2))
-              (#.+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))
-              ;; Subterm
-              (#.+opcode-subterm-variable-local+ (instruction %subterm-variable-local 1))
-              (#.+opcode-subterm-variable-stack+ (instruction %subterm-variable-stack 1))
-              (#.+opcode-subterm-value-local+    (instruction %subterm-value-local 1))
-              (#.+opcode-subterm-value-stack+    (instruction %subterm-value-stack 1))
-              (#.+opcode-subterm-void+           (instruction %subterm-void 1))
-              ;; Constant
-              (#.+opcode-put-constant+           (instruction %put-constant 2))
-              (#.+opcode-get-constant+           (instruction %get-constant 2))
-              (#.+opcode-subterm-constant+       (instruction %subterm-constant 1))
-              ;; List
-              (#.+opcode-put-list+               (instruction %put-list 1))
-              (#.+opcode-get-list+               (instruction %get-list 1))
-              ;; Choice
-              (#.+opcode-try+                    (instruction %try 1))
-              (#.+opcode-retry+                  (instruction %retry 1))
-              (#.+opcode-trust+                  (instruction %trust 0))
-              (#.+opcode-cut+                    (instruction %cut 0))
-              ;; Control
-              (#.+opcode-allocate+               (instruction %allocate 1))
-              (#.+opcode-deallocate+             (instruction %deallocate 0))
-              ;; need to skip the PC increment for PROC/CALL/JUMP/DONE
-              ;; TODO: this is (still) still ugly
-              (#.+opcode-proceed+
-               (instruction %proceed 0)
-               (setf increment-pc nil))
-              (#.+opcode-jump+
-               (instruction %jump 1)
-               (setf increment-pc nil))
-              (#.+opcode-call+
-               (instruction %call 1)
-               (setf increment-pc nil))
-              (#.+opcode-dynamic-jump+
-               (instruction %dynamic-jump 0)
-               (setf increment-pc nil))
-              (#.+opcode-dynamic-call+
-               (instruction %dynamic-call 0)
-               (setf increment-pc nil))
-              (#.+opcode-done+
-               (if (funcall done-thunk)
-                 (return-from run)
-                 (backtrack! wam))))
-            ;; Only increment the PC when we didn't backtrack.
-            ;;
-            ;; If we backtracked, the PC will have been filled in from the
-            ;; choice point.
-            (when (and increment-pc (not (wam-backtracked wam)))
-              (incf pc (instruction-size opcode)))
-            (setf (wam-backtracked wam) nil
-                  increment-pc t)
-            (when (>= pc (wam-code-pointer wam))
-              (error "Fell off the end of the program code store."))))))
-    (values)))
+(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
+  "Expand into a call of the appropriate machine instruction.
+
+  `pc` should be a safe place representing the program counter.
+
+  `code-store` should be a safe place representing the instructions.
+
+  "
+  `(,instruction ,wam
+    ,@(loop :for i :from 1 :to number-of-arguments
+            :collect `(aref ,code-store (+ ,pc ,i)))))
+
+(defmacro opcode-case ((wam code opcode-place) &rest clauses)
+  "Handle each opcode in the main VM run loop.
+
+  Each clause should be of the form:
+
+     (opcode &key instruction (increment-pc t) raw)
+
+  `opcode` must be a constant by macroexpansion time.
+
+  `instruction` should be the corresponding instruction function to call.  If
+  given it will be expanded with the appropriate `aref`s to get its arguments
+  from the code store.
+
+  If `increment-pc` is true an extra `incf` form will be added after the
+  instruction to handle incrementing the program counter (but only if
+  backtracking didn't happen).
+
+  If a `raw` argument is given it will be spliced in verbatim.
+
+  "
+  ;; This macro is pretty nasty, but it's better than trying to write it all out
+  ;; by hand.
+  ;;
+  ;; The main idea is that we want to be able to nicely specify all our
+  ;; opcode/instruction pairs in `run`.  Furthermore, we need to handle
+  ;; everything really efficiently because `run` is the hot loop of the entire
+  ;; VM.  It is the #1 function you'll see when profiling.
+  ;;
+  ;; This macro handles expanding each case clause into the appropriate `aref`s
+  ;; and such, as well as updating the program counter.  The instruction size of
+  ;; each opcode is looked up at macroexpansion time to save cycles.
+  ;;
+  ;; For example, a clause like this:
+  ;;
+  ;;     (opcode-case (wam code opcode)
+  ;;       ;; ...
+  ;;       (#.+opcode-put-structure+ :instruction %put-structure))
+  ;;
+  ;; will get expanded into something like this:
+  ;;
+  ;;     (ecase/tree opcode
+  ;;       ;; ...
+  ;;       (+opcode-put-structure+ (%put-structure wam (aref code (+ program-counter 1))
+  ;;                                                   (aref code (+ program-counter 2)))
+  ;;                               (incf program-counter 3)))
+  (flet
+      ((parse-opcode-clause (clause)
+         (destructuring-bind (opcode &key instruction (increment-pc t) raw)
+             clause
+           (let ((size (instruction-size opcode)))
+             `(,opcode
+               ,(when instruction
+                  `(instruction-call ,wam
+                    ,instruction
+                    ,code
+                    (wam-program-counter ,wam)
+                    ,(1- size)))
+               ,(when increment-pc
+                  `(when (not (wam-backtracked ,wam))
+                    (incf (wam-program-counter ,wam) ,size)))
+               ,raw)))))
+    `(ecase/tree ,opcode-place
+      ,@(mapcar #'parse-opcode-clause clauses))))
+
+
+(defun* run ((wam wam) (done-thunk function) &optional (step *step*))
+  (loop
+    :with code = (wam-code wam)
+    :until (or (wam-fail wam) ; failure
+               (= (wam-program-counter wam) +code-sentinel+)) ; finished
+    :for opcode = (aref (wam-code wam) (wam-program-counter wam))
+    :do (progn
+          (when step
+            (dump)
+            (break "About to execute instruction at ~4,'0X" (wam-program-counter wam)))
+
+          (opcode-case (wam code opcode)
+            ;; Query
+            (#.+opcode-put-structure+       :instruction %put-structure)
+            (#.+opcode-put-variable-local+  :instruction %put-variable-local)
+            (#.+opcode-put-variable-stack+  :instruction %put-variable-stack)
+            (#.+opcode-put-value-local+     :instruction %put-value-local)
+            (#.+opcode-put-value-stack+     :instruction %put-value-stack)
+            ;; Program
+            (#.+opcode-get-structure+       :instruction %get-structure)
+            (#.+opcode-get-variable-local+  :instruction %get-variable-local)
+            (#.+opcode-get-variable-stack+  :instruction %get-variable-stack)
+            (#.+opcode-get-value-local+     :instruction %get-value-local)
+            (#.+opcode-get-value-stack+     :instruction %get-value-stack)
+            ;; Subterm
+            (#.+opcode-subterm-variable-local+  :instruction %subterm-variable-local)
+            (#.+opcode-subterm-variable-stack+  :instruction %subterm-variable-stack)
+            (#.+opcode-subterm-value-local+     :instruction %subterm-value-local)
+            (#.+opcode-subterm-value-stack+     :instruction %subterm-value-stack)
+            (#.+opcode-subterm-void+            :instruction %subterm-void)
+            ;; Constant
+            (#.+opcode-put-constant+      :instruction %put-constant)
+            (#.+opcode-get-constant+      :instruction %get-constant)
+            (#.+opcode-subterm-constant+  :instruction %subterm-constant)
+            ;; List
+            (#.+opcode-put-list+  :instruction %put-list)
+            (#.+opcode-get-list+  :instruction %get-list)
+            ;; Choice
+            (#.+opcode-try+    :instruction %try)
+            (#.+opcode-retry+  :instruction %retry)
+            (#.+opcode-trust+  :instruction %trust)
+            (#.+opcode-cut+    :instruction %cut)
+            ;; Control
+            (#.+opcode-allocate+      :instruction %allocate)
+            (#.+opcode-deallocate+    :instruction %deallocate)
+            (#.+opcode-proceed+       :instruction %proceed      :increment-pc nil)
+            (#.+opcode-jump+          :instruction %jump         :increment-pc nil)
+            (#.+opcode-call+          :instruction %call         :increment-pc nil)
+            (#.+opcode-dynamic-jump+  :instruction %dynamic-jump :increment-pc nil)
+            (#.+opcode-dynamic-call+  :instruction %dynamic-call :increment-pc nil)
+            ;; Final
+            (#.+opcode-done+
+             :increment-pc nil
+             :raw (if (funcall done-thunk)
+                    (return-from run)
+                    (backtrack! wam))))
+
+          (setf (wam-backtracked wam) nil)
+
+          (when (>= (wam-program-counter wam)
+                    (wam-code-pointer wam))
+            (error "Fell off the end of the program code store."))))
+  (values))
 
 (defun* run-query ((wam wam)
                    term