hg.stevelosh.com > temperance

src/wam/compiler/3-flattening.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 62c76cc272e7
children (none) 
(in-package #:bones.wam)

;;;; .-,--' .      .  .
;;;;  \|__  |  ,-. |- |- ,-. ,-. . ,-. ,-.
;;;;   |    |  ,-| |  |  |-' | | | | | | |
;;;;  `'    `' `-^ `' `' `-' ' ' ' ' ' `-|
;;;;                                    ,|
;;;;                                    `'

;;; "Flattening" is the process of turning a parse tree (with register
;;; assignments) into a flat list of nodes, which will then be turned into
;;; a series of instructions.
;;;
;;; The order of this list depends on whether we're compiling a query term or
;;; a program term.
;;;
;;; Turns:
;;;
;;;   X0 <- p(X1, X2)
;;;   X1 <- A
;;;   X2 <- q(X1, X3)
;;;   X3 <- B
;;;
;;; into something like:
;;;
;;;   X2 <- q(X1, X3)
;;;   X0 <- p(X1, X2)


(defstruct (register-assignment
             (:conc-name assignment-))
  (register (required) :type register))


(defstruct (structure-assignment (:include register-assignment)
                                 (:conc-name assignment-))
  (functor nil :type symbol)
  (arity 0 :type arity)
  (arguments () :type list))

(defstruct (argument-variable-assignment (:include register-assignment)
                                         (:conc-name assignment-))
  (target (required) :type register))

(defstruct (list-assignment (:include register-assignment)
                            (:conc-name assignment-))
  (head (required) :type register)
  (tail (required) :type register))

(defstruct (lisp-object-assignment (:include register-assignment)
                                   (:conc-name assignment-))
  (object nil :type t))


(defmethod print-object ((assignment structure-assignment) stream)
  (print-unreadable-object (assignment stream :type nil :identity nil)
    (format stream "~A = ~A/~D(~{~A~^, ~})"
            (register-to-string (assignment-register assignment))
            (assignment-functor assignment)
            (assignment-arity assignment)
            (mapcar #'register-to-string (assignment-arguments assignment)))))

(defmethod print-object ((assignment argument-variable-assignment) stream)
  (print-unreadable-object (assignment stream :type nil :identity nil)
    (format stream "~A = ~A"
            (register-to-string (assignment-register assignment))
            (register-to-string (assignment-target assignment)))))

(defmethod print-object ((assignment list-assignment) stream)
  (print-unreadable-object (assignment stream :type nil :identity nil)
    (format stream "~A = [~A | ~A]"
            (register-to-string (assignment-register assignment))
            (register-to-string (assignment-head assignment))
            (register-to-string (assignment-tail assignment)))))

(defmethod print-object ((assignment lisp-object-assignment) stream)
  (print-unreadable-object (assignment stream :type nil :identity nil)
    (format stream "~A = ~A"
            (register-to-string (assignment-register assignment))
            (lisp-object-to-string (assignment-object assignment)))))


(defgeneric node-flatten (node))

(defmethod node-flatten (node)
  nil)

(defmethod node-flatten ((node structure-node))
  (values (make-structure-assignment
            :register (node-register node)
            :functor (node-functor node)
            :arity (node-arity node)
            :arguments (mapcar #'node-register (node-arguments node)))))

(defmethod node-flatten ((node argument-variable-node))
  (values (make-argument-variable-assignment
            :register (node-register node)
            :target (node-secondary-register node))))

(defmethod node-flatten ((node list-node))
  (values (make-list-assignment
            :register (node-register node)
            :head (node-register (node-head node))
            :tail (node-register (node-tail node)))))

(defmethod node-flatten ((node lisp-object-node))
  (values (make-lisp-object-assignment
            :register (node-register node)
            :object (node-object node))))


(defun flatten-breadth-first (tree)
  (let ((results nil))
    (recursively ((node tree))
      (when-let (assignment (node-flatten node))
        (push assignment results))
      (mapc #'recur (node-children node)))
    (nreverse results)))

(defun flatten-depth-first-post-order (tree)
  (let ((results nil))
    (recursively ((node tree))
      (mapc #'recur (node-children node))
      (when-let (assignment (node-flatten node))
        (push assignment results)))
    (nreverse results)))


(defun flatten-query (tree)
  (flatten-depth-first-post-order tree))

(defun flatten-program (tree)
  (flatten-breadth-first tree))