X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3109662aca9c06495ac22c5c58b46e1c036aca5c..167524b5890cdbf4a832b1766a328f6d8a1f8f04:/src/codegen-proto.lisp diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 4b3b49d..4bfaeca 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -41,6 +41,7 @@ "Answer whether VAR is currently being used. See `with-temporary-var'.") (:method (var) "Non-temporary variables are always in use." + (declare (ignore var)) t)) (defgeneric (setf var-in-use-p) (value var) (:documentation @@ -48,24 +49,12 @@ ;; Root class. -(export 'temporary-name) +(export '(temporary-name temp-tag)) (defclass temporary-name () ((tag :initarg :tag :reader temp-tag)) (:documentation "Base class for temporary variable and argument names.")) -;; Important variables. - -(defparameter *temporary-index* 0 - "Index for temporary name generation. - - This is automatically reset to zero before the output functions are - invoked to write a file. This way, we can ensure that the same output - file is always produced from the same input." - ;; FIXME: this is currently a lie. Need some protocol to ensure that this - ;; happens. -) - ;; Important temporary names. (export '(*sod-ap* *sod-master-ap*)) @@ -73,6 +62,10 @@ (make-instance 'temporary-name :tag "sod__ap")) (defparameter *sod-master-ap* (make-instance 'temporary-name :tag "sod__master_ap")) +(defparameter *sod-tmp-ap* + (make-instance 'temporary-name :tag "sod__tmp_ap")) +(defparameter *sod-tmp-val* + (make-instance 'temporary-name :tag "sod__t")) ;;;-------------------------------------------------------------------------- ;;; Instructions. @@ -85,9 +78,9 @@ "A base class for instructions. An `instruction' is anything which might be useful to string into a code - generator. Both statements and expressions map can be represented by - trees of instructions. The `definst' macro is a convenient way of - defining new instructions. + generator. Both statements and expressions can be represented by trees of + instructions. The `definst' macro is a convenient way of defining new + instructions. The only important protocol for instructions is output, which is achieved by calling `print-object' with `*print-escape*' nil. @@ -107,12 +100,19 @@ This isn't intended to be a particularly rigorous definition. Its purpose is to allow code generators to make decisions about inlining or calling code fairly simply.") - (:method (inst) 1)) + (:method ((inst t)) + (declare (ignore inst)) + 1) + (:method ((inst null)) + (declare (ignore inst)) + 1) + (:method ((inst list)) + (reduce #'+ inst :key #'inst-metric))) ;; Instruction definition. (export 'definst) -(defmacro definst (code (streamvar) args &body body) +(defmacro definst (code (streamvar &key export) args &body body) "Define an instruction type and describe how to output it. An `inst' can represent any structured piece of output syntax: a @@ -124,62 +124,53 @@ * Instance slots named after the ARGS, with matching keyword initargs, and `inst-ARG' readers. - * A constructor `make-CODE-inst' which accepts the ARGS (in order, not - with keywords) as arguments and returns a fresh instance. + * A constructor `make-CODE-inst' which accepts the ARGS (as an ordinary + BVL) as arguments and returns a fresh instance. * A print method, which prints a diagnostic dump if `*print-escape*' is set, or invokes the BODY (with STREAMVAR bound to the output stream) otherwise. The BODY is expected to produce target code at this - point." - - (let ((inst-var (gensym "INST")) - (class-name (symbolicate code '-inst)) - (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword)) - args))) + point. + + If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst' + symbols." + + (let* ((inst-var (gensym "INST")) + (class-name (symbolicate code '-inst)) + (constructor-name (symbolicate 'make- code '-inst)) + (slots (mapcan (lambda (arg) + (if (listp arg) (list (car arg)) + (let ((name (symbol-name arg))) + (if (and (plusp (length name)) + (char/= (char name 0) #\&)) + (list arg) + nil)))) + args)) + (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword)) + slots))) `(progn (defclass ,class-name (inst) - ,(mapcar (lambda (arg key) - `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg))) - args keys)) - (defun ,(symbolicate 'make- code '-inst) (,@args) - (make-instance ',class-name ,@(mappend #'list keys args))) + ,(mapcar (lambda (slot key) + `(,slot :initarg ,key + :reader ,(symbolicate 'inst- slot))) + slots keys)) + (defun ,constructor-name (,@args) + (make-instance ',class-name ,@(mappend #'list keys slots))) (defmethod inst-metric ((,inst-var ,class-name)) - (with-slots (,@args) ,inst-var - (+ 1 ,@(mapcar (lambda (arg) `(inst-metric ,arg)) args)))) + (with-slots (,@slots) ,inst-var + (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) slots)))) (defmethod print-object ((,inst-var ,class-name) ,streamvar) - (with-slots (,@args) ,inst-var + (with-slots (,@slots) ,inst-var (if *print-escape* (print-unreadable-object (,inst-var ,streamvar :type t) (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>" - ,@(mappend #'list keys args))) - (progn ,@body))))))) - -;; Important instruction classes. - -(export '(block-inst make-block-inst var-inst make-var-inst - function-inst make-function-inst set-inst make-set-inst - return-inst make-return-inst expr-inst make-expr-inst - inst-decls inst-body inst-name inst-type inst-init inst-var - inst-expr)) - -(definst var (stream) (name type init) - (pprint-c-type type stream name) - (when init - (format stream " = ~A" init))) -(definst set (stream) (var expr) - (format stream "~@<~A = ~@_~2I~A;~:>" var expr)) -(definst return (stream) (expr) - (format stream "return~@[ (~A)~];" expr)) -(definst expr (stream) (expr) - (format stream "~A;" expr)) -(definst block (stream) (decls body) - (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}" - decls body)) -(definst function (stream) (name type body) - (pprint-logical-block (stream nil) - (princ "static " stream) - (pprint-c-type type stream name) - (format stream "~:@_~A~:@_~:@_" body))) + ,@(mappend #'list keys slots))) + (block ,code ,@body)))) + ,@(and export `((export '(,class-name ,constructor-name + ,@(mapcar (lambda (slot) + (symbolicate 'inst- slot)) + slots))))) + ',code))) ;; Formatting utilities. @@ -216,6 +207,66 @@ `(format-compound-statement* ,stream ,child ,morep (lambda (,stream) ,@body))) +;; Important instruction classes. + +;; HACK: Some of the slot names we'd like to use are external symbols in our +;; package or the `common-lisp' package. Use gensyms for these slot names to +;; prevent them from leaking. + +(definst var (stream :export t) (name #1=#:type &optional init) + (pprint-c-type #1# stream name) + (when init + (format stream " = ~A" init)) + (write-char #\; stream)) + +(definst function (stream :export t) (name #1=#:type body) + (pprint-logical-block (stream nil) + (princ "static " stream) + (pprint-c-type #1# stream name) + (format stream "~:@_~A~:@_~:@_" body))) + +;; Expression statements. +(definst expr (stream :export t) (#1=#:expr) + (format stream "~A;" #1#)) +(definst set (stream :export t) (var #1=#:expr) + (format stream "~@<~A = ~@_~2I~A;~:>" var #1#)) +(definst update (stream :export t) (var op #1=#:expr) + (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op #1#)) + +;; Special kinds of expressions. +(definst call (stream :export t) (#1=#:func &rest args) + (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args)) + +;; Simple statements. +(definst return (stream :export t) (#1=#:expr) + (format stream "return~@[ (~A)~];" #1#)) +(definst break (stream :export t) () + (format stream "break;")) +(definst continue (stream :export t) () + (format stream "continue;")) + +;; Compound statements. + +(definst block (stream :export t) (decls body) + (format stream "{~:@_~@< ~2I~@[~{~A~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}" + decls body)) + +(definst if (stream :export t) (#1=#:cond conseq &optional alt) + (format-compound-statement (stream conseq alt) + (format stream "if (~A)" #1#)) + (when alt + (format-compound-statement (stream alt) + (write-string "else" stream)))) + +(definst while (stream :export t) (#1=#:cond body) + (format-compound-statement (stream body) + (format stream "while (~A)" #1#))) + +(definst do-while (stream :export t) (body #1=#:cond) + (format-compound-statement (stream body :space) + (write-string "do" stream)) + (format stream "while (~A);" #1#)) + ;;;-------------------------------------------------------------------------- ;;; Code generation. @@ -246,6 +297,14 @@ (:method (codegen insts) (dolist (inst insts) (emit-inst codegen inst)))) +(export '(emit-decl emit-decls)) +(defgeneric emit-decl (codegen inst) + (:documentation + "Add INST to the end of CODEGEN's list of declarations.")) +(defgeneric emit-decls (codegen insts) + (:documentation + "Add a list of INSTS to the end of CODEGEN's list of declarations.")) + (export 'codegen-push) (defgeneric codegen-push (codegen) (:documentation @@ -313,11 +372,14 @@ "Evaluate BODY with VAR bound to a temporary variable name. During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked - available for re-use." - `(let ((,var (temporary-var ,codegen ,type))) - (unwind-protect - (progn ,@body) - (setf (var-in-use-p ,var) nil)))) + available for re-use." + (multiple-value-bind (doc decls body) (parse-body body :docp nil) + (declare (ignore doc)) + `(let ((,var (temporary-var ,codegen ,type))) + ,@decls + (unwind-protect + (progn ,@body) + (setf (var-in-use-p ,var) nil))))) ;;;-------------------------------------------------------------------------- ;;; Code generation idioms. @@ -381,4 +443,9 @@ (emit-inst codegen (make-return-inst nil))) (t (funcall func target)))) +(export 'deliver-call) +(defun deliver-call (codegen target func &rest args) + "Emit a statement to call FUNC with ARGS and deliver the result to TARGET." + (deliver-expr codegen target (apply #'make-call-inst func args))) + ;;;----- That's all, folks --------------------------------------------------