--- a/bones.asd Tue Apr 05 15:00:28 2016 +0000
+++ b/bones.asd Sun Apr 10 14:35:22 2016 +0000
@@ -20,6 +20,7 @@
(:file "package")
(:module "src"
:components ((:file "paip")
+ (:file "more-utilities")
(:module "wam"
:components ((:file "constants")
(:file "types")
--- a/package.lisp Tue Apr 05 15:00:28 2016 +0000
+++ b/package.lisp Sun Apr 10 14:35:22 2016 +0000
@@ -2,8 +2,15 @@
(:use #:cl)
(:export #:hello))
+(defpackage #:bones.more-utils
+ (:use #:cl #:defstar #:bones.utils)
+ (:export
+ #:vector-push-extend-all
+ #:push-if-new))
+
(defpackage #:bones.wam
- (:use #:cl #:defstar #:bones.utils #:optima #:cl-arrows)
+ (:use #:cl #:defstar #:optima #:cl-arrows
+ #:bones.utils #:bones.more-utils)
(:import-from #:optima #:match)
(:shadowing-import-from #:cl-arrows #:->))
--- a/src/make-utilities.lisp Tue Apr 05 15:00:28 2016 +0000
+++ b/src/make-utilities.lisp Sun Apr 10 14:35:22 2016 +0000
@@ -9,6 +9,7 @@
:while
:until
:tree-member-p
+ :with-gensyms
:map-tree
)
:package "BONES.UTILS")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/more-utilities.lisp Sun Apr 10 14:35:22 2016 +0000
@@ -0,0 +1,9 @@
+(in-package #:bones.more-utils)
+
+;; TODO: learn setf expanders and do this right.
+(defmacro push-if-new (thing list-place)
+ `(not (eql ,list-place (pushnew ,thing ,list-place))))
+
+(defun vector-push-extend-all (vector &rest things)
+ (loop :for thing :in things :do
+ (vector-push-extend thing vector)))
--- a/src/utils.lisp Tue Apr 05 15:00:28 2016 +0000
+++ b/src/utils.lisp Sun Apr 10 14:35:22 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :MAP-TREE) :ensure-package T :package "BONES.UTILS")
+;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :WITH-GENSYMS :MAP-TREE) :ensure-package T :package "BONES.UTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.UTILS")
@@ -249,6 +249,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(define-constant set-equal curry switch eswitch cswitch
- ensure-boolean while until tree-member-p map-tree)))
+ ensure-boolean while until tree-member-p with-gensyms
+ with-unique-names map-tree)))
;;;; END OF utils.lisp ;;;;
--- a/src/wam/compile.lisp Tue Apr 05 15:00:28 2016 +0000
+++ b/src/wam/compile.lisp Sun Apr 10 14:35:22 2016 +0000
@@ -235,7 +235,11 @@
(flatten registers functor arity))
(defun flatten-program (registers functor arity)
- (reverse (flatten registers functor arity)))
+ (multiple-value-bind (assignments functor arity)
+ (flatten registers functor arity)
+ (values (reverse assignments)
+ functor
+ arity)))
;;;; Tokenization
@@ -296,93 +300,108 @@
;;; (#'%set-value 1)
;;; (#'%set-value 2)
-(defun generate-actions (wam tokens store mode)
- "Generate a series of machine instructions from a stream of tokens."
+(defun compile-tokens (wam tokens store mode)
+ "Generate a series of machine instructions from a stream of tokens.
+
+ The compiled instructions will be appended to `store` using
+ `vector-push-extend.`
+
+ "
(let ((seen (list)))
(flet ((handle-argument (register target)
- (if (member target seen)
- (vector-push-extend (ecase mode
- (:program +opcode-get-value+)
- (:query +opcode-put-value+))
- store)
- (progn
- (push target seen)
- (vector-push-extend (ecase mode
- (:program +opcode-get-variable+)
- (:query +opcode-put-variable+))
- store)))
- (vector-push-extend target store)
- (vector-push-extend register store))
+ ; OP X_n A_i
+ (vector-push-extend-all store
+ (if (push-if-new target 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 (ecase mode
- (:program +opcode-get-structure+)
- (:query +opcode-put-structure+))
- store)
- (vector-push-extend
+ (vector-push-extend-all store
+ (ecase mode
+ (:program +opcode-get-structure+)
+ (:query +opcode-put-structure+))
(wam-ensure-functor-index wam (cons functor arity))
- store)
- (vector-push-extend register store))
+ register))
(handle-register (register)
- (if (member register seen)
- (progn
- (vector-push-extend (ecase mode
- (:program +opcode-get-value+)
- (:query +opcode-set-value+))
- store)
- (vector-push-extend register store))
- (progn
- (push register seen)
- (vector-push-extend (ecase mode
- (:program +opcode-get-variable+)
- (:query +opcode-set-variable+))
- store)
- (vector-push-extend register store)))))
+ ; OP reg
+ (vector-push-extend-all store
+ (if (push-if-new register seen)
+ (ecase mode
+ (:program +opcode-unify-variable+)
+ (:query +opcode-set-variable+))
+ (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-register register)))
+ ))))
-(defun generate-query-actions (wam tokens store)
- (generate-actions wam tokens store :query))
+(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 generate-program-actions (wam tokens store)
- (generate-actions wam tokens store :program))
+(defun compile-program-tokens (wam tokens functor arity store)
+ ; todo: add functor/arity into labels
+ (compile-tokens wam tokens store :program)
+ (vector-push-extend +opcode-proceed+ store))
;;;; UI
-(defun compile-query-term (wam term)
- "Parse a Lisp query term into a series of WAM machine instructions."
+(defun compile-query (wam term)
+ "Parse a Lisp query term into a series of WAM machine instructions.
+
+ The compiled code will be returned in a fresh array.
+
+ "
(let ((code (make-array 64
:fill-pointer 0
:adjustable t
:element-type 'code-word)))
- (-<>> term
- parse-term
- (multiple-value-call #'inline-structure-argument-assignments)
- (multiple-value-call #'flatten-query)
- (multiple-value-call #'tokenize-assignments)
- (generate-query-actions wam <> code))
+ (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))
-(defun compile-program-term (wam term)
- "Parse a Lisp program term into a series of WAM machine instructions."
- (-> term
- parse-term
- flatten-program
- tokenize-assignments
- generate-program-actions))
+(defun compile-program (wam term)
+ "Parse a Lisp program term into a series of WAM machine instructions.
+
+ The compiled code will be placed at the top of the WAM code store.
+
+ "
+ (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))))
-(defun run (wam instructions &optional step)
+(defun run (wam instructions)
"Execute the machine instructions on the given WAM."
+ ; (loop :)
(mapc (lambda (action)
(when (not (wam-fail wam))
- (apply (car action) wam (cdr action))
- (when step (break))))
+ (apply (car action) wam (cdr action))))
instructions)
(values))
--- a/src/wam/dump.lisp Tue Apr 05 15:00:28 2016 +0000
+++ b/src/wam/dump.lisp Sun Apr 10 14:35:22 2016 +0000
@@ -63,23 +63,61 @@
(opcode-short-name opcode)
(pretty-arguments arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-set-variable+)) arguments functor-list)
+ (format nil "SVAR~A ; X~D <- new unbound REF"
+ (pretty-arguments arguments)
+ (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list)
+ (format nil "SVLU~A ; new REF to X~D"
+ (pretty-arguments arguments)
+ (first arguments)))
+
(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
- (format nil "GETS~A ; ~A"
+ (format nil "GETS~A ; X~D <- ~A"
(pretty-arguments arguments)
+ (second arguments)
(pretty-functor (first arguments) functor-list)))
(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
- (format nil "PUTS~A ; ~A"
+ (format nil "PUTS~A ; X~D <- new ~A"
+ (pretty-arguments arguments)
+ (second arguments)
+ (pretty-functor (first arguments) functor-list)))
+
+
+(defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list)
+ (format nil "CALL~A ; ~A"
(pretty-arguments arguments)
(pretty-functor (first arguments) functor-list)))
-; (defmethod instruction-details ((opcode (eql +opcode-set-variable+)) arguments functor-list))
+(defmethod instruction-details ((opcode (eql +opcode-get-variable+)) arguments functor-list)
+ (format nil "GVAR~A ; A~D -> X~D"
+ (pretty-arguments arguments)
+ (second arguments)
+ (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-get-value+)) arguments functor-list)
+ (format nil "GVLU~A ; A~D = X~D"
+ (pretty-arguments arguments)
+ (second arguments)
+ (first arguments)))
+
+
+(defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list)
+ (format nil "PVAR~A ; A~D <- X~D <- new REF"
+ (pretty-arguments arguments)
+ (second arguments)
+ (first arguments)))
+
+; (defmethod instruction-details ((opcode (eql +opcode-get-value+)) arguments functor-list)
+; )
+
; (defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list))
; (defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list))
; (defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list))
-
-; (defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list))
; (defmethod instruction-details ((opcode (eql +opcode-proceed+)) arguments functor-list))
(defun dump-code-store (code-store &optional
@@ -97,7 +135,7 @@
(defun dump-code (wam &optional (from 0) (to (length (wam-code wam))))
(format t "CODE~%")
- (dump-code-store (wam-code wam) from to))
+ (dump-code-store (wam-code wam) from to (wam-functors wam)))
(defun dump-wam-registers (wam)
--- a/src/wam/opcodes.lisp Tue Apr 05 15:00:28 2016 +0000
+++ b/src/wam/opcodes.lisp Sun Apr 10 14:35:22 2016 +0000
@@ -41,7 +41,10 @@
(+opcode-set-variable+ "SET-VARIABLE")
(+opcode-set-value+ "SET-VALUE")
(+opcode-put-variable+ "PUT-VARIABLE")
- (+opcode-put-value+ "PUT-VALUE")))
+ (+opcode-put-value+ "PUT-VALUE")
+
+ (+opcode-call+ "CALL")
+ (+opcode-proceed+ "PROCEED")))
(defun* opcode-short-name ((opcode opcode))
(:returns string)
@@ -56,4 +59,7 @@
(+opcode-set-variable+ "SVAR")
(+opcode-set-value+ "SVLU")
(+opcode-put-variable+ "PVAR")
- (+opcode-put-value+ "PVLU")))
+ (+opcode-put-value+ "PVLU")
+
+ (+opcode-call+ "CALL")
+ (+opcode-proceed+ "PROC")))