# HG changeset patch # User Steve Losh # Date 1459019947 0 # Node ID fcec9e0c9c6701467a3da1e1341b943bfdcd3655 # Parent 859a6c1314d399b4ed9b6157e52c7a3e036b234a Fix the topological sorting Necessary before we start working with program terms diff -r 859a6c1314d3 -r fcec9e0c9c67 bones.asd --- 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") diff -r 859a6c1314d3 -r fcec9e0c9c67 package.lisp --- 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) diff -r 859a6c1314d3 -r fcec9e0c9c67 src/wam/compile.lisp --- 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." diff -r 859a6c1314d3 -r fcec9e0c9c67 src/wam/dump.lisp --- 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)) diff -r 859a6c1314d3 -r fcec9e0c9c67 src/wam/topological-sort.lisp --- /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))))) diff -r 859a6c1314d3 -r fcec9e0c9c67 src/wam/wam.lisp --- 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