ea71bdab6baa

Deal with the L1 register assignment mess
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Fri, 01 Apr 2016 17:24:39 +0000
parents bbbc9030a316
children 6dc3f4e03454
branches/tags (none)
files src/make-utilities.lisp src/utils.lisp src/wam/compile.lisp

Changes

--- 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