# HG changeset patch # User Steve Losh # Date 1460569137 0 # Node ID fdb771cc2b8cf2ee987aee2c19a9ffc0b5291a0e # Parent 99abd362620ad239fecfd3f5b11f6a79f56c5048 Start working on L2 This changes the compilation process to keep track of register types, which we'll need to distinguish between local/permanent variables. It also makes things a bit more obvious/safe when compiling argument registers because they're tagged explicitly. This also changes up the actual running of the code by actually using CALL/PROCEED, though it's not fully fleshed out yet. diff -r 99abd362620a -r fdb771cc2b8c .lispwords --- 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!) diff -r 99abd362620a -r fdb771cc2b8c Makefile --- 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 diff -r 99abd362620a -r fdb771cc2b8c src/make-quickutils.lisp --- 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 ) diff -r 99abd362620a -r fdb771cc2b8c src/quickutils.lisp --- 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 ;;;; diff -r 99abd362620a -r fdb771cc2b8c src/wam/compile.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)) + diff -r 99abd362620a -r fdb771cc2b8c src/wam/constants.lisp --- 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) diff -r 99abd362620a -r fdb771cc2b8c src/wam/dump.lisp --- 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?"))))) diff -r 99abd362620a -r fdb771cc2b8c src/wam/instructions.lisp --- 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... diff -r 99abd362620a -r fdb771cc2b8c src/wam/types.lisp --- 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 () diff -r 99abd362620a -r fdb771cc2b8c src/wam/wam.lisp --- 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)