--- 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")))))
--- 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
--- 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)))))
--- 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))
-
--- /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))
+
--- 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))
-
-
--- /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))
+
+
--- 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)))))