--- a/.lispwords Sun Apr 10 18:17:03 2016 +0000
+++ b/.lispwords Wed Apr 13 17:38:57 2016 +0000
@@ -1,1 +1,2 @@
(1 vector-push-extend-all)
+(2 code-push-instruction!)
--- a/Makefile Sun Apr 10 18:17:03 2016 +0000
+++ b/Makefile Wed Apr 13 17:38:57 2016 +0000
@@ -5,13 +5,13 @@
apidoc = docs/03-reference.markdown
test:
- sbcl --noinform --load test/run.lisp --eval '(quit)'
+ sbcl-rlwrap --noinform --load test/run.lisp --eval '(quit)'
src/quickutils.lisp: src/make-quickutils.lisp
- cd src && sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
+ cd src && sbcl-rlwrap --noinform --load make-quickutils.lisp --eval '(quit)'
$(apidoc): $(sourcefiles) docs/api.lisp
- sbcl --noinform --load docs/api.lisp --eval '(quit)'
+ sbcl-rlwrap --noinform --load docs/api.lisp --eval '(quit)'
docs: docs/build/index.html
--- a/src/make-quickutils.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/make-quickutils.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -10,6 +10,7 @@
:while
:until
:tree-member-p
+ :tree-collect
:with-gensyms
:map-tree
)
--- a/src/quickutils.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/quickutils.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :WITH-GENSYMS :MAP-TREE) :ensure-package T :package "BONES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :MAP-TREE) :ensure-package T :package "BONES.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.QUICKUTILS")
@@ -18,7 +18,7 @@
:CURRY :STRING-DESIGNATOR
:WITH-GENSYMS :EXTRACT-FUNCTION-NAME
:SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
- :TREE-MEMBER-P :MAP-TREE))))
+ :TREE-MEMBER-P :TREE-COLLECT :MAP-TREE))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -235,6 +235,25 @@
(rec tree)))
+ (defun tree-collect (predicate tree)
+ "Returns a list of every node in the `tree` that satisfies the `predicate`. If there are any improper lists in the tree, the `predicate` is also applied to their dotted elements."
+ (let ((sentinel (gensym)))
+ (flet ((my-cdr (obj)
+ (cond ((consp obj)
+ (let ((result (cdr obj)))
+ (if (listp result)
+ result
+ (list result sentinel))))
+ (t
+ (list sentinel)))))
+ (loop :for (item . rest) :on tree :by #'my-cdr
+ :until (eq item sentinel)
+ :if (funcall predicate item) collect item
+ :else
+ :if (listp item)
+ :append (tree-collect predicate item)))))
+
+
(defun map-tree (function tree)
"Map `function` to each of the leave of `tree`."
(check-type tree cons)
@@ -249,7 +268,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(define-constant set-equal curry switch eswitch cswitch
- ensure-boolean while until tree-member-p with-gensyms
+ ensure-boolean while until tree-member-p tree-collect with-gensyms
with-unique-names map-tree)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/wam/compile.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/wam/compile.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -18,7 +18,32 @@
(defun find-assignment (register assignments)
"Find the assignment for the given register number in the assignment list."
- (find register assignments :key #'car))
+ (assoc register assignments))
+
+
+(defun variable-p (term)
+ (keywordp term))
+
+(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 variable-assignment-p (ass)
@@ -84,7 +109,12 @@
(defun parse-term (term)
"Parse a term into a series of register assignments.
- Return the assignment list, the root functor, and the root functor's arity.
+ Return:
+
+ * The assignment list
+ * The register types
+ * The root functor
+ * The root functor's arity
"
;; A term is a Lispy representation of the raw Prolog. A register assignment
@@ -104,9 +134,7 @@
;; We'll fill them in later.
(registers (make-array 64 :fill-pointer arity :adjustable t)))
(labels
- ((variable-p (term)
- (keywordp term))
- (parse-variable (var)
+ ((parse-variable (var)
;; If we've already seen this variable, just return its position,
;; otherwise allocate a register for it.
(or (position var registers)
@@ -140,7 +168,7 @@
arity))))
-(defun inline-structure-argument-assignments (assignments functor arity)
+(defun inline-structure-argument-assignments (assignments arity)
"Inline structure register assignments directly into the argument registers."
;; After parsing the term we end up with something like:
;;
@@ -166,9 +194,20 @@
(cons argument-register
(recur (1- remaining)
(cdr assignments))))))))
- (values (sort (recur arity assignments) #'< :key #'car)
- functor
- arity)))
+ (sort (recur arity assignments) #'< :key #'car)))
+
+(defun register-types (assignments arity permanent-variables)
+ "Return the alist of register types for the given register assignments.
+
+ `assignments` must be sorted, and not flattened yet.
+
+ "
+ (loop :for i :from 0
+ :for (register . contents) :in assignments :collect
+ (cons i (cond
+ ((< i arity) :argument)
+ ((member contents permanent-variables) :permanent)
+ (t :local)))))
;;;; Flattening
@@ -218,28 +257,22 @@
assignments))
-(defun flatten (assignments functor arity)
+(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.
"
- (values (-<> assignments
- (topological-sort <> (find-dependencies assignments) :key #'car)
- (remove-if #'variable-assignment-p <>))
- functor
- arity))
+ (-<> assignments
+ (topological-sort <> (find-dependencies assignments) :key #'car)
+ (remove-if #'variable-assignment-p <>)))
-(defun flatten-query (registers functor arity)
- (flatten registers functor arity))
+(defun flatten-query (assignments)
+ (flatten assignments))
-(defun flatten-program (registers functor arity)
- (multiple-value-bind (assignments functor arity)
- (flatten registers functor arity)
- (values (reverse assignments)
- functor
- arity)))
+(defun flatten-program (assignments)
+ (reverse (flatten assignments)))
;;;; Tokenization
@@ -254,33 +287,81 @@
;;;
;;; (X2 = q/2), X1, X3, (X0 = p/2), X1, X2
-(defun tokenize-assignments (assignments functor arity)
+(defun tokenize-assignments (assignments arity)
"Tokenize a flattened set of register assignments into a stream."
- (values
- (mapcan
- (lambda (ass)
- ;; Take a single assignment like:
- ;; X1 = f(a, b, c) (1 . (f a b c))
- ;; A0 = X5 (0 . 5)
- ;;
- ;; And turn it into a stream of tokens:
- ;; (X1 = f/3), a, b, c ((:structure 1 f 3) a b c)
- ;; (A0 = X5) ((:argument 0 5))
- (if (register-assignment-p ass)
- ;; It might be a register assignment for an argument register.
- (destructuring-bind (argument-register . target-register) ass
- (assert (< argument-register arity) ()
- "Cannot tokenize register assignment to non-argument register ~D in ~A/~D:~%~S."
- argument-register functor arity assignments)
- (list (list :argument argument-register target-register)))
- ;; Otherwise it's a structure assignment. We know the others have
- ;; gotten flattened away by now.
- (destructuring-bind (register . (functor . arguments)) ass
- (cons (list :structure register functor (length arguments))
- arguments))))
- assignments)
- functor
- arity))
+ (mapcan
+ (lambda (ass)
+ ;; Take a single assignment like:
+ ;; X1 = f(a, b, c) (1 . (f a b c))
+ ;; A0 = X5 (0 . 5)
+ ;;
+ ;; And turn it into a stream of tokens:
+ ;; (X1 = f/3), a, b, c ((:structure 1 f 3) a b c)
+ ;; (A0 = X5) ((:argument 0 5))
+ (if (register-assignment-p ass)
+ ;; It might be a register assignment for an argument register.
+ (destructuring-bind (argument-register . target-register) ass
+ (assert (< argument-register arity) ()
+ "Cannot tokenize register assignment to non-argument register ~D in ???/~D:~%~S."
+ argument-register arity assignments)
+ (list (list :argument argument-register target-register)))
+ ;; Otherwise it's a structure assignment. We know the others have
+ ;; gotten flattened away by now.
+ (destructuring-bind (register . (functor . arguments)) ass
+ (cons (list :structure register functor (length arguments))
+ arguments))))
+ assignments))
+
+
+(defun zip-register-types (tokens register-types)
+ (labels
+ ((get-type (register)
+ (cdr (assoc register register-types)))
+ (update-leaf (leaf)
+ (if (numberp leaf)
+ (cons (get-type leaf) leaf)
+ leaf))
+ (fix-token (token)
+ (match token
+ (`(:structure ,register ,functor ,arity)
+ `(:structure (,(get-type register) . ,register)
+ ,functor
+ ,arity))
+ ((guard n (numberp n))
+ (update-leaf n))
+ (other (map-tree #'update-leaf other)))))
+ (mapcar #'fix-token tokens)))
+
+
+(defun tokenize-term (term permanent-variables flattener)
+ (multiple-value-bind (assignments functor arity)
+ (parse-term term)
+ (let* ((assignments (inline-structure-argument-assignments assignments
+ arity))
+ (register-types (register-types assignments
+ arity
+ permanent-variables))
+ (assignments (funcall flattener assignments))
+ (tokens (tokenize-assignments assignments arity)))
+ (values (zip-register-types tokens register-types)
+ functor
+ arity))))
+
+(defun tokenize-program-term (term permanent-variables)
+ "Tokenize `term` as a program term, returning its tokens, functor, and arity."
+ (multiple-value-bind (tokens functor arity)
+ (tokenize-term term permanent-variables #'flatten-program)
+ ;; We need to shove a PROCEED token onto the end.
+ (values (append tokens `((:proceed)))
+ functor
+ arity)))
+
+(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
@@ -300,38 +381,61 @@
;;; (#'%set-value 1)
;;; (#'%set-value 2)
-(defun compile-tokens (wam tokens store mode)
- "Generate a series of machine instructions from a stream of tokens.
+(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
- `vector-push-extend.`
+ `code-push-instructions!`.
"
- (let ((seen (list)))
- (flet ((handle-argument (register target)
- ; OP X_n A_i
- (vector-push-extend-all store
- (if (push-if-new target seen)
+ (let ((seen (list))
+ (mode nil))
+ (labels
+ ((handle-argument (argument-type argument source-type source)
+ (assert (eql argument-type :argument) ()
+ "Attempted argument assignment to non-argument register.")
+ (assert (member source-type '(:local :permanent)) ()
+ "Attempted argument assignment from non-permanent/local register.")
+ ; OP X_n A_i
+ (code-push-instruction! store
+ (if (push-if-new source seen)
(ecase mode
(:program +opcode-get-variable+)
(:query +opcode-put-variable+))
(ecase mode
(:program +opcode-get-value+)
(:query +opcode-put-value+)))
- target
- register))
- (handle-structure (register functor arity)
- ; OP functor reg
- (push register seen)
- (vector-push-extend-all store
+ source
+ argument))
+ (handle-structure (register-type register functor arity)
+ (assert (member register-type '(:local :argument)) ()
+ "Attempted structure assignment to non-local/argument register.")
+ ; OP functor reg
+ (push 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))
- (handle-register (register)
- ; OP reg
- (vector-push-extend-all store
+ (wam-ensure-functor-index wam (cons functor arity))
+ register))
+ (handle-call (functor arity)
+ (code-push-instruction! store
+ +opcode-call+
+ (wam-ensure-functor-index wam (cons functor arity))))
+ (handle-proceed ()
+ (code-push-instruction! store
+ +opcode-proceed+))
+ (handle-register (register-type register)
+ (declare (ignore register-type))
+ ; OP reg
+ (code-push-instruction! store
(if (push-if-new register seen)
(ecase mode
(:program +opcode-unify-variable+)
@@ -339,60 +443,78 @@
(ecase mode
(:program +opcode-unify-value+)
(:query +opcode-set-value+)))
- register)))
- (loop :for token :in tokens :collect
- (match token
- (`(:argument ,register ,target)
- (handle-argument register target))
- (`(:structure ,register ,functor ,arity)
- (handle-structure register functor arity))
- (register (handle-register register)))))))
+ register))
+ (handle-stream (tokens)
+ (loop :for token :in tokens :collect
+ (match token
+ (`(:argument (,argument-type . ,argument) (,source-type . ,source))
+ (handle-argument argument-type argument source-type source))
+ (`(:structure (,register-type . ,register) ,functor ,arity)
+ (handle-structure register-type register functor arity))
+ (`(:call ,functor ,arity)
+ (handle-call functor arity))
+ (`(:proceed)
+ (handle-proceed))
+ (`(,register-type . ,register)
+ (handle-register register-type register))))))
+ (when head-tokens
+ (setf mode :program)
+ (handle-stream head-tokens))
+ (setf mode :query)
+ (handle-stream body-tokens))))
-(defun compile-query-tokens (wam tokens functor arity store)
- (compile-tokens wam tokens store :query)
- (vector-push-extend-all store
- +opcode-call+
- (wam-ensure-functor-index wam (cons functor arity))))
-
-(defun compile-program-tokens (wam tokens functor arity store)
- ; todo: make this less ugly
+(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 (wam-code wam)))
- (compile-tokens wam tokens store :program)
- (vector-push-extend +opcode-proceed+ store))
+ (fill-pointer store)))
;;;; UI
-(defun compile-query (wam term)
- "Parse a Lisp query term into a series of WAM machine instructions.
+(defun make-query-code-store ()
+ (make-array 64
+ :fill-pointer 0
+ :adjustable t
+ :element-type 'code-word))
- The compiled code will be returned in a fresh array.
+(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 ((code (make-array 64
- :fill-pointer 0
- :adjustable t
- :element-type 'code-word)))
- (multiple-value-bind (tokens functor arity)
- (-<>> term
- parse-term
- (multiple-value-call #'inline-structure-argument-assignments)
- (multiple-value-call #'flatten-query)
- (multiple-value-call #'tokenize-assignments))
- (compile-query-tokens wam tokens functor arity code))
- code))
+ (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))))
+ (compile-tokens wam head-tokens body-tokens store))
+ (values))
-(defun compile-program (wam term)
- "Parse a Lisp program term into a series of WAM machine instructions.
+(defun compile-query (wam query)
+ "Compile `query` into a fresh array of bytecode.
- The compiled code will be placed at the top of the WAM code store.
+ `query` should be a list of goal terms.
"
- (multiple-value-bind (tokens functor arity)
- (-<>> term
- parse-term
- (multiple-value-call #'inline-structure-argument-assignments)
- (multiple-value-call #'flatten-program)
- (multiple-value-call #'tokenize-assignments))
- (compile-program-tokens wam tokens functor arity (wam-code wam))))
+ (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/constants.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/wam/constants.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -24,6 +24,9 @@
(define-constant +code-limit+ (expt 2 +code-word-size+)
:documentation "Maximum size of the WAM code store.")
+(define-constant +code-sentinal+ (1- +code-limit+)
+ :documentation "Sentinal value used in the PC and CP.")
+
(define-constant +tag-null+ #b00
:documentation "An empty cell.")
@@ -52,6 +55,11 @@
:documentation "The maximum allowed arity of functors.")
+(define-constant +maximum-query-size+ 256
+ :documentation
+ "The maximum size (in bytes of bytecode) a query may compile to.")
+
+
;;;; Opcodes
;;; Program
(define-constant +opcode-get-structure+ 1)
--- a/src/wam/dump.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/wam/dump.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -114,7 +114,7 @@
(first arguments)))
(defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)
- (format nil "PVAR~A ; A~D <- X~D <- new REF"
+ (format nil "PVAR~A ; A~D <- X~D <- new unbound REF"
(pretty-arguments arguments)
(second arguments)
(first arguments)))
@@ -144,6 +144,25 @@
(dump-code-store (wam-code wam) from to (wam-functors wam)))
+(defun extract-thing (wam address)
+ "Extract the thing at the given heap address and print it nicely."
+ (let ((cell (wam-heap-cell wam (deref wam address))))
+ (cond
+ ((cell-null-p cell)
+ "NULL!")
+ ((cell-reference-p cell)
+ (format nil "var-~D" (cell-value cell)))
+ ((cell-structure-p cell)
+ (extract-thing wam (cell-value cell)))
+ ((cell-functor-p cell)
+ (destructuring-bind (functor . arity)
+ (wam-functor-lookup wam (cell-functor-index cell))
+ (list* functor
+ (loop :for i :from (1+ address) :to (+ address arity)
+ :collect (extract-thing wam i)))))
+ (t (error "What to heck is this?")))))
+
+
(defun dump-wam-registers (wam)
(format t "REGISTERS:~%")
(format t "~5@A ->~6@A~%" "S" (wam-s wam))
@@ -151,12 +170,15 @@
:for reg :across (wam-registers wam)
:for contents = (when (not (= reg (1- +heap-limit+)))
(wam-register-cell wam i))
- :do (format t "~5@A ->~6@A ~A~%"
+ :do (format t "~5@A ->~6@A ~A ~A~%"
(format nil "X~D" i)
reg
(if contents
(cell-aesthetic contents)
- "unset"))))
+ "unset")
+ (if contents
+ (format nil "; ~A" (extract-thing wam reg))
+ ""))))
(defun dump-wam-functors (wam)
(format t " FUNCTORS: ~S~%" (wam-functors wam)))
@@ -195,20 +217,3 @@
addr))
-(defun extract-thing (wam address)
- "Extract the thing at the given heap address and print it nicely."
- (let ((cell (wam-heap-cell wam (deref wam address))))
- (cond
- ((cell-null-p cell)
- "NULL!")
- ((cell-reference-p cell)
- (format nil "var-~D" (cell-value cell)))
- ((cell-structure-p cell)
- (extract-thing wam (cell-value cell)))
- ((cell-functor-p cell)
- (destructuring-bind (functor . arity)
- (wam-functor-lookup wam (cell-functor-index cell))
- (list* functor
- (loop :for i :from (1+ address) :to (+ address arity)
- :collect (extract-thing wam i)))))
- (t (error "What to heck is this?")))))
--- a/src/wam/instructions.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/wam/instructions.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -94,6 +94,7 @@
"Mark a failure in the WAM."
(setf (wam-fail wam) t)
(format *debug-io* "FAIL: ~A~%" reason)
+ (break)
(values))
@@ -120,11 +121,12 @@
(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
+ (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 :for i :from 1 :to (cell-functor-arity functor-1) :do
+ (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.
@@ -265,7 +267,26 @@
(wam-register wam register)
(wam-register wam argument))
(values))
-
+
+(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))
+
;;;; Running
(defmacro instruction-call (wam instruction code-store pc number-of-arguments)
@@ -280,32 +301,47 @@
,@(loop :for i :from 1 :to number-of-arguments
:collect `(aref ,code-store (+ ,pc ,i)))))
-(defun run-program (wam functor)
- (with-slots (code program-counter) wam
+
+(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
- (progn
+ (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))
- (+opcode-proceed+ (return)))
+ ;; 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 (length code))
- ;; programs SHOULD always end in a PROCEED
- (error "Fell off the end of the program code store!"))))))
+ (when (>= program-counter (fill-pointer code))
+ (error "Fell off the end of the program code store!"))))
+ (if fail
+ (print "FAIL")
+ (print "SUCCESS"))))
(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)
@@ -319,7 +355,8 @@
(+opcode-put-value+ (instruction-call wam %put-value code pc 2))
(+opcode-call+
(when step (break))
- (run-program wam (aref code (+ pc 1)))
+ (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...
--- a/src/wam/types.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/wam/types.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -31,6 +31,7 @@
`(unsigned-byte ,+code-word-size+))
(deftype code-index ()
+ ; either an address or the sentinal
`(integer 0 ,(1- +code-limit+)))
(deftype opcode ()
--- a/src/wam/wam.lisp Sun Apr 10 18:17:03 2016 +0000
+++ b/src/wam/wam.lisp Wed Apr 13 17:38:57 2016 +0000
@@ -12,8 +12,8 @@
:documentation "The actual heap (stack).")
(code
:initform (make-array 1024
+ :adjustable t
:fill-pointer 0
- :adjustable t
:initial-element 0
:element-type 'code-word)
:reader wam-code
@@ -57,8 +57,13 @@
(program-counter
:accessor wam-program-counter
:initform 0
- :type 'code-index
- :documentation "The Program Counter for the WAM code store.")
+ :type code-index
+ :documentation "The Program Counter into the WAM code store.")
+ (continuation-pointer
+ :accessor wam-continuation-pointer
+ :initform 0
+ :type code-index
+ :documentation "The Continuation Pointer into the WAM code store.")
(mode
:accessor wam-mode
:initform nil
@@ -98,6 +103,23 @@
(setf (aref (wam-heap wam) address) new-value))
+(defun* wam-truncate-heap! ((wam wam))
+ (setf (fill-pointer (wam-heap wam)) 0))
+
+(defun* wam-reset-registers! ((wam wam))
+ (loop :for i :from 0 :below +register-count+ :do
+ (setf (wam-register wam i)
+ (1- +heap-limit+)))
+ (setf (wam-s wam) nil))
+
+(defun* wam-reset! ((wam wam))
+ (wam-truncate-heap! wam)
+ (wam-reset-registers! wam)
+ (setf (wam-program-counter wam) 0)
+ (setf (wam-continuation-pointer wam) 0)
+ (setf (wam-mode wam) nil))
+
+
;;;; Code
(defun* retrieve-instruction (code-store (address code-index))
"Return the full instruction at the given address in the code store."
@@ -122,15 +144,15 @@
(retrieve-instruction (wam-code wam) address))
-(defun* wam-code-push-word! ((wam wam) (word code-word))
+(defun* code-push-word! ((store (array code-word))
+ (word code-word))
"Push the given word into the code store and return its new address."
(:returns code-index)
- (with-slots (code) wam
- (if (= +code-limit+ (fill-pointer code))
- (error "WAM code store exhausted.")
- (vector-push-extend word code))))
+ (vector-push-extend word store))
-(defun* wam-code-push! ((wam wam) (opcode opcode) &rest (arguments code-word))
+(defun* code-push-instruction! ((store (array code-word))
+ (opcode opcode)
+ &rest (arguments code-word))
"Push the given instruction into the code store and return its new address.
The address will be the address of the start of the instruction (i.e. the
@@ -147,14 +169,14 @@
arguments
(instruction-size opcode))
(prog1
- (wam-code-push-word! wam opcode)
+ (code-push-word! store opcode)
(dolist (arg arguments)
- (wam-code-push-word! wam arg))))
+ (code-push-word! store arg))))
(defun* wam-code-label ((wam wam)
(functor functor-index))
- (:returns code-index)
+ (:returns (or null code-index))
(gethash functor (wam-code-labels wam)))
(defun (setf wam-code-label) (new-value wam functor)