src/wam/compiler/1-parsing.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 |
6c90a65137d9 |
| children |
(none) |
(in-package #:bones.wam)
;;;; .-,--.
;;;; '|__/ ,-. ,-. ,-. . ,-. ,-.
;;;; ,| ,-| | `-. | | | | |
;;;; `' `-^ ' `-' ' ' ' `-|
;;;; ,|
;;;; `'
; todo functor -> fname
(defstruct node)
(defstruct (top-level-node (:include node))
(functor nil :type symbol)
(arity 0 :type arity)
(arguments nil :type list))
(defstruct (vanilla-node (:include node)
(:conc-name node-))
;; The register allocated to store this node.
(register nil :type (or null register)))
(defstruct (structure-node (:include vanilla-node)
(:conc-name node-))
(functor nil :type symbol)
(arity 0 :type arity)
(arguments nil :type list))
(defstruct (variable-node (:include vanilla-node)
(:conc-name node-))
(variable nil :type symbol))
(defstruct (argument-variable-node (:include variable-node)
(:conc-name node-))
;; The register that actually holds the variable (NOT the argument register).
(secondary-register nil :type (or null register)))
(defstruct (list-node (:include vanilla-node)
(:conc-name node-))
(head (error "Head argument required") :type node)
(tail (error "Head argument required") :type node))
(defstruct (lisp-object-node (:include vanilla-node)
(:conc-name node-))
(object nil :type t))
(defgeneric node-children (node)
(:documentation
"Return the children of the given node.
Presumably these will need to be traversed when allocating registers."))
(defmethod node-children ((node vanilla-node))
(list))
(defmethod node-children ((node top-level-node))
(top-level-node-arguments node))
(defmethod node-children ((node structure-node))
(node-arguments node))
(defmethod node-children ((node list-node))
(list (node-head node) (node-tail node)))
(defun nil-node-p (node)
"Return whether the given node is the magic nil/0 constant."
(and (typep node 'structure-node)
(eql (node-functor node) nil)
(zerop (node-arity node))))
(defparameter *dump-node-indent* 0)
(defun print-node-register (node stream &optional space-before)
(when (slot-boundp node 'register)
(format stream (if space-before " ~A =" "~A = ") (node-register node))))
(defun print-node-secondary-register (node stream &optional space-before)
(when (slot-boundp node 'secondary-register)
(format stream
(if space-before " ~A =" "~A = ")
(node-secondary-register node))))
(defgeneric dump-node (node))
(defmethod dump-node ((node node))
(format t "~VAAN NODE" *dump-node-indent* ""))
(defmethod dump-node ((node variable-node))
(format t "~VA#<VAR" *dump-node-indent* "")
(print-node-register node t t)
(format t " ~S>" (node-variable node)))
(defmethod dump-node ((node argument-variable-node))
(format t "~VA#<VAR" *dump-node-indent* "")
(print-node-register node t t)
(print-node-secondary-register node t t)
(format t " ~S>" (node-variable node)))
(defmethod dump-node ((node structure-node))
(format t "~VA#<STRUCT " *dump-node-indent* "")
(print-node-register node t)
(format t "~A/~D" (node-functor node) (node-arity node))
(let ((*dump-node-indent* (+ *dump-node-indent* 4)))
(dolist (a (node-arguments node))
(terpri)
(dump-node a)))
(format t ">"))
(defmethod dump-node ((node list-node))
(format t "~VA#<LIST" *dump-node-indent* "")
(print-node-register node t t)
(let ((*dump-node-indent* (+ *dump-node-indent* 4)))
(loop :for element = node :then tail
:while (typep element 'list-node)
:for head = (node-head element)
:for tail = (node-tail element)
:do (progn (terpri) (dump-node head))
:finally (when (not (nil-node-p element))
(format t "~%~VA.~%" *dump-node-indent* "")
(dump-node element))))
(format t ">"))
(defmethod dump-node ((node lisp-object-node))
(format t "~VA#<LISP OBJECT " *dump-node-indent* "")
(print-node-register node t)
(format t "~A>" (lisp-object-to-string (node-object node))))
(defmethod dump-node ((node top-level-node))
(with-slots (functor arity arguments) node
(format t "#<~A/~D" functor arity)
(let ((*dump-node-indent* 4))
(dolist (n arguments)
(terpri)
(dump-node n)))
(format t ">")))
(defmethod print-object ((node node) stream)
(let ((*standard-output* stream))
(dump-node node)))
(defun parse-list (contents)
(if contents
(make-list-node :head (parse (car contents))
:tail (parse-list (cdr contents)))
(make-structure-node :functor nil
:arity 0
:arguments ())))
(defun parse-list* (contents)
(destructuring-bind (next . remaining) contents
(if (null remaining)
(parse next)
(make-list-node :head (parse next)
:tail (parse-list* remaining)))))
(defun parse (term &optional top-level-argument)
(cond
((variablep term)
(if top-level-argument
(make-argument-variable-node :variable term)
(make-variable-node :variable term)))
((symbolp term)
(parse (list term))) ; c/0 -> (c/0)
((consp term)
(destructuring-bind (functor . arguments) term
(when (not (symbolp functor))
(error
"Cannot parse term ~S because ~S is not a valid functor."
term functor))
(case functor
(list (parse-list arguments))
(list* (parse-list* arguments))
(t (make-structure-node :functor functor
:arity (length arguments)
:arguments (mapcar #'parse arguments))))))
((numberp term)
(make-lisp-object-node :object term))
(t (error "Cannot parse term ~S into a Prolog term." term))))
(defun parse-top-level (term)
(typecase term
(symbol (parse-top-level (list term))) ; c/0 -> (c/0)
(cons (destructuring-bind (functor . arguments) term
(when (not (symbolp functor))
(error
"Cannot parse top-level term ~S because ~S is not a valid functor."
term functor))
(make-top-level-node :functor functor
:arity (length arguments)
:arguments (mapcar (lambda (a) (parse a t))
arguments))))
(t (error "Cannot parse top-level term ~S into a Prolog term." term))))