fcec9e0c9c67

Fix the topological sorting

Necessary before we start working with program terms
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Sat, 26 Mar 2016 19:19:07 +0000
parents 859a6c1314d3
children d4ba6547d8a1
branches/tags (none)
files bones.asd package.lisp src/wam/compile.lisp src/wam/dump.lisp src/wam/topological-sort.lisp src/wam/wam.lisp

Changes

--- 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/package.lisp	Sat Mar 26 12:21:56 2016 +0000
+++ b/package.lisp	Sat Mar 26 19:19:07 2016 +0000
@@ -3,8 +3,9 @@
   (:export #:hello))
 
 (defpackage #:bones.wam
-  (:use #:cl #:defstar #:bones.utils #:optima)
-  (:import-from #:optima #:match))
+  (:use #:cl #:defstar #:bones.utils #:optima #:cl-arrows)
+  (:import-from #:optima #:match)
+  (:shadowing-import-from #:cl-arrows #:->))
 
 (defpackage #:bones.paip
   (:use #:cl #:defstar #:bones.utils)
--- 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."
--- a/src/wam/dump.lisp	Sat Mar 26 12:21:56 2016 +0000
+++ b/src/wam/dump.lisp	Sat Mar 26 19:19:07 2016 +0000
@@ -46,7 +46,13 @@
                     (format nil "X~D" i)
                     (cell-aesthetic reg))))
 
+(defun dump-wam-functors (wam)
+  (format t "FUNCTORS: ~S~%" (wam-functors wam)))
+
+
 (defun dump-wam (wam from to highlight)
+  (dump-wam-functors wam)
+  (format t "~%")
   (dump-wam-registers wam)
   (format t "~%")
   (dump-heap wam from to highlight))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/wam/topological-sort.lisp	Sat Mar 26 19:19:07 2016 +0000
@@ -0,0 +1,50 @@
+(in-package #:bones.wam)
+
+;;;; Topological Sort
+;;; Adapted from the AMOP book to add some flexibility (and remove the
+;;; tie-breaker functionality, which we don't need).
+(defun topological-sort
+    (elements constraints &key (key #'identity) (key-test #'eql) (test #'equal))
+  "Return a topologically sorted list of `elements` given the `constraints`.
+
+  `elements` should be a sequence of elements to be sorted.
+
+  `constraints` should be a list of `(element . element)` conses where
+  `(foo . bar)` means that element `foo` must precede `bar` in the result.
+
+  `key` will be used to turn items in `elements` into the items in
+  `constraints`.
+
+  `key-test` is the equality predicate for keys.
+
+  `test` is the equality predicate for (non-keyified) elements.
+
+  "
+  (labels
+      ((find-minimal-elements (elements constraints)
+         ;; An element is minimal if there are no other elements that are
+         ;; required to precede it.
+         (remove-if #'(lambda (element)
+                       (member (funcall key element)
+                               constraints
+                               :key #'cdr
+                               :test key-test))
+                    elements))
+       (in-constraint (val constraint)
+         ;; Return whether val is either part of a constraint.
+         (or (funcall key-test val (car constraint))
+             (funcall key-test val (cdr constraint))))
+       (recur (remaining-constraints remaining-elements result)
+         (let ((minimal-elements (find-minimal-elements remaining-elements
+                                                        remaining-constraints)))
+           (if (null minimal-elements)
+             (if (null remaining-elements)
+               result
+               (error "Inconsistent constraints."))
+             (let ((choice (car minimal-elements)))
+               (recur (remove (funcall key choice)
+                              remaining-constraints
+                              :test #'in-constraint)
+                      (remove choice remaining-elements :test test)
+                      (cons choice result)))))))
+    (reverse (recur constraints elements (list)))))
--- a/src/wam/wam.lisp	Sat Mar 26 12:21:56 2016 +0000
+++ b/src/wam/wam.lisp	Sat Mar 26 19:19:07 2016 +0000
@@ -3,7 +3,7 @@
 ;;;; WAM
 (defclass wam ()
   ((heap
-     :initform (make-array 16
+     :initform (make-array 32
                            :initial-element (make-cell-null)
                            :element-type 'heap-cell)
      :reader wam-heap