# HG changeset patch # User Steve Losh # Date 1459531479 0 # Node ID ea71bdab6baa2bbd0ebc5fca9fa64f3ced4ebe7b # Parent bbbc9030a316dfc5834262ac8ce1ebd3f663b663 Deal with the L1 register assignment mess diff -r bbbc9030a316 -r ea71bdab6baa src/make-utilities.lisp --- 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") diff -r bbbc9030a316 -r ea71bdab6baa src/utils.lisp --- 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 ;;;; diff -r bbbc9030a316 -r ea71bdab6baa src/wam/compile.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