# HG changeset patch # User Steve Losh # Date 1460298922 0 # Node ID 51022d18e98f705067c42efffb1859133616b472 # Parent 6138ec555cde8d151e58955640d01bd04d589d49 First stab at compiling L1 -- not ready yet diff -r 6138ec555cde -r 51022d18e98f bones.asd --- 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") diff -r 6138ec555cde -r 51022d18e98f package.lisp --- 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 #:->)) diff -r 6138ec555cde -r 51022d18e98f src/make-utilities.lisp --- 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") diff -r 6138ec555cde -r 51022d18e98f src/more-utilities.lisp --- /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))) diff -r 6138ec555cde -r 51022d18e98f src/utils.lisp --- 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 ;;;; diff -r 6138ec555cde -r 51022d18e98f src/wam/compile.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)) diff -r 6138ec555cde -r 51022d18e98f src/wam/dump.lisp --- 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) diff -r 6138ec555cde -r 51022d18e98f src/wam/opcodes.lisp --- 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")))