# HG changeset patch # User Steve Losh # Date 1460812036 0 # Node ID b8bc9b1756361ef5ecdefe4a558b199af61f7661 # Parent ac5c1bfbe50aa3da42b026b5c216f0645268f27a Rename a few files diff -r ac5c1bfbe50a -r b8bc9b175636 bones.asd --- a/bones.asd Sat Apr 16 12:54:58 2016 +0000 +++ b/bones.asd Sat Apr 16 13:07:16 2016 +0000 @@ -24,12 +24,11 @@ (:module "wam" :components ((:file "constants") (:file "types") - (:file "topological-sort") (:file "cells") (:file "bytecode") (:file "wam") - (:file "compile") - (:file "instructions") + (:file "compiler") + (:file "interpreter") (:file "dump"))) (:file "bones"))))) diff -r ac5c1bfbe50a -r b8bc9b175636 package.lisp --- a/package.lisp Sat Apr 16 12:54:58 2016 +0000 +++ b/package.lisp Sat Apr 16 13:07:16 2016 +0000 @@ -8,6 +8,7 @@ #:bones.quickutils) (:export #:repeat + #:topological-sort #:push-if-new)) (defpackage #:bones.wam diff -r ac5c1bfbe50a -r b8bc9b175636 src/utils.lisp --- a/src/utils.lisp Sat Apr 16 12:54:58 2016 +0000 +++ b/src/utils.lisp Sat Apr 16 13:07:16 2016 +0000 @@ -33,3 +33,50 @@ "Repeat `body` `n` times." `(dotimes (,(gensym) ,n) ,@body)) + + +;;;; 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 `(key . key)` conses where `(foo . bar)` + means element `foo` must precede `bar` in the result. + + `key` will be used to turn items in `elements` into the keys in `constraints`. + + `key-test` is the equality predicate for keys. + + `test` is the equality predicate for (non-keyified) elements. + + " + (labels + ((minimal-p (element constraints) + ;; An element is minimal if there are no other elements that must + ;; precede it. + (not (member (funcall key element) constraints + :key #'cdr + :test key-test))) + (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-element + (find-if (lambda (el) + (minimal-p el remaining-constraints)) + remaining-elements))) + (if (null minimal-element) + (if (null remaining-elements) + result + (error "Inconsistent constraints.")) + (recur (remove (funcall key minimal-element) + remaining-constraints + :test #'in-constraint) + (remove minimal-element remaining-elements :test test) + (cons minimal-element result)))))) + (reverse (recur constraints elements (list))))) diff -r ac5c1bfbe50a -r b8bc9b175636 src/wam/compile.lisp --- a/src/wam/compile.lisp Sat Apr 16 12:54:58 2016 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,564 +0,0 @@ -(in-package #:bones.wam) -(named-readtables:in-readtable :fare-quasiquote) - -;;;; Registers -(deftype register-type () - '(member :argument :local :permanent)) - -(deftype register-number () - '(integer 0)) - - -(defclass register () - ((type - :initarg :type - :reader register-type - :type register-type) - (number - :initarg :number - :reader register-number - :type register-number))) - - -(defun* make-register ((type register-type) (number register-number)) - (:returns register) - (make-instance 'register :type type :number number)) - -(defun* make-temporary-register ((number register-number) (arity arity)) - (:returns register) - (make-register (if (< number arity) :argument :local) - number)) - -(defun* make-permanent-register ((number register-number) (arity arity)) - (:returns register) - (declare (ignore arity)) - (make-register :permanent number)) - - -(defun* register-to-designator ((register register)) - (:returns register-designator) - (with-slots (type number) register - (if (eql type :permanent) - (make-stack-register-designator number) - (make-local-register-designator number)))) - -(defun* register-to-string ((register register)) - (format nil "~A~D" - (ecase (register-type register) - (:argument #\A) - (:local #\X) - (:permanent #\Y)) - (+ (register-number register) - (if *off-by-one* 1 0)))) - -(defmethod print-object ((object register) stream) - (print-unreadable-object (object stream :identity nil :type nil) - (format stream (register-to-string object)))) - - -(defun* register= ((r1 register) (r2 register)) - (:returns boolean) - (ensure-boolean - (and (eql (register-type r1) - (register-type r2)) - (= (register-number r1) - (register-number r2))))) - -(defun* register≈ ((r1 register) (r2 register)) - (:returns boolean) - (ensure-boolean - (and (or (eql (register-type r1) - (register-type r2)) - ;; local and argument registers are actually the same register, - ;; just named differently - (and (member (register-type r1) '(:local :argument)) - (member (register-type r2) '(:local :argument)))) - (= (register-number r1) - (register-number r2))))) - - -;;;; Register Assignments -(deftype register-assignment () - ;; A register assignment represented as a cons of (register . contents). - '(cons register t)) - -(deftype register-assignment-list () - '(trivial-types:association-list register t)) - - -(defun* pprint-assignments ((assignments register-assignment-list)) - (format t "~{~A~%~}" - (loop :for (register . contents) :in assignments :collect - (format nil "~A <- ~S" (register-to-string register) contents)))) - -(defun* find-assignment ((register register) - (assignments register-assignment-list)) - (:returns register-assignment) - "Find the assignment for the given register number in the assignment list." - (assoc register assignments)) - - -(defun* variable-p (term) - (:returns boolean) - (ensure-boolean (keywordp term))) - - -(defun* variable-assignment-p ((assignment register-assignment)) - "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)`. - - " - (:returns boolean) - (variable-p (cdr assignment))) - -(defun* variable-register-p ((register register) - (assignments register-assignment-list)) - (:returns boolean) - "Return whether the given register contains a variable assignment." - (variable-assignment-p (find-assignment register assignments))) - - -(defun* register-assignment-p ((assignment register-assignment)) - (:returns boolean) - "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. - - " - (typep (cdr assignment) 'register)) - - -(defun* structure-assignment-p ((assignment register-assignment)) - (:returns boolean) - "Return whether the given assignment pair is a structure assignment." - (listp (cdr assignment))) - -(defun* structure-register-p ((register register) - (assignments register-assignment-list)) - (:returns boolean) - "Return whether the given register contains a structure assignment." - (structure-assignment-p (find-assignment register assignments))) - - -;;;; Parsing -;;; Turns p(A, q(A, B)) into something like: -;;; -;;; X0 -> p(X1, X2) -;;; 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 parse-term (term permanent-variables) - "Parse a term into a series of register assignments. - - Returns: - - * The assignment list - * The root functor - * The root functor's arity - - " - ;; 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. - (local-registers (make-array 64 - :fill-pointer arity - :adjustable t - :initial-element nil)) - ;; We essentially "preallocate" all the permanent variables up front - ;; because we need them to always be in the same stack registers across - ;; all the terms of our clause. - ;; - ;; The ones that won't get used in this term will end up getting - ;; flattened away anyway. - (stack-registers (make-array (length permanent-variables) - :initial-contents permanent-variables))) - (labels - ((find-variable (var) - (let ((r (position var local-registers)) - (s (position var stack-registers))) - (cond - (r (make-temporary-register r arity)) - (s (make-permanent-register s arity)) - (t nil)))) - (store-variable (var) - (make-temporary-register - (vector-push-extend var local-registers) - arity)) - (parse-variable (var) - ;; If we've already seen this variable just return the register it's - ;; in, otherwise allocate a register for it and return that. - (or (find-variable var) - (store-variable var))) - (parse-structure (structure reg) - (destructuring-bind (functor . arguments) structure - ;; If we've been given a register to hold this structure (i.e. - ;; we're parsing a top-level argument) use it. Otherwise allocate - ;; a fresh one. Note that structures always live in local - ;; registers, never permanent ones. - (let ((reg (or reg (vector-push-extend nil local-registers)))) - (setf (aref local-registers reg) - (cons functor (mapcar #'parse arguments))) - (make-temporary-register reg arity)))) - (parse (term &optional register) - (cond - ((variable-p term) (parse-variable term)) - ((symbolp term) (parse (list term) register)) ; f -> f/0 - ((listp term) (parse-structure term register)) - (t (error "Cannot parse term ~S." term)))) - (make-assignment-list (registers register-maker) - (loop :for i :from 0 - :for contents :across registers - :collect - (cons (funcall register-maker i arity) - contents)))) - ;; 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 - :for parsed = (parse argument i) - ;; If the argument didn't fill itself in (structure), do it. - :when (not (aref local-registers i)) - :do (setf (aref local-registers i) parsed)) - (values (append - (make-assignment-list local-registers #'make-temporary-register) - (make-assignment-list stack-registers #'make-permanent-register)) - predicate - arity)))) - - -;;;; 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 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) - (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) - (destructuring-bind (argument . contents) assignment - (list `(,contents . ,argument)))) - ; 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 (assignments) - "Flatten the set of register assignments into a minimal set. - - We remove the plain old variable assignments (in non-argument registers) - because they're not actually needed in the end. - - " - (-<> assignments - (topological-sort <> (find-dependencies assignments) - :key #'car - :key-test #'register= - :test #'eql) - (remove-if #'variable-assignment-p <>))) - -(defun flatten-query (assignments) - (flatten assignments)) - -(defun flatten-program (assignments) - (reverse (flatten assignments))) - - -;;;; 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), A3 <- X4 -;;; -;;; into something like: -;;; -;;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2, (A3 = X4) - -(defun tokenize-assignments (assignments) - "Tokenize a flattened set of register assignments into a stream." - (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 - (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)) - - -(defun tokenize-term (term permanent-variables flattener) - (multiple-value-bind (assignments functor arity) - (parse-term term permanent-variables) - (values (->> assignments - (funcall flattener) - tokenize-assignments) - functor - arity))) - -(defun tokenize-program-term (term permanent-variables) - "Tokenize `term` as a program term, returning its tokens, functor, and arity." - (tokenize-term term permanent-variables #'flatten-program)) - -(defun tokenize-query-term (term permanent-variables) - "Tokenize `term` as a query term, returning its stream of tokens." - (multiple-value-bind (tokens functor arity) - (tokenize-term term permanent-variables #'flatten-query) - ;; We need to shove a CALL token onto the end. - (append tokens `((:call ,functor ,arity))))) - - -;;;; Bytecode -;;; Once we have a tokenized stream we can generate the 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 compile-tokens (wam head-tokens body-tokens store) - "Generate a series of machine instructions from a stream of head and body - tokens. - - The `head-tokens` should be program-style tokens, and are compiled in program - mode. The `body-tokens` should be query-style tokens, and are compiled in - query mode. - - Actual queries are a special case where the `head-tokens` stream is `nil` - - The compiled instructions will be appended to `store` using - `code-push-instructions!`. - - " - (let ((seen (list)) - (mode nil)) - (labels - ((handle-argument (argument-register source-register) - ;; OP X_n A_i - (code-push-instruction! store - (if (push-if-new source-register seen :test #'register=) - (ecase mode - (:program +opcode-get-variable+) - (:query +opcode-put-variable+)) - (ecase mode - (:program +opcode-get-value+) - (:query +opcode-put-value+))) - (register-to-designator source-register) - (register-to-designator argument-register))) - (handle-structure (destination-register functor arity) - ;; OP functor reg - (push destination-register seen) - (code-push-instruction! store - (ecase mode - (:program +opcode-get-structure+) - (:query +opcode-put-structure+)) - (wam-ensure-functor-index wam (cons functor arity)) - (register-to-designator destination-register))) - (handle-call (functor arity) - ;; CALL functor - (code-push-instruction! store - +opcode-call+ - (wam-ensure-functor-index wam (cons functor arity)))) - (handle-register (register) - ;; OP reg - (code-push-instruction! store - (if (push-if-new register seen :test #'register=) - (ecase mode - (:program +opcode-unify-variable+) - (:query +opcode-set-variable+)) - (ecase mode - (:program +opcode-unify-value+) - (:query +opcode-set-value+))) - (register-to-designator register))) - (handle-stream (tokens) - (loop :for token :in tokens :collect - (ematch token - ((guard `(:argument ,argument-register ,source-register) - (and (eql (register-type argument-register) :argument) - (member (register-type source-register) - '(:local :permanent)))) - (handle-argument argument-register source-register)) - ((guard `(:structure ,destination-register ,functor ,arity) - (member (register-type destination-register) - '(:local :argument))) - (handle-structure destination-register functor arity)) - (`(:call ,functor ,arity) - (handle-call functor arity)) - ((guard register - (typep register 'register)) - (handle-register register)))))) - (when head-tokens - (setf mode :program) - (handle-stream head-tokens)) - (setf mode :query) - (handle-stream body-tokens)))) - - -;;;; UI -(defun find-permanent-variables (clause) - "Return a list of all the 'permanent' variables in `clause`. - - Permanent variables are those that appear in more than one goal of the clause, - where the head of the clause is considered to be a part of the first goal. - - " - (if (< (length clause) 2) - (list) ; facts and chain rules have no permanent variables at all - (destructuring-bind (head body-first . body-rest) clause - ;; the head is treated as part of the first goal for the purposes of - ;; finding permanent variables - (let* ((goals (cons (cons head body-first) body-rest)) - (variables (remove-duplicates (tree-collect #'variable-p goals)))) - (flet ((permanent-p (variable) - "Permanent variables are those contained in more than 1 goal." - (> (count-if (curry #'tree-member-p variable) - goals) - 1))) - (remove-if-not #'permanent-p variables)))))) - - -(defun mark-label (wam functor arity store) - "Set the code label `(functor . arity)` to point at the next space in `store`." - ;; todo make this less ugly - (setf (wam-code-label wam (wam-ensure-functor-index wam (cons functor arity))) - (fill-pointer store))) - - -(defun make-query-code-store () - (make-array 64 - :fill-pointer 0 - :adjustable t - :element-type 'code-word)) - - -(defun compile-clause (wam store head body) - "Compile the clause into the given store array. - - `head` should be the head of the clause for program clauses, or may be `nil` - for query clauses. - - " - (let* ((permanent-variables - (find-permanent-variables (cons head body))) - (head-tokens - (when head - (multiple-value-bind (tokens functor arity) - (tokenize-program-term head permanent-variables) - (mark-label wam functor arity store) ; TODO: this is ugly - tokens))) - (body-tokens - (loop :for term :in body :append - (tokenize-query-term term permanent-variables)))) - (flet ((compile% () (compile-tokens wam head-tokens body-tokens store))) - ;; We need to compile facts and rules differently. Facts end with - ;; a PROCEED and rules are wrapped in ALOC/DEAL. - (cond - ((and head body) ; a full-ass rule - (code-push-instruction! store +opcode-allocate+ (length permanent-variables)) - (compile%) - (code-push-instruction! store +opcode-deallocate+)) - ((and head (null body)) ; a bare fact - (compile%) - (code-push-instruction! store +opcode-proceed+)) - (t ; just a query - (compile%))))) - (values)) - -(defun compile-query (wam query) - "Compile `query` into a fresh array of bytecode. - - `query` should be a list of goal terms. - - " - (let ((store (make-query-code-store))) - (compile-clause wam store nil query) - store)) - -(defun compile-program (wam rule) - "Compile `rule` into the WAM's code store. - - `rule` should be a clause consisting of a head term and zero or more body - terms. A rule with no body is also called a \"fact\". - - " - (compile-clause wam (wam-code wam) (first rule) (rest rule)) - (values)) - diff -r ac5c1bfbe50a -r b8bc9b175636 src/wam/compiler.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/wam/compiler.lisp Sat Apr 16 13:07:16 2016 +0000 @@ -0,0 +1,564 @@ +(in-package #:bones.wam) +(named-readtables:in-readtable :fare-quasiquote) + +;;;; Registers +(deftype register-type () + '(member :argument :local :permanent)) + +(deftype register-number () + '(integer 0)) + + +(defclass register () + ((type + :initarg :type + :reader register-type + :type register-type) + (number + :initarg :number + :reader register-number + :type register-number))) + + +(defun* make-register ((type register-type) (number register-number)) + (:returns register) + (make-instance 'register :type type :number number)) + +(defun* make-temporary-register ((number register-number) (arity arity)) + (:returns register) + (make-register (if (< number arity) :argument :local) + number)) + +(defun* make-permanent-register ((number register-number) (arity arity)) + (:returns register) + (declare (ignore arity)) + (make-register :permanent number)) + + +(defun* register-to-designator ((register register)) + (:returns register-designator) + (with-slots (type number) register + (if (eql type :permanent) + (make-stack-register-designator number) + (make-local-register-designator number)))) + +(defun* register-to-string ((register register)) + (format nil "~A~D" + (ecase (register-type register) + (:argument #\A) + (:local #\X) + (:permanent #\Y)) + (+ (register-number register) + (if *off-by-one* 1 0)))) + +(defmethod print-object ((object register) stream) + (print-unreadable-object (object stream :identity nil :type nil) + (format stream (register-to-string object)))) + + +(defun* register= ((r1 register) (r2 register)) + (:returns boolean) + (ensure-boolean + (and (eql (register-type r1) + (register-type r2)) + (= (register-number r1) + (register-number r2))))) + +(defun* register≈ ((r1 register) (r2 register)) + (:returns boolean) + (ensure-boolean + (and (or (eql (register-type r1) + (register-type r2)) + ;; local and argument registers are actually the same register, + ;; just named differently + (and (member (register-type r1) '(:local :argument)) + (member (register-type r2) '(:local :argument)))) + (= (register-number r1) + (register-number r2))))) + + +;;;; Register Assignments +(deftype register-assignment () + ;; A register assignment represented as a cons of (register . contents). + '(cons register t)) + +(deftype register-assignment-list () + '(trivial-types:association-list register t)) + + +(defun* pprint-assignments ((assignments register-assignment-list)) + (format t "~{~A~%~}" + (loop :for (register . contents) :in assignments :collect + (format nil "~A <- ~S" (register-to-string register) contents)))) + +(defun* find-assignment ((register register) + (assignments register-assignment-list)) + (:returns register-assignment) + "Find the assignment for the given register number in the assignment list." + (assoc register assignments)) + + +(defun* variable-p (term) + (:returns boolean) + (ensure-boolean (keywordp term))) + + +(defun* variable-assignment-p ((assignment register-assignment)) + "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)`. + + " + (:returns boolean) + (variable-p (cdr assignment))) + +(defun* variable-register-p ((register register) + (assignments register-assignment-list)) + (:returns boolean) + "Return whether the given register contains a variable assignment." + (variable-assignment-p (find-assignment register assignments))) + + +(defun* register-assignment-p ((assignment register-assignment)) + (:returns boolean) + "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. + + " + (typep (cdr assignment) 'register)) + + +(defun* structure-assignment-p ((assignment register-assignment)) + (:returns boolean) + "Return whether the given assignment pair is a structure assignment." + (listp (cdr assignment))) + +(defun* structure-register-p ((register register) + (assignments register-assignment-list)) + (:returns boolean) + "Return whether the given register contains a structure assignment." + (structure-assignment-p (find-assignment register assignments))) + + +;;;; Parsing +;;; Turns p(A, q(A, B)) into something like: +;;; +;;; X0 -> p(X1, X2) +;;; 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 parse-term (term permanent-variables) + "Parse a term into a series of register assignments. + + Returns: + + * The assignment list + * The root functor + * The root functor's arity + + " + ;; 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. + (local-registers (make-array 64 + :fill-pointer arity + :adjustable t + :initial-element nil)) + ;; We essentially "preallocate" all the permanent variables up front + ;; because we need them to always be in the same stack registers across + ;; all the terms of our clause. + ;; + ;; The ones that won't get used in this term will end up getting + ;; flattened away anyway. + (stack-registers (make-array (length permanent-variables) + :initial-contents permanent-variables))) + (labels + ((find-variable (var) + (let ((r (position var local-registers)) + (s (position var stack-registers))) + (cond + (r (make-temporary-register r arity)) + (s (make-permanent-register s arity)) + (t nil)))) + (store-variable (var) + (make-temporary-register + (vector-push-extend var local-registers) + arity)) + (parse-variable (var) + ;; If we've already seen this variable just return the register it's + ;; in, otherwise allocate a register for it and return that. + (or (find-variable var) + (store-variable var))) + (parse-structure (structure reg) + (destructuring-bind (functor . arguments) structure + ;; If we've been given a register to hold this structure (i.e. + ;; we're parsing a top-level argument) use it. Otherwise allocate + ;; a fresh one. Note that structures always live in local + ;; registers, never permanent ones. + (let ((reg (or reg (vector-push-extend nil local-registers)))) + (setf (aref local-registers reg) + (cons functor (mapcar #'parse arguments))) + (make-temporary-register reg arity)))) + (parse (term &optional register) + (cond + ((variable-p term) (parse-variable term)) + ((symbolp term) (parse (list term) register)) ; f -> f/0 + ((listp term) (parse-structure term register)) + (t (error "Cannot parse term ~S." term)))) + (make-assignment-list (registers register-maker) + (loop :for i :from 0 + :for contents :across registers + :collect + (cons (funcall register-maker i arity) + contents)))) + ;; 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 + :for parsed = (parse argument i) + ;; If the argument didn't fill itself in (structure), do it. + :when (not (aref local-registers i)) + :do (setf (aref local-registers i) parsed)) + (values (append + (make-assignment-list local-registers #'make-temporary-register) + (make-assignment-list stack-registers #'make-permanent-register)) + predicate + arity)))) + + +;;;; 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 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) + (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) + (destructuring-bind (argument . contents) assignment + (list `(,contents . ,argument)))) + ; 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 (assignments) + "Flatten the set of register assignments into a minimal set. + + We remove the plain old variable assignments (in non-argument registers) + because they're not actually needed in the end. + + " + (-<> assignments + (topological-sort <> (find-dependencies assignments) + :key #'car + :key-test #'register= + :test #'eql) + (remove-if #'variable-assignment-p <>))) + +(defun flatten-query (assignments) + (flatten assignments)) + +(defun flatten-program (assignments) + (reverse (flatten assignments))) + + +;;;; 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), A3 <- X4 +;;; +;;; into something like: +;;; +;;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2, (A3 = X4) + +(defun tokenize-assignments (assignments) + "Tokenize a flattened set of register assignments into a stream." + (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 + (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)) + + +(defun tokenize-term (term permanent-variables flattener) + (multiple-value-bind (assignments functor arity) + (parse-term term permanent-variables) + (values (->> assignments + (funcall flattener) + tokenize-assignments) + functor + arity))) + +(defun tokenize-program-term (term permanent-variables) + "Tokenize `term` as a program term, returning its tokens, functor, and arity." + (tokenize-term term permanent-variables #'flatten-program)) + +(defun tokenize-query-term (term permanent-variables) + "Tokenize `term` as a query term, returning its stream of tokens." + (multiple-value-bind (tokens functor arity) + (tokenize-term term permanent-variables #'flatten-query) + ;; We need to shove a CALL token onto the end. + (append tokens `((:call ,functor ,arity))))) + + +;;;; Bytecode +;;; Once we have a tokenized stream we can generate the 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 compile-tokens (wam head-tokens body-tokens store) + "Generate a series of machine instructions from a stream of head and body + tokens. + + The `head-tokens` should be program-style tokens, and are compiled in program + mode. The `body-tokens` should be query-style tokens, and are compiled in + query mode. + + Actual queries are a special case where the `head-tokens` stream is `nil` + + The compiled instructions will be appended to `store` using + `code-push-instructions!`. + + " + (let ((seen (list)) + (mode nil)) + (labels + ((handle-argument (argument-register source-register) + ;; OP X_n A_i + (code-push-instruction! store + (if (push-if-new source-register seen :test #'register=) + (ecase mode + (:program +opcode-get-variable+) + (:query +opcode-put-variable+)) + (ecase mode + (:program +opcode-get-value+) + (:query +opcode-put-value+))) + (register-to-designator source-register) + (register-to-designator argument-register))) + (handle-structure (destination-register functor arity) + ;; OP functor reg + (push destination-register seen) + (code-push-instruction! store + (ecase mode + (:program +opcode-get-structure+) + (:query +opcode-put-structure+)) + (wam-ensure-functor-index wam (cons functor arity)) + (register-to-designator destination-register))) + (handle-call (functor arity) + ;; CALL functor + (code-push-instruction! store + +opcode-call+ + (wam-ensure-functor-index wam (cons functor arity)))) + (handle-register (register) + ;; OP reg + (code-push-instruction! store + (if (push-if-new register seen :test #'register=) + (ecase mode + (:program +opcode-unify-variable+) + (:query +opcode-set-variable+)) + (ecase mode + (:program +opcode-unify-value+) + (:query +opcode-set-value+))) + (register-to-designator register))) + (handle-stream (tokens) + (loop :for token :in tokens :collect + (ematch token + ((guard `(:argument ,argument-register ,source-register) + (and (eql (register-type argument-register) :argument) + (member (register-type source-register) + '(:local :permanent)))) + (handle-argument argument-register source-register)) + ((guard `(:structure ,destination-register ,functor ,arity) + (member (register-type destination-register) + '(:local :argument))) + (handle-structure destination-register functor arity)) + (`(:call ,functor ,arity) + (handle-call functor arity)) + ((guard register + (typep register 'register)) + (handle-register register)))))) + (when head-tokens + (setf mode :program) + (handle-stream head-tokens)) + (setf mode :query) + (handle-stream body-tokens)))) + + +;;;; UI +(defun find-permanent-variables (clause) + "Return a list of all the 'permanent' variables in `clause`. + + Permanent variables are those that appear in more than one goal of the clause, + where the head of the clause is considered to be a part of the first goal. + + " + (if (< (length clause) 2) + (list) ; facts and chain rules have no permanent variables at all + (destructuring-bind (head body-first . body-rest) clause + ;; the head is treated as part of the first goal for the purposes of + ;; finding permanent variables + (let* ((goals (cons (cons head body-first) body-rest)) + (variables (remove-duplicates (tree-collect #'variable-p goals)))) + (flet ((permanent-p (variable) + "Permanent variables are those contained in more than 1 goal." + (> (count-if (curry #'tree-member-p variable) + goals) + 1))) + (remove-if-not #'permanent-p variables)))))) + + +(defun mark-label (wam functor arity store) + "Set the code label `(functor . arity)` to point at the next space in `store`." + ;; todo make this less ugly + (setf (wam-code-label wam (wam-ensure-functor-index wam (cons functor arity))) + (fill-pointer store))) + + +(defun make-query-code-store () + (make-array 64 + :fill-pointer 0 + :adjustable t + :element-type 'code-word)) + + +(defun compile-clause (wam store head body) + "Compile the clause into the given store array. + + `head` should be the head of the clause for program clauses, or may be `nil` + for query clauses. + + " + (let* ((permanent-variables + (find-permanent-variables (cons head body))) + (head-tokens + (when head + (multiple-value-bind (tokens functor arity) + (tokenize-program-term head permanent-variables) + (mark-label wam functor arity store) ; TODO: this is ugly + tokens))) + (body-tokens + (loop :for term :in body :append + (tokenize-query-term term permanent-variables)))) + (flet ((compile% () (compile-tokens wam head-tokens body-tokens store))) + ;; We need to compile facts and rules differently. Facts end with + ;; a PROCEED and rules are wrapped in ALOC/DEAL. + (cond + ((and head body) ; a full-ass rule + (code-push-instruction! store +opcode-allocate+ (length permanent-variables)) + (compile%) + (code-push-instruction! store +opcode-deallocate+)) + ((and head (null body)) ; a bare fact + (compile%) + (code-push-instruction! store +opcode-proceed+)) + (t ; just a query + (compile%))))) + (values)) + +(defun compile-query (wam query) + "Compile `query` into a fresh array of bytecode. + + `query` should be a list of goal terms. + + " + (let ((store (make-query-code-store))) + (compile-clause wam store nil query) + store)) + +(defun compile-program (wam rule) + "Compile `rule` into the WAM's code store. + + `rule` should be a clause consisting of a head term and zero or more body + terms. A rule with no body is also called a \"fact\". + + " + (compile-clause wam (wam-code wam) (first rule) (rest rule)) + (values)) + diff -r ac5c1bfbe50a -r b8bc9b175636 src/wam/instructions.lisp --- a/src/wam/instructions.lisp Sat Apr 16 12:54:58 2016 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,422 +0,0 @@ -(in-package #:bones.wam) -(named-readtables:in-readtable :fare-quasiquote) - -;;;; Config -(defparameter *break-on-fail* nil) - - -;;;; Utilities -(defun* push-unbound-reference! ((wam wam)) - (:returns (values heap-cell heap-index)) - "Push a new unbound reference cell onto the heap." - (wam-heap-push! wam (make-cell-reference (wam-heap-pointer wam)))) - -(defun* push-new-structure! ((wam wam)) - (:returns (values heap-cell heap-index)) - "Push a new structure cell onto the heap. - - The structure cell's value will point at the next address, so make sure you - push something there too! - - " - (wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam))))) - -(defun* push-new-functor! ((wam wam) (functor functor-index)) - (:returns (values heap-cell heap-index)) - "Push a new functor cell onto the heap." - (wam-heap-push! wam (make-cell-functor functor))) - - -(defun* bound-reference-p ((wam wam) (address heap-index)) - (:returns boolean) - "Return whether the cell at `address` is a bound reference." - (ensure-boolean - (let ((cell (wam-heap-cell wam address))) - (and (cell-reference-p cell) - (not (= (cell-value cell) address)))))) - -(defun* unbound-reference-p ((wam wam) (address heap-index)) - (:returns boolean) - "Return whether the cell at `address` is an unbound reference." - (ensure-boolean - (let ((cell (wam-heap-cell wam address))) - (and (cell-reference-p cell) - (= (cell-value cell) address))))) - -(defun* matching-functor-p ((cell heap-cell) - (functor functor-index)) - (:returns boolean) - "Return whether `cell` is a functor cell containing `functor`." - (ensure-boolean - (and (cell-functor-p cell) - (= (cell-functor-index cell) functor)))) - -(defun* functors-match-p ((functor-cell-1 heap-cell) - (functor-cell-2 heap-cell)) - (:returns boolean) - "Return whether the two functor cells represent the same functor." - (= (cell-value functor-cell-1) - (cell-value functor-cell-2))) - - -(defun* deref ((wam wam) (address heap-index)) - (:returns heap-index) - "Dereference the address in the WAM to its eventual destination. - - If the address is a variable that's bound to something, that something will be - looked up (recursively) and the address of whatever it's ultimately bound to - will be returned. - - " - (if (bound-reference-p wam address) - (deref wam (cell-value (wam-heap-cell wam address))) - address)) - -(defun* bind! ((wam wam) (address-1 heap-index) (address-2 heap-index)) - (:returns :void) - "Bind the unbound reference cell to the other. - - `bind!` takes two addresses as arguments. At least one of these *must* refer - to an unbound reference cell. This unbound reference will be bound to point - at the other address. - - If both addresses refer to unbound references, the direction of the binding is - chosen arbitrarily. - - " - (cond - ((unbound-reference-p wam address-1) - (setf (wam-heap-cell wam address-1) - (make-cell-reference address-2))) - ((unbound-reference-p wam address-2) - (setf (wam-heap-cell wam address-2) - (make-cell-reference address-1))) - (t (error "At least one cell must be an unbound reference when binding."))) - (values)) - -(defun* fail! ((wam wam) (reason string)) - (:returns :void) - "Mark a failure in the WAM. - - If `*break-on-fail*` is true, the debugger will be invoked. - - " - (setf (wam-fail wam) t) - (when *break-on-fail* - (break "FAIL: ~A~%" reason)) - (values)) - - -(defun* unify! ((wam wam) (a1 heap-index) (a2 heap-index)) - (wam-unification-stack-push! wam a1) - (wam-unification-stack-push! wam a2) - (setf (wam-fail wam) nil) - ;; TODO: refactor this horror show. - (until (or (wam-fail wam) - (wam-unification-stack-empty-p wam)) - (let ((d1 (deref wam (wam-unification-stack-pop! wam))) - (d2 (deref wam (wam-unification-stack-pop! wam)))) - (when (not (= d1 d2)) - (let ((cell-1 (wam-heap-cell wam d1)) - (cell-2 (wam-heap-cell wam d2))) - (if (or (cell-reference-p cell-1) - (cell-reference-p cell-2)) - ;; If at least one is a reference, bind them. - ;; - ;; We know that any references we see here will be unbound, - ;; because we deref'ed them above. - (bind! wam d1 d2) - ;; Otherwise we're looking at two structures (hopefully, lol). - (let* ((structure-1-addr (cell-value cell-1)) ; find where they - (structure-2-addr (cell-value cell-2)) ; start on the heap - (functor-1 (wam-heap-cell wam structure-1-addr)) ; grab the - (functor-2 (wam-heap-cell wam structure-2-addr))) ; functors - (if (functors-match-p functor-1 functor-2) - ;; If the functors match, push their pairs of arguments onto - ;; the stack to be unified. - (loop :with arity = (cdr (wam-functor-lookup wam functor-1)) - :for i :from 1 :to arity :do - (wam-unification-stack-push! wam (+ structure-1-addr i)) - (wam-unification-stack-push! wam (+ structure-2-addr i))) - ;; Otherwise we're hosed. - (fail! wam "Functors don't match in unify!"))))))))) - - -;;;; Query Instructions -(defun* %put-structure ((wam wam) - (functor functor-index) - (register register-designator)) - (:returns :void) - (->> (push-new-structure! wam) - (nth-value 1) - (setf (wam-register wam register))) - (push-new-functor! wam functor) - (values)) - -(defun* %set-variable ((wam wam) (register register-designator)) - (:returns :void) - (->> (push-unbound-reference! wam) - (nth-value 1) - (setf (wam-register wam register))) - (values)) - -(defun* %set-value ((wam wam) (register register-designator)) - (:returns :void) - (wam-heap-push! wam (wam-register-cell wam register)) - (values)) - -(defun* %put-variable ((wam wam) - (register register-designator) - (argument register-designator)) - (:returns :void) - (->> (push-unbound-reference! wam) - (nth-value 1) - (setf (wam-register wam register)) - (setf (wam-register wam argument))) - (values)) - -(defun* %put-value ((wam wam) - (register register-designator) - (argument register-designator)) - (:returns :void) - (setf (wam-register wam argument) - (wam-register wam register)) - (values)) - - -;;;; Program Instructions -(defun* %get-structure ((wam wam) - (functor functor-index) - (register register-designator)) - (:returns :void) - (let* ((addr (deref wam (wam-register wam register))) - (cell (wam-heap-cell wam addr))) - (cond - ;; If the register points at a reference cell, we push two new cells onto - ;; the heap: - ;; - ;; | N | STR | N+1 | - ;; | N+1 | FUN | f/n | - ;; - ;; Then we bind this reference cell to point at the new structure and flip - ;; over to write mode. - ;; - ;; It seems a bit confusing that we don't push the rest of the structure - ;; stuff on the heap after it too. But that's going to happen in the next - ;; few instructions (which will be unify-*'s, executed in write mode). - ((cell-reference-p cell) - (let ((new-structure-address (nth-value 1 (push-new-structure! wam)))) - (push-new-functor! wam functor) - (bind! wam addr new-structure-address) - (setf (wam-mode wam) :write))) - - ;; If the register points at a structure cell, then we look at where that - ;; cell points (which will be the functor cell for the structure): - ;; - ;; | N | STR | M | points at the structure, not necessarily contiguous - ;; | ... | - ;; | M | FUN | f/2 | the functor (hopefully it matches) - ;; | M+1 | ... | ... | pieces of the structure, always contiguous - ;; | M+2 | ... | ... | and always right after the functor - ;; - ;; If it matches the functor we're looking for, we can proceed. We set - ;; the S register to the address of the first subform we need to match - ;; (M+1 in the example above). - ;; - ;; What about if it's a 0-arity functor? The S register will be set to - ;; garbage. But that's okay, because we know the next thing in the stream - ;; of instructions will be another get-structure and we'll just blow away - ;; the S register there. - ((cell-structure-p cell) - (let* ((functor-addr (cell-value cell)) - (functor-cell (wam-heap-cell wam functor-addr))) - (if (matching-functor-p functor-cell functor) - (progn - (setf (wam-s wam) (1+ functor-addr)) - (setf (wam-mode wam) :read)) - (fail! wam "Functors don't match in get-struct")))) - (t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A" - (cell-aesthetic cell)))))) - (values)) - -(defun* %unify-variable ((wam wam) (register register-designator)) - (:returns :void) - (ecase (wam-mode wam) - (:read (setf (wam-register wam register) - (wam-s wam))) - (:write (->> (push-unbound-reference! wam) - (nth-value 1) - (setf (wam-register wam register))))) - (incf (wam-s wam)) - (values)) - -(defun* %unify-value ((wam wam) (register register-designator)) - (:returns :void) - (ecase (wam-mode wam) - (:read (unify! wam - (wam-register wam register) - (wam-s wam))) - (:write (wam-heap-push! wam (wam-register-cell wam register)))) - (incf (wam-s wam)) - (values)) - -(defun* %get-variable ((wam wam) - (register register-designator) - (argument register-designator)) - (:returns :void) - (setf (wam-register wam register) - (wam-register wam argument)) - (values)) - -(defun* %get-value ((wam wam) - (register register-designator) - (argument register-designator)) - (:returns :void) - (unify! wam - (wam-register wam register) - (wam-register wam argument)) - (values)) - - -;;;; Control Instructions -(defun* %call ((wam wam) (functor functor-index)) - (:returns :void) - (let ((target (wam-code-label wam functor))) - (if target - (progn - (setf (wam-continuation-pointer wam) ; CP <- next instruction - (+ (wam-program-counter wam) - (instruction-size +opcode-call+)) - (wam-program-counter wam) ; PC <- target - target)) - (fail! wam "Tried to call unknown procedure."))) - (values)) - -(defun* %proceed ((wam wam)) - (:returns :void) - (setf (wam-program-counter wam) ; P <- CP - (wam-continuation-pointer wam)) - (values)) - -(defun* %allocate ((wam wam) (n stack-frame-argcount)) - (:returns :void) - (setf (wam-environment-pointer wam) ; E <- new E - (->> wam - wam-environment-pointer - (wam-stack-push! wam) ; CE - (nth-value 1))) - (wam-stack-push! wam (wam-continuation-pointer wam)) ; CP - (wam-stack-push! wam n) ; N - (wam-stack-extend! wam n)) ; Y_n (TODO: this sucks) - -(defun* %deallocate ((wam wam)) - (:returns :void) - (setf (wam-program-counter wam) - (wam-stack-frame-cp wam)) - (wam-stack-pop-environment! wam)) - - -;;;; Running -(defmacro instruction-call (wam instruction code-store pc number-of-arguments) - "Expand into a call of the appropriate machine instruction. - - `pc` should be a safe place representing the program counter. - - `code-store` should be a safe place representing the instructions. - - " - `(,instruction ,wam - ,@(loop :for i :from 1 :to number-of-arguments - :collect `(aref ,code-store (+ ,pc ,i))))) - - -(defun extract-query-results (wam goal) - ;; TODO: rehaul this - (let ((results (list))) - (labels ((recur (original result) - (cond - ((and (variable-p original) - (not (assoc original results))) - (push (cons original - (match result - (`(,bare-functor) bare-functor) - (r r))) - results)) - ((consp original) - (recur (car original) (car result)) - (recur (cdr original) (cdr result))) - (t nil)))) - (loop :for argument :in (cdr goal) - :for a :from 0 - :do (recur argument - (extract-thing - wam - ;; results are stored in local (argument) registers - (wam-local-register wam a))))) - results)) - - -(defun run-program (wam functor &optional (step nil)) - (with-slots (code program-counter fail) wam - (setf program-counter (wam-code-label wam functor)) - (loop - :while (and (not fail) ; failure - (not (= program-counter +code-sentinal+))) ; finished - :for opcode = (aref code program-counter) - :do - (block op - (when step - (break "About to execute instruction at ~4,'0X" program-counter)) - (eswitch (opcode) - (+opcode-get-structure+ (instruction-call wam %get-structure code program-counter 2)) - (+opcode-unify-variable+ (instruction-call wam %unify-variable code program-counter 1)) - (+opcode-unify-value+ (instruction-call wam %unify-value code program-counter 1)) - (+opcode-get-variable+ (instruction-call wam %get-variable code program-counter 2)) - (+opcode-get-value+ (instruction-call wam %get-value code program-counter 2)) - ;; need to skip the PC increment for PROC/CALL - ;; TODO: this is ugly - (+opcode-proceed+ (instruction-call wam %proceed code program-counter 0) - (return-from op)) - (+opcode-call+ (instruction-call wam %call code program-counter 1) - (return-from op))) - (incf program-counter (instruction-size opcode)) - (when (>= program-counter (fill-pointer code)) - (error "Fell off the end of the program code store!")))) - (values))) - -(defun run-query (wam term &optional (step nil)) - "Compile query `term` and run the instructions on the `wam`. - - Resets the heap, etc before running. - - When `step` is true, break into the debugger before calling the procedure. - - " - (let ((code (compile-query wam term))) - (wam-reset! wam) - (loop - :with pc = 0 ; local program counter for this hunk of query code - :for opcode = (aref code pc) - :do - (progn - (eswitch (opcode) - (+opcode-put-structure+ (instruction-call wam %put-structure code pc 2)) - (+opcode-set-variable+ (instruction-call wam %set-variable code pc 1)) - (+opcode-set-value+ (instruction-call wam %set-value code pc 1)) - (+opcode-put-variable+ (instruction-call wam %put-variable code pc 2)) - (+opcode-put-value+ (instruction-call wam %put-value code pc 2)) - (+opcode-call+ - (when step (break)) - (setf (wam-continuation-pointer wam) +code-sentinal+) - (run-program wam (aref code (+ pc 1)) step) - (return))) - (incf pc (instruction-size opcode)) - (when (>= pc (length code)) ; queries SHOULD always end in a CALL... - (error "Fell off the end of the query code store!"))))) - (if (wam-fail wam) - (princ "No.") - (loop :for (var . val) :in (extract-query-results wam (first term)) - :do (format t "~S -> ~S~%" var val))) - (values)) - - diff -r ac5c1bfbe50a -r b8bc9b175636 src/wam/interpreter.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/wam/interpreter.lisp Sat Apr 16 13:07:16 2016 +0000 @@ -0,0 +1,422 @@ +(in-package #:bones.wam) +(named-readtables:in-readtable :fare-quasiquote) + +;;;; Config +(defparameter *break-on-fail* nil) + + +;;;; Utilities +(defun* push-unbound-reference! ((wam wam)) + (:returns (values heap-cell heap-index)) + "Push a new unbound reference cell onto the heap." + (wam-heap-push! wam (make-cell-reference (wam-heap-pointer wam)))) + +(defun* push-new-structure! ((wam wam)) + (:returns (values heap-cell heap-index)) + "Push a new structure cell onto the heap. + + The structure cell's value will point at the next address, so make sure you + push something there too! + + " + (wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam))))) + +(defun* push-new-functor! ((wam wam) (functor functor-index)) + (:returns (values heap-cell heap-index)) + "Push a new functor cell onto the heap." + (wam-heap-push! wam (make-cell-functor functor))) + + +(defun* bound-reference-p ((wam wam) (address heap-index)) + (:returns boolean) + "Return whether the cell at `address` is a bound reference." + (ensure-boolean + (let ((cell (wam-heap-cell wam address))) + (and (cell-reference-p cell) + (not (= (cell-value cell) address)))))) + +(defun* unbound-reference-p ((wam wam) (address heap-index)) + (:returns boolean) + "Return whether the cell at `address` is an unbound reference." + (ensure-boolean + (let ((cell (wam-heap-cell wam address))) + (and (cell-reference-p cell) + (= (cell-value cell) address))))) + +(defun* matching-functor-p ((cell heap-cell) + (functor functor-index)) + (:returns boolean) + "Return whether `cell` is a functor cell containing `functor`." + (ensure-boolean + (and (cell-functor-p cell) + (= (cell-functor-index cell) functor)))) + +(defun* functors-match-p ((functor-cell-1 heap-cell) + (functor-cell-2 heap-cell)) + (:returns boolean) + "Return whether the two functor cells represent the same functor." + (= (cell-value functor-cell-1) + (cell-value functor-cell-2))) + + +(defun* deref ((wam wam) (address heap-index)) + (:returns heap-index) + "Dereference the address in the WAM to its eventual destination. + + If the address is a variable that's bound to something, that something will be + looked up (recursively) and the address of whatever it's ultimately bound to + will be returned. + + " + (if (bound-reference-p wam address) + (deref wam (cell-value (wam-heap-cell wam address))) + address)) + +(defun* bind! ((wam wam) (address-1 heap-index) (address-2 heap-index)) + (:returns :void) + "Bind the unbound reference cell to the other. + + `bind!` takes two addresses as arguments. At least one of these *must* refer + to an unbound reference cell. This unbound reference will be bound to point + at the other address. + + If both addresses refer to unbound references, the direction of the binding is + chosen arbitrarily. + + " + (cond + ((unbound-reference-p wam address-1) + (setf (wam-heap-cell wam address-1) + (make-cell-reference address-2))) + ((unbound-reference-p wam address-2) + (setf (wam-heap-cell wam address-2) + (make-cell-reference address-1))) + (t (error "At least one cell must be an unbound reference when binding."))) + (values)) + +(defun* fail! ((wam wam) (reason string)) + (:returns :void) + "Mark a failure in the WAM. + + If `*break-on-fail*` is true, the debugger will be invoked. + + " + (setf (wam-fail wam) t) + (when *break-on-fail* + (break "FAIL: ~A~%" reason)) + (values)) + + +(defun* unify! ((wam wam) (a1 heap-index) (a2 heap-index)) + (wam-unification-stack-push! wam a1) + (wam-unification-stack-push! wam a2) + (setf (wam-fail wam) nil) + ;; TODO: refactor this horror show. + (until (or (wam-fail wam) + (wam-unification-stack-empty-p wam)) + (let ((d1 (deref wam (wam-unification-stack-pop! wam))) + (d2 (deref wam (wam-unification-stack-pop! wam)))) + (when (not (= d1 d2)) + (let ((cell-1 (wam-heap-cell wam d1)) + (cell-2 (wam-heap-cell wam d2))) + (if (or (cell-reference-p cell-1) + (cell-reference-p cell-2)) + ;; If at least one is a reference, bind them. + ;; + ;; We know that any references we see here will be unbound, + ;; because we deref'ed them above. + (bind! wam d1 d2) + ;; Otherwise we're looking at two structures (hopefully, lol). + (let* ((structure-1-addr (cell-value cell-1)) ; find where they + (structure-2-addr (cell-value cell-2)) ; start on the heap + (functor-1 (wam-heap-cell wam structure-1-addr)) ; grab the + (functor-2 (wam-heap-cell wam structure-2-addr))) ; functors + (if (functors-match-p functor-1 functor-2) + ;; If the functors match, push their pairs of arguments onto + ;; the stack to be unified. + (loop :with arity = (cdr (wam-functor-lookup wam functor-1)) + :for i :from 1 :to arity :do + (wam-unification-stack-push! wam (+ structure-1-addr i)) + (wam-unification-stack-push! wam (+ structure-2-addr i))) + ;; Otherwise we're hosed. + (fail! wam "Functors don't match in unify!"))))))))) + + +;;;; Query Instructions +(defun* %put-structure ((wam wam) + (functor functor-index) + (register register-designator)) + (:returns :void) + (->> (push-new-structure! wam) + (nth-value 1) + (setf (wam-register wam register))) + (push-new-functor! wam functor) + (values)) + +(defun* %set-variable ((wam wam) (register register-designator)) + (:returns :void) + (->> (push-unbound-reference! wam) + (nth-value 1) + (setf (wam-register wam register))) + (values)) + +(defun* %set-value ((wam wam) (register register-designator)) + (:returns :void) + (wam-heap-push! wam (wam-register-cell wam register)) + (values)) + +(defun* %put-variable ((wam wam) + (register register-designator) + (argument register-designator)) + (:returns :void) + (->> (push-unbound-reference! wam) + (nth-value 1) + (setf (wam-register wam register)) + (setf (wam-register wam argument))) + (values)) + +(defun* %put-value ((wam wam) + (register register-designator) + (argument register-designator)) + (:returns :void) + (setf (wam-register wam argument) + (wam-register wam register)) + (values)) + + +;;;; Program Instructions +(defun* %get-structure ((wam wam) + (functor functor-index) + (register register-designator)) + (:returns :void) + (let* ((addr (deref wam (wam-register wam register))) + (cell (wam-heap-cell wam addr))) + (cond + ;; If the register points at a reference cell, we push two new cells onto + ;; the heap: + ;; + ;; | N | STR | N+1 | + ;; | N+1 | FUN | f/n | + ;; + ;; Then we bind this reference cell to point at the new structure and flip + ;; over to write mode. + ;; + ;; It seems a bit confusing that we don't push the rest of the structure + ;; stuff on the heap after it too. But that's going to happen in the next + ;; few instructions (which will be unify-*'s, executed in write mode). + ((cell-reference-p cell) + (let ((new-structure-address (nth-value 1 (push-new-structure! wam)))) + (push-new-functor! wam functor) + (bind! wam addr new-structure-address) + (setf (wam-mode wam) :write))) + + ;; If the register points at a structure cell, then we look at where that + ;; cell points (which will be the functor cell for the structure): + ;; + ;; | N | STR | M | points at the structure, not necessarily contiguous + ;; | ... | + ;; | M | FUN | f/2 | the functor (hopefully it matches) + ;; | M+1 | ... | ... | pieces of the structure, always contiguous + ;; | M+2 | ... | ... | and always right after the functor + ;; + ;; If it matches the functor we're looking for, we can proceed. We set + ;; the S register to the address of the first subform we need to match + ;; (M+1 in the example above). + ;; + ;; What about if it's a 0-arity functor? The S register will be set to + ;; garbage. But that's okay, because we know the next thing in the stream + ;; of instructions will be another get-structure and we'll just blow away + ;; the S register there. + ((cell-structure-p cell) + (let* ((functor-addr (cell-value cell)) + (functor-cell (wam-heap-cell wam functor-addr))) + (if (matching-functor-p functor-cell functor) + (progn + (setf (wam-s wam) (1+ functor-addr)) + (setf (wam-mode wam) :read)) + (fail! wam "Functors don't match in get-struct")))) + (t (fail! wam (format nil "get-struct on a non-ref/struct cell ~A" + (cell-aesthetic cell)))))) + (values)) + +(defun* %unify-variable ((wam wam) (register register-designator)) + (:returns :void) + (ecase (wam-mode wam) + (:read (setf (wam-register wam register) + (wam-s wam))) + (:write (->> (push-unbound-reference! wam) + (nth-value 1) + (setf (wam-register wam register))))) + (incf (wam-s wam)) + (values)) + +(defun* %unify-value ((wam wam) (register register-designator)) + (:returns :void) + (ecase (wam-mode wam) + (:read (unify! wam + (wam-register wam register) + (wam-s wam))) + (:write (wam-heap-push! wam (wam-register-cell wam register)))) + (incf (wam-s wam)) + (values)) + +(defun* %get-variable ((wam wam) + (register register-designator) + (argument register-designator)) + (:returns :void) + (setf (wam-register wam register) + (wam-register wam argument)) + (values)) + +(defun* %get-value ((wam wam) + (register register-designator) + (argument register-designator)) + (:returns :void) + (unify! wam + (wam-register wam register) + (wam-register wam argument)) + (values)) + + +;;;; Control Instructions +(defun* %call ((wam wam) (functor functor-index)) + (:returns :void) + (let ((target (wam-code-label wam functor))) + (if target + (progn + (setf (wam-continuation-pointer wam) ; CP <- next instruction + (+ (wam-program-counter wam) + (instruction-size +opcode-call+)) + (wam-program-counter wam) ; PC <- target + target)) + (fail! wam "Tried to call unknown procedure."))) + (values)) + +(defun* %proceed ((wam wam)) + (:returns :void) + (setf (wam-program-counter wam) ; P <- CP + (wam-continuation-pointer wam)) + (values)) + +(defun* %allocate ((wam wam) (n stack-frame-argcount)) + (:returns :void) + (setf (wam-environment-pointer wam) ; E <- new E + (->> wam + wam-environment-pointer + (wam-stack-push! wam) ; CE + (nth-value 1))) + (wam-stack-push! wam (wam-continuation-pointer wam)) ; CP + (wam-stack-push! wam n) ; N + (wam-stack-extend! wam n)) ; Y_n (TODO: this sucks) + +(defun* %deallocate ((wam wam)) + (:returns :void) + (setf (wam-program-counter wam) + (wam-stack-frame-cp wam)) + (wam-stack-pop-environment! wam)) + + +;;;; Running +(defmacro instruction-call (wam instruction code-store pc number-of-arguments) + "Expand into a call of the appropriate machine instruction. + + `pc` should be a safe place representing the program counter. + + `code-store` should be a safe place representing the instructions. + + " + `(,instruction ,wam + ,@(loop :for i :from 1 :to number-of-arguments + :collect `(aref ,code-store (+ ,pc ,i))))) + + +(defun extract-query-results (wam goal) + ;; TODO: rehaul this + (let ((results (list))) + (labels ((recur (original result) + (cond + ((and (variable-p original) + (not (assoc original results))) + (push (cons original + (match result + (`(,bare-functor) bare-functor) + (r r))) + results)) + ((consp original) + (recur (car original) (car result)) + (recur (cdr original) (cdr result))) + (t nil)))) + (loop :for argument :in (cdr goal) + :for a :from 0 + :do (recur argument + (extract-thing + wam + ;; results are stored in local (argument) registers + (wam-local-register wam a))))) + results)) + + +(defun run-program (wam functor &optional (step nil)) + (with-slots (code program-counter fail) wam + (setf program-counter (wam-code-label wam functor)) + (loop + :while (and (not fail) ; failure + (not (= program-counter +code-sentinal+))) ; finished + :for opcode = (aref code program-counter) + :do + (block op + (when step + (break "About to execute instruction at ~4,'0X" program-counter)) + (eswitch (opcode) + (+opcode-get-structure+ (instruction-call wam %get-structure code program-counter 2)) + (+opcode-unify-variable+ (instruction-call wam %unify-variable code program-counter 1)) + (+opcode-unify-value+ (instruction-call wam %unify-value code program-counter 1)) + (+opcode-get-variable+ (instruction-call wam %get-variable code program-counter 2)) + (+opcode-get-value+ (instruction-call wam %get-value code program-counter 2)) + ;; need to skip the PC increment for PROC/CALL + ;; TODO: this is ugly + (+opcode-proceed+ (instruction-call wam %proceed code program-counter 0) + (return-from op)) + (+opcode-call+ (instruction-call wam %call code program-counter 1) + (return-from op))) + (incf program-counter (instruction-size opcode)) + (when (>= program-counter (fill-pointer code)) + (error "Fell off the end of the program code store!")))) + (values))) + +(defun run-query (wam term &optional (step nil)) + "Compile query `term` and run the instructions on the `wam`. + + Resets the heap, etc before running. + + When `step` is true, break into the debugger before calling the procedure. + + " + (let ((code (compile-query wam term))) + (wam-reset! wam) + (loop + :with pc = 0 ; local program counter for this hunk of query code + :for opcode = (aref code pc) + :do + (progn + (eswitch (opcode) + (+opcode-put-structure+ (instruction-call wam %put-structure code pc 2)) + (+opcode-set-variable+ (instruction-call wam %set-variable code pc 1)) + (+opcode-set-value+ (instruction-call wam %set-value code pc 1)) + (+opcode-put-variable+ (instruction-call wam %put-variable code pc 2)) + (+opcode-put-value+ (instruction-call wam %put-value code pc 2)) + (+opcode-call+ + (when step (break)) + (setf (wam-continuation-pointer wam) +code-sentinal+) + (run-program wam (aref code (+ pc 1)) step) + (return))) + (incf pc (instruction-size opcode)) + (when (>= pc (length code)) ; queries SHOULD always end in a CALL... + (error "Fell off the end of the query code store!"))))) + (if (wam-fail wam) + (princ "No.") + (loop :for (var . val) :in (extract-query-results wam (first term)) + :do (format t "~S -> ~S~%" var val))) + (values)) + + diff -r ac5c1bfbe50a -r b8bc9b175636 src/wam/topological-sort.lisp --- a/src/wam/topological-sort.lisp Sat Apr 16 12:54:58 2016 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,47 +0,0 @@ -(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 `(key . key)` conses where `(foo . bar)` - means element `foo` must precede `bar` in the result. - - `key` will be used to turn items in `elements` into the keys in `constraints`. - - `key-test` is the equality predicate for keys. - - `test` is the equality predicate for (non-keyified) elements. - - " - (labels - ((minimal-p (element constraints) - ;; An element is minimal if there are no other elements that must - ;; precede it. - (not (member (funcall key element) constraints - :key #'cdr - :test key-test))) - (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-element - (find-if (lambda (el) - (minimal-p el remaining-constraints)) - remaining-elements))) - (if (null minimal-element) - (if (null remaining-elements) - result - (error "Inconsistent constraints.")) - (recur (remove (funcall key minimal-element) - remaining-constraints - :test #'in-constraint) - (remove minimal-element remaining-elements :test test) - (cons minimal-element result)))))) - (reverse (recur constraints elements (list)))))