--- a/src/make-utilities.lisp Thu Mar 31 22:17:53 2016 +0000
+++ b/src/make-utilities.lisp Fri Apr 01 17:24:39 2016 +0000
@@ -8,5 +8,7 @@
:ensure-boolean
:while
:until
+ :tree-member-p
+ :map-tree
)
:package "BONES.UTILS")
--- a/src/utils.lisp Thu Mar 31 22:17:53 2016 +0000
+++ b/src/utils.lisp Fri Apr 01 17:24:39 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL) :ensure-package T :package "BONES.UTILS")
+;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :MAP-TREE) :ensure-package T :package "BONES.UTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.UTILS")
@@ -17,7 +17,8 @@
:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:CURRY :STRING-DESIGNATOR
:WITH-GENSYMS :EXTRACT-FUNCTION-NAME
- :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE))))
+ :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
+ :TREE-MEMBER-P :MAP-TREE))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -223,8 +224,31 @@
`(until (not ,expression)
,@body))
+
+ (defun tree-member-p (item tree &key (test #'eql))
+ "Returns `t` if `item` is in `tree`, `nil` otherwise."
+ (labels ((rec (tree)
+ (cond ((null tree) nil)
+ ((atom tree) (funcall test item tree))
+ (t (or (rec (car tree))
+ (rec (cdr tree)))))))
+ (rec tree)))
+
+
+ (defun map-tree (function tree)
+ "Map `function` to each of the leave of `tree`."
+ (check-type tree cons)
+ (labels ((rec (tree)
+ (cond
+ ((null tree) nil)
+ ((atom tree) (funcall function tree))
+ ((consp tree)
+ (cons (rec (car tree))
+ (rec (cdr tree)))))))
+ (rec tree)))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(define-constant set-equal curry switch eswitch cswitch
- ensure-boolean while until)))
+ ensure-boolean while until tree-member-p map-tree)))
;;;; END OF utils.lisp ;;;;
--- a/src/wam/compile.lisp Thu Mar 31 22:17:53 2016 +0000
+++ b/src/wam/compile.lisp Fri Apr 01 17:24:39 2016 +0000
@@ -7,52 +7,167 @@
;;; X1 -> A
;;; X2 -> q(X1, X3)
;;; X3 -> B
+;;;
+;;; And then processes the argument register assignments into:
+;;;
+;;; p/2:
+;;; A0 -> A
+;;; A1 -> q(A1, X3)
+;;; X2 -> B
+
+(defun find-assignment (register assignments)
+ "Find the assignment for the given register number in the assignment list."
+ (find register assignments :key #'car))
+
+
+(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.
+
+ Note that register assignments actually look like `(1 . contents)`, so
+ a simple variable assignment would be `(1 . :foo)`.
+
+ "
+ (keywordp (cdr ass)))
+
+(defun variable-register-p (register assignments)
+ "Return whether the given register contains a variable assignment."
+ (variable-assignment-p (find-assignment register assignments)))
+
+
+(defun register-assignment-p (ass)
+ "Return whether the register assigment is a register-to-register assignment.
+
+ E.g. `A1 = X2`.
+
+ Note that this should only ever happen for argument registers.
+
+ "
+ (numberp (cdr ass)))
+
+
+(defun structure-assignment-p (ass)
+ "Return whether the given assignment pair is a structure assignment."
+ (listp (cdr ass)))
+
+(defun structure-register-p (register assignments)
+ "Return whether the given register contains a structure assignment."
+ (structure-assignment-p (find-assignment register assignments)))
+
+
+(defun relocate-register (assignments from to)
+ "Relocate a register in the assignment list."
+ ;; Takes an assignment list like:
+ ;;
+ ;; (0 . 2) ; A0 = X2
+ ;; (1 . (f 2 3)) ; A1 = f(X2, X3)
+ ;; (2 . :foo) ; X2 = Foo
+ ;; (3 . :bar) ; X3 = Bar
+ (assert (< to from) (from to)
+ "Cannot relocate register ~D to ~D, destination must be before source."
+ from to)
+ (assert (not (tree-member-p to assignments)) (to)
+ "Cannot relocate register ~D to ~D in ~S, destination is already in use."
+ from to assignments)
+ (when assignments
+ (map-tree (lambda (r)
+ (if (numberp r)
+ (cond ((= r from) to) ; relocate the actual register
+ ((> r from) (1- r)) ; decrement higher registers
+ ((< r from) r)) ; pass through lower registers
+ r))
+ assignments)))
+
(defun parse-term (term)
"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)
+ Return the assignment list, the root functor, and the root functor's arity.
"
- (labels ((variable-p (term)
- (keywordp term))
- (parse-variable (var registers)
- ;; If we've already seen this variable, just return its position,
- ;; otherwise allocate a register for it.
- (or (position var registers)
- (vector-push-extend var registers)))
- (parse-structure (structure registers)
- (let* ((functor (first structure))
- (arguments (rest structure))
- (contents (list functor)))
- (prog1
- (vector-push-extend contents registers)
- ;; Parse the arguments and splice the results into this cell
- ;; once we're finished. The children should handle extending
- ;; the registers as needed.
- (nconc contents
- (mapcar (lambda (arg)
- (parse arg registers))
- arguments)))))
- (parse (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)))))
+ ;; A term is a Lispy representation of the raw Prolog. A register assignment
+ ;; is a cons of (register . assigned-to), e.g.:
+ ;;
+ ;; (p :foo (f :foo :bar))
+ ;; ->
+ ;; (0 . 2) ; A0 = X2
+ ;; (1 . 4) ; A1 = X3
+ ;; (2 . :foo) ; X2 = Foo
+ ;; (3 . (f 2 4)) ; X3 = f(X2, X4)
+ ;; (4 . :bar) ; X4 = Bar
+ (let* ((predicate (first term))
+ (arguments (rest term))
+ (arity (length arguments))
+ ;; Preallocate enough registers for all of the arguments.
+ ;; We'll fill them in later.
+ (registers (make-array 64 :fill-pointer arity :adjustable t)))
+ (labels
+ ((variable-p (term)
+ (keywordp term))
+ (parse-variable (var)
+ ;; If we've already seen this variable, just return its position,
+ ;; otherwise allocate a register for it.
+ (or (position var registers)
+ (vector-push-extend var registers)))
+ (parse-structure (structure)
+ (let* ((functor (first structure))
+ (arguments (rest structure))
+ (contents (list functor)))
+ (prog1
+ (vector-push-extend contents registers)
+ ;; Parse the arguments and splice the results into this cell
+ ;; once we're finished. The children should handle extending
+ ;; the registers as needed.
+ (nconc contents (mapcar #'parse arguments)))))
+ (parse (term)
+ (cond
+ ((variable-p term) (parse-variable term))
+ ((symbolp term) (parse (list term))) ; f -> f/0
+ ((listp term) (parse-structure term))
+ (t (error "Cannot parse term ~S." term)))))
+ ;; Arguments are handled specially. We parse the children as normal,
+ ;; and then fill in the argument registers after each child.
+ (loop :for argument :in arguments
+ :for i :from 0
+ :do (setf (aref registers i)
+ (parse argument)))
+ (values (loop :for i :from 0 ; turn the register array into an assignment list
+ :for reg :across registers
+ :collect (cons i reg))
+ predicate
+ arity))))
+
+
+(defun inline-structure-argument-assignments (assignments functor arity)
+ "Inline structure register assignments directly into the argument registers."
+ ;; After parsing the term we end up with something like:
+ ;;
+ ;; (0 . 2) ; A0 = X2
+ ;; (1 . 4) ; A1 = X3 <---------+
+ ;; (2 . :foo) ; X2 = Foo | inline this
+ ;; (3 . (f 2 4)) ; X3 = f(X2, X4) ------+
+ ;; (4 . :bar) ; X4 = Bar
+ ;;
+ ;; We want to "inline" any structure arguments into the argument registers.
+ (labels
+ ((recur (remaining assignments)
+ (if (zerop remaining)
+ assignments
+ (let* ((argument-register (car assignments))
+ (argument-number (car argument-register))
+ (argument-target (cdr argument-register)))
+ (if (structure-register-p argument-target assignments)
+ (recur (1- remaining)
+ (relocate-register (cdr assignments)
+ argument-target
+ argument-number))
+ (cons argument-register
+ (recur (1- remaining)
+ (cdr assignments))))))))
+ (values (sort (recur arity assignments) #'< :key #'car)
+ functor
+ arity)))
;;;; Flattening
@@ -76,59 +191,50 @@
;;;
;;; 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)
+(defun find-dependencies (assignments)
"Return a list of dependencies amongst the given registers.
Each entry will be a cons of `(a . b)` if register `a` depends on `b`.
"
- (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 swap-cons (c)
- (cons (cdr c) (car c)))
+ (mapcan
+ (lambda (assignment)
+ (cond
+ ; Variable assignments (X1 <- Foo) don't depend on anything else.
+ ((variable-assignment-p assignment)
+ ())
+ ; Register assignments (A0 <- X5) have one obvious dependency.
+ ((register-assignment-p assignment)
+ (list (cons (cdr assignment) (car assignment))))
+ ; Structure assignments depend on all the functor's arguments.
+ ((structure-assignment-p assignment)
+ (destructuring-bind (target . (functor . reqs))
+ assignment
+ (declare (ignore functor))
+ (loop :for req :in reqs
+ :collect (cons req target))))
+ (t (error "Cannot find dependencies for assignment ~S." assignment))))
+ assignments))
-(defun flatten (registers reverse)
+(defun flatten (assignments functor arity)
"Flatten the set of register assignments into a minimal set.
- `reverse` determines the ordering. For queries (`nil`) we require that every
- register be assigned before it is used. For programs (`t`) we require the
- opposite.
-
- We also remove the plain old variable assignments because they're not actually
- needed in the end.
+ We remove the plain old variable assignments (in non-argument registers)
+ because they're not actually needed in the end.
"
- (-<>> registers
- (topological-sort <>
- (let ((dependencies (find-dependencies registers)))
- (if reverse
- (mapcar #'swap-cons dependencies)
- dependencies))
- :key #'car)
- (remove-if #'variable-assignment-p <>)))
+ (values (-<> assignments
+ (topological-sort <> (find-dependencies assignments) :key #'car)
+ (remove-if #'variable-assignment-p <>))
+ functor
+ arity))
-(defun flatten-query (registers)
- (flatten registers nil))
+(defun flatten-query (registers functor arity)
+ (flatten registers functor arity))
-(defun flatten-program (registers)
- (flatten registers t))
+(defun flatten-program (registers functor arity)
+ (reverse (flatten registers functor arity)))
;;;; Tokenization
@@ -143,18 +249,33 @@
;;;
;;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2
-(defun tokenize-assignments (assignments)
+(defun tokenize-assignments (assignments functor arity)
"Tokenize a flattened set of register assignments into a stream."
- (mapcan (lambda (ass)
- (destructuring-bind (register . (functor . arguments)) ass
- ;; Take a single assignment like:
- ;; X1 = f(a, b, c) (1 . (f a b c))
- ;;
- ;; And turn it into a stream of tokens:
- ;; (X1 = f/3), a, b, c (1 f 3) a b c
- (cons (list register functor (length arguments))
- arguments)))
- assignments))
+ (values
+ (mapcan
+ (lambda (ass)
+ ;; Take a single assignment like:
+ ;; X1 = f(a, b, c) (1 . (f a b c))
+ ;; A0 = X5 (0 . 5)
+ ;;
+ ;; And turn it into a stream of tokens:
+ ;; (X1 = f/3), a, b, c ((:structure 1 f 3) a b c)
+ ;; (A0 = X5) ((:argument 0 5))
+ (if (register-assignment-p ass)
+ ;; It might be a register assignment for an argument register.
+ (destructuring-bind (argument-register . target-register) ass
+ (assert (< argument-register arity) ()
+ "Cannot tokenize register assignment to non-argument register ~D in ~A/~D:~%~S."
+ argument-register functor arity assignments)
+ (list (list :argument argument-register target-register)))
+ ;; Otherwise it's a structure assignment. We know the others have
+ ;; gotten flattened away by now.
+ (destructuring-bind (register . (functor . arguments)) ass
+ (cons (list :structure register functor (length arguments))
+ arguments))))
+ assignments)
+ functor
+ arity))
;;;; Actions