hg.stevelosh.com > temperance

src/wam/compiler/6-optimization.lisp @ ba96e98a1d54 

Add precompilation of static queries at compile time

Imagine a function like this:

    (defun legal-moves ()
      (query (legal ?who ?move)))

The argument to `query` there is constant, so we can compile it into WAM
bytecode once, when the Lisp function around it is compiled.  Then running the
query doesn't need to touch the Bones compiler -- it can just load the bytecode
from an array and first up the VM loop.

This saves a lot of time (and consing) compared to compiling the same query over
and over at runtime.
author Steve Losh <steve@stevelosh.com>
date Sun, 17 Jul 2016 16:49:06 +0000
parents 8a247663fec5
children 3325913a9b16 
(in-package #:bones.wam)

;;;; ,,--.     .                    .
;;;; |`, | ,-. |- . ,-,-. . ,_, ,-. |- . ,-. ,-.
;;;; |   | | | |  | | | | |  /  ,-| |  | | | | |
;;;; `---' |-' `' ' ' ' ' ' '"' `-^ `' ' `-' ' '
;;;;       |
;;;;       '

;;; 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-subterm-constant-query (node constant register)
  ;; 3. put_structure c/0, Xi                     *** WE ARE HERE
  ;;    ...
  ;;    subterm_value Xi          -> subterm_constant c
  (loop
    :with previous = (circle-prev node)
    ;; Search 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 :subterm-value-local)
               (register= register (first arguments)))
    :do
    (circle-replace n `(:subterm-constant ,constant))
    (return previous)))

(defun optimize-subterm-constant-program (node constant register)
  ;; 4. subterm_variable Xi       -> subterm_constant c
  ;;    ...
  ;;    get_structure c/0, Xi                     *** WE ARE HERE
  (loop
    ;; Search backward for the corresponding subterm-variable instruction
    :for n = (circle-backward node) :then (circle-backward n)
    :while n
    :for (opcode . arguments) = (circle-value n)
    :when (and (eql opcode :subterm-variable-local)
               (register= register (first arguments)))
    :do
    (circle-replace n `(:subterm-constant ,constant))
    (return (circle-backward-remove node))))


(defun optimize-constants (instructions)
  ;; From the book and the erratum, there are four optimizations we can do for
  ;; constants (0-arity structures).

  (flet ((optimize-put (node functor register)
           (if (register-argument-p register)
             (optimize-put-constant node functor register)
             (optimize-subterm-constant-query node functor register)))
         (optimize-get (node functor register)
           (if (register-argument-p register)
             (optimize-get-constant node functor register)
             (optimize-subterm-constant-program node functor register))))
    (loop
      :for node = (circle-forward instructions) :then (circle-forward node)
      :while node :do
      (destructuring-bind (opcode . arguments) (circle-value node)
        (when (member opcode '(:put-structure :get-structure))
          (destructuring-bind (functor arity register) arguments
            (when (zerop arity)
              (setf node
                    (case opcode
                      (:put-structure (optimize-put node functor register))
                      (:get-structure (optimize-get node functor register))))))))))
  instructions)


(defun optimize-void-runs (instructions)
  ;; We can optimize runs of N (:[unify/set]-void 1) instructions into a single
  ;; one that does all N at once.
  (loop
    :for node = (circle-forward instructions) :then (circle-forward node)
    :while node
    :for opcode = (car (circle-value node))
    :when (or (eq opcode :set-void)
              (eq opcode :subterm-void))
    :do
    (loop
      :with beginning = (circle-backward node)
      :for run-node = node :then (circle-forward run-node)
      :for run-opcode = (car (circle-value run-node))
      :while (eq opcode run-opcode)
      :do (circle-remove run-node)
      :sum 1 :into run-length fixnum ; lol
      :finally
      (progn
        (setf node (circle-forward beginning))
        (circle-insert-after beginning
                             `(,opcode ,run-length)))))
  instructions)


(defun optimize-instructions (instructions)
  (->> instructions
    (optimize-constants)
    (optimize-void-runs)))