--- a/bones.asd Sat Mar 26 12:21:56 2016 +0000
+++ b/bones.asd Sat Mar 26 19:19:07 2016 +0000
@@ -11,6 +11,7 @@
:depends-on (#:defstar
#:optima
#:trivial-types
+ #:cl-arrows
#:fare-quasiquote-optima
#:fare-quasiquote-readtable)
@@ -21,6 +22,7 @@
:components ((:file "paip")
(:module "wam"
:components ((:file "constants")
+ (:file "topological-sort")
(:file "cells")
(:file "wam")
(:file "instructions")
--- a/src/wam/compile.lisp Sat Mar 26 12:21:56 2016 +0000
+++ b/src/wam/compile.lisp Sat Mar 26 19:19:07 2016 +0000
@@ -1,13 +1,24 @@
(in-package #:bones.wam)
+;;;; Parsing
+;;; Turns p(A, q(A, B)) into something like:
+;;;
+;;; X0 -> p(X1, X2)
+;;; X1 -> A
+;;; X2 -> q(X1, X3)
+;;; X3 -> B
+
(defun parse-term (term)
- "Parse a term into a series of register assignments."
- ;; Turns p(A, q(A, B)) into something like:
- ;;
- ;; X0 -> p(X1, X2)
- ;; X1 -> A
- ;; X2 -> q(X1, X3)
- ;; X3 -> B
+ "Parse a term into a series of register assignments.
+
+ A term is a Lispy representation of the raw Prolog.
+
+ A register assignment is a cons of (register . assigned-to), e.g.:
+
+ (1 . :foo) ; X1 = Foo
+ (2 . (f 1 3) ; X2 = f(X1, X3)
+
+ "
(labels ((variable-p (term)
(keywordp term))
(parse-variable (var registers)
@@ -29,58 +40,97 @@
(parse arg registers))
arguments)))))
(parse (term registers)
- (if (variable-p term)
- (parse-variable term registers)
- (parse-structure term registers))))
+ (cond
+ ((variable-p term)
+ (parse-variable term registers))
+ ;; Wrap bare symbols in a list. Essentially: foo -> foo/0
+ ((symbolp term)
+ (parse (list term) registers))
+ ((listp term)
+ (parse-structure term registers)))))
(let ((registers (make-array 64 :fill-pointer 0 :adjustable t)))
(parse term registers)
(loop :for i :from 0
:for reg :across registers
:collect (cons i reg)))))
-(defun flatten-register-assignments (registers)
- "Flatten the set of register assignments into a minimal set."
- ;; Turns:
- ;;
- ;; X0 -> p(X1, X2)
- ;; X1 -> A
- ;; X2 -> q(X1, X3)
- ;; X3 -> B
- ;;
- ;; into something like:
- ;;
- ;; X2 -> q(X1, X3), X0 -> p(X1, X2)
- (labels ((variable-assignment-p (ass)
- (keywordp (cdr ass)))
- (assignment-less-p (ass1 ass2)
- (cond
- ;; If 2 is a variable assignment, nothing can be less than it.
- ((variable-assignment-p ass2) nil)
+
+;;;; Flattening
+;;; "Flattening" is the process of turning a series of register assignments into
+;;; a sorted sequence appropriate for turning into a series of instructions.
+;;;
+;;; The order depends on whether we're compiling a query term or a program term.
+;;;
+;;; It's a stupid name because the assignments are already flattened as much as
+;;; they ever will be. "Sorting" would be a better name. Maybe I'll change it
+;;; once I'm done with the book.
+;;;
+;;; Turns:
+;;;
+;;; X0 -> p(X1, X2)
+;;; X1 -> A
+;;; X2 -> q(X1, X3)
+;;; X3 -> B
+;;;
+;;; into something like:
+;;;
+;;; X2 -> q(X1, X3), X0 -> p(X1, X2)
+
+(defun variable-assignment-p (ass)
+ "Return whether the register assigment is a simple variable assignment.
+
+ E.g. `X1 = Foo` is simple, but `X2 = f(...)` is not.
+
+ "
+ (keywordp (cdr ass)))
+
+(defun find-dependencies (registers)
+ "Return a list of dependencies amongst the given registers.
+
+ Each entry will be a cons of `(a . b)` if register `a` depends on `b`.
- ;; If 2 isn't, but 1 is, then 1 < 2.
- ((variable-assignment-p ass1) t)
+ "
+ (mapcan #'(lambda (assignment)
+ (if (variable-assignment-p assignment)
+ () ; Variable assignments don't depend on anything else
+ (destructuring-bind (target . (functor . reqs))
+ assignment
+ (declare (ignore functor))
+ (loop :for req :in reqs
+ :collect (cons req target)))))
+ registers))
+
+
+(defun flatten-query (registers)
+ "Flatten the set of register assignments into a minimal set for a query.
+
+ For queries we require that every register is assigned before it is used.
+
+ We also remove the plain old variable assignments because they're not actually
+ needed.
- ;; Otherwise they're both structure assignments.
- ;; (N . foo A B C) (M . bar X Y Z)
- ;;
- ;; We need to make sure that if something inside 2 uses the
- ;; target of 1, then 1 < 2.
- ((member (car ass1) (cdr ass2)) t)
+ "
+ (-<>> registers
+ (topological-sort <> (find-dependencies registers) :key #'car)
+ (remove-if #'variable-assignment-p <>)))
+
+(defun flatten-program (registers))
+
- ;; Otherwise we don't care.
- (t nil))))
- (remove-if #'variable-assignment-p
- (sort registers #'assignment-less-p))))
+;;;; Tokenization
+;;; Tokenizing takes a flattened set of assignments and turns it into a stream
+;;; of structure assignments and bare registers.
+;;;
+;;; It turns:
+;;;
+;;; X2 -> q(X1, X3), X0 -> p(X1, X2)
+;;;
+;;; into something like:
+;;;
+;;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2
(defun tokenize-assignments (assignments)
"Tokenize a flattened set of register assignments into a stream."
- ;; Turns:
- ;;
- ;; X2 -> q(X1, X3), X0 -> p(X1, X2)
- ;;
- ;; into something like:
- ;;
- ;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2
(mapcan #'(lambda (ass)
(destructuring-bind (register . (functor . arguments)) ass
;; Take a single assignment like:
@@ -92,20 +142,26 @@
arguments)))
assignments))
+
+;;;; Actions
+;;; Once we have a tokenized stream we can generate the list of machine
+;;; instructions from it.
+;;;
+;;; We turn:
+;;;
+;;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2
+;;;
+;;; into something like:
+;;;
+;;; (#'put-structure 2 q 2)
+;;; (#'set-variable 1)
+;;; (#'set-variable 3)
+;;; (#'put-structure 0 p 2)
+;;; (#'set-value 1)
+;;; (#'set-value 2)
+
(defun generate-actions (tokens)
"Generate a series of 'machine instructions' from a stream of tokens."
- ;; Turns:
- ;;
- ;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2
- ;;
- ;; into something like:
- ;;
- ;; (#'put-structure 2 q 2)
- ;; (#'set-variable 1)
- ;; (#'set-variable 3)
- ;; (#'put-structure 0 p 2)
- ;; (#'set-value 1)
- ;; (#'set-value 2)
(let ((seen (list)))
(flet ((handle-structure (register functor arity)
(push register seen)
@@ -122,12 +178,11 @@
(handle-register token))))))
-(defun compile-term (term)
+;;;; UI
+(defun compile-query-term (term)
"Parse a Lisp term into a series of WAM machine instructions."
- (generate-actions
- (tokenize-assignments
- (flatten-register-assignments
- (parse-term term)))))
+ (-> term parse-term flatten-query tokenize-assignments generate-actions))
+
(defun run (wam instructions)
"Execute the machine instructions on the given WAM."