From: Mark Wooding Date: Tue, 5 Jan 2016 21:55:24 +0000 (+0000) Subject: src/: Add commentary to the generated code. X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/7de8c6661211bce3a2b2739b461f33a370294979 src/: Add commentary to the generated code. Introduce a new `banner' instruction whose purpose is to act as section heading in the code: a blank line is left (except at the head of a block, hence the earlier expansion of the `format' string) and the banner text written as a beautifully formatted comment. The new `format' string, in `format-banner-comment', is just about interesting enough to make up for the loss of the `block' printer. --- diff --git a/doc/SYMBOLS b/doc/SYMBOLS index e19df8b..b73d8a9 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -329,6 +329,7 @@ codegen-proto.lisp *null-pointer* variable *sod-ap* variable *sod-master-ap* variable + banner-inst class block-inst class break-inst class call-inst class @@ -345,12 +346,14 @@ codegen-proto.lisp deliver-call function deliver-expr function do-while-inst class + emit-banner function emit-decl generic emit-decls generic emit-inst generic emit-insts generic ensure-var generic expr-inst class + format-banner-comment function format-compound-statement macro format-temporary-name generic function-inst class @@ -358,9 +361,12 @@ codegen-proto.lisp inst class inst-alt generic inst-args generic + inst-banner generic + inst-banner-args generic inst-body generic inst-cond generic inst-conseq generic + inst-control generic inst-decls generic inst-expr generic inst-func generic @@ -370,6 +376,7 @@ codegen-proto.lisp inst-op generic inst-type generic inst-var generic + make-banner-inst function make-block-inst function make-break-inst function make-call-inst function @@ -605,6 +612,7 @@ cl:t ichain ilayout inst + banner-inst block-inst break-inst call-inst @@ -1041,7 +1049,12 @@ ilayout-ichains inst-alt if-inst inst-args + banner-inst call-inst +inst-banner + function-inst +inst-banner-args + function-inst inst-body block-inst do-while-inst @@ -1057,6 +1070,8 @@ inst-cond while-inst inst-conseq if-inst +inst-control + banner-inst inst-decls block-inst inst-expr @@ -1073,6 +1088,7 @@ inst-metric cl:list cl:null t + banner-inst block-inst break-inst call-inst @@ -1181,6 +1197,7 @@ print-c-type t simple-c-type t tagged-c-type cl:print-object + banner-inst t base-offset t block-inst t break-inst t diff --git a/doc/clang.tex b/doc/clang.tex index b38dc09..87e8d47 100644 --- a/doc/clang.tex +++ b/doc/clang.tex @@ -902,6 +902,10 @@ Temporary names are represented by objects which implement a simple protocol. @
^*} \end{describe} +\begin{describe}{fun} + {format-banner-comment @ @ \&rest @} +\end{describe} + \begin{table} \begin{tabular}[C]{ll>{\codeface}l} \hlx*{hv} \thd{Class name} & @@ -921,7 +925,9 @@ Temporary names are represented by objects which implement a simple protocol. @|call| & @ @|\&rest| @ & @(@_1, $\ldots$, - @_n) \\ \hlx{vhv} + @_n) \\ \hlx{v} + @|banner| & @ @|\&rest| @ + & /* @ */ \\ \hlx{vhv} @|block| & @ @ & \{ @[@@] @ \} \\ \hlx{v} @|if| & @ @ @|\&optional| @ @@ -931,8 +937,12 @@ Temporary names are represented by objects which implement a simple protocol. \\ \hlx{v} @|do-while| & @ @ & do @ while (@); \\ \hlx{v} - @|function| & @ @ @ & - \vtop{\hbox{\strut @_0 @(@_1 @_1, $\ldots$, + @|function| & + \vtop{\hbox{\strut @ @ @} + \hbox{\strut \quad @|\&optional @|} + \hbox{\strut \quad @|\&rest| @}} & + \vtop{\hbox{\strut @[/* @ */@]} + \hbox{\strut @_0 @(@_1 @_1, $\ldots$, @_n @_n @[, \dots@])} \hbox{\strut \quad @}} \\ \hlx*{vh} \end{tabular} @@ -962,6 +972,9 @@ Temporary names are represented by objects which implement a simple protocol. \begin{describe}{gf}{emit-decls @ @} \end{describe} +\begin{describe}{fun}{emit-banner @ @ \&rest @} +\end{describe} + \begin{describe}{gf}{codegen-push @} \end{describe} diff --git a/src/builtin.lisp b/src/builtin.lisp index 1c14f19..ea72d66 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -90,8 +90,8 @@ (define-class-slot "imprint" (class stream) (format nil "~A__imprint" class) (let ((ilayout (sod-class-ilayout class))) (format stream "~&~: -/* Imprint raw memory with instance structure. */ -static void *~A__imprint(void *p) +/* Imprint raw memory with class `~A' instance structure. */ +static void *~:*~A__imprint(void *p) { struct ~A *sod__obj = p; diff --git a/src/class-output.lisp b/src/class-output.lisp index b2d1ec8..09f7e9f 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -452,15 +452,25 @@ (defmethod hook-output progn (defmethod hook-output progn ((method sod-method) (reason (eql :c)) sequencer) - (with-slots ((class %class) body) method + (with-slots ((class %class) role body message) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) :constraint ((class :direct-methods :start) + (class :direct-method method :banner) (class :direct-method method :start) (class :direct-method method :body) (class :direct-method method :end) (class :direct-methods :end)) + ((class :direct-method method :banner) + (format-banner-comment stream "Direct ~@[~(~A~) ~]method ~:_~ + on `~A.~A' ~:_defined by `~A'." + role + (sod-class-nickname + (sod-message-class message)) + (sod-message-name message) + class) + (fresh-line stream)) ((class :direct-method method :body) (pprint-c-type (sod-method-function-type method) stream diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 767f35b..186f225 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -210,6 +210,10 @@ (defmacro format-compound-statement `(format-compound-statement* ,stream ,child ,morep (lambda (,stream) ,@body))) +(export 'format-banner-comment) +(defun format-banner-comment (stream control &rest args) + (format stream "~@~_ */~:>" control args)) + ;; Important instruction classes. ;; HACK: Some of the slot names we'd like to use are external symbols in our @@ -222,8 +226,12 @@ (definst var (stream :export t) (name #1=#:type &optional init) (format stream " = ~A" init)) (write-char #\; stream)) -(definst function (stream :export t) (name #1=#:type body) +(definst function (stream :export t) + (name #1=#:type body &optional #2=#:banner &rest banner-args) (pprint-logical-block (stream nil) + (when #2# + (apply #'format-banner-comment stream #2# banner-args) + (pprint-newline :mandatory stream)) (princ "static " stream) (pprint-c-type #1# stream name) (format stream "~:@_~A~:@_~:@_" body))) @@ -250,6 +258,21 @@ (definst continue (stream :export t) () ;; Compound statements. +(defvar *first-statement-p* t + "True if this is the first statement in a block. + + This is used to communicate between `block-inst' and `banner-inst' so that + they get the formatting right between them.") + +(definst banner (stream :export t) (control &rest args) + (pprint-logical-block (stream nil) + (unless *first-statement-p* (pprint-newline :mandatory stream)) + (apply #'format-banner-comment stream control args))) + +(export 'emit-banner) +(defun emit-banner (codegen control &rest args) + (emit-inst codegen (apply #'make-banner-inst control args))) + (definst block (stream :export t) (decls body) (write-char #\{ stream) (pprint-newline :mandatory stream) @@ -266,9 +289,11 @@ (definst block (stream :export t) (decls body) (newline) (write decl :stream stream)) (when body (newline))) - (dolist (inst body) - (newline) - (write inst :stream stream))))) + (let ((*first-statement-p* t)) + (dolist (inst body) + (newline) + (write inst :stream stream) + (setf *first-statement-p* nil)))))) (pprint-newline :mandatory stream) (write-char #\} stream)) @@ -367,13 +392,15 @@ (defgeneric temporary-var (codegen type) cleanup automatically.")) (export 'codegen-build-function) -(defun codegen-build-function (codegen name type vars insts) +(defun codegen-build-function + (codegen name type vars insts &optional banner &rest banner-args) "Build a function and add it to CODEGEN's list. Returns the function's name." (codegen-add-function codegen - (make-function-inst name type - (make-block-inst vars insts))) + (apply #'make-function-inst name type + (make-block-inst vars insts) + banner banner-args)) name) (export 'codegen-pop-block) @@ -385,15 +412,17 @@ (defgeneric codegen-pop-block (codegen) (make-block-inst vars insts)))) (export 'codegen-pop-function) -(defgeneric codegen-pop-function (codegen name type) +(defgeneric codegen-pop-function + (codegen name type &optional banner &rest banner-args) (:documentation "Makes a function out of the completed code in CODEGEN. The NAME can be any object you like. The TYPE should be a function type object which includes argument names. The return value is the NAME.") - (:method (codegen name type) + (:method (codegen name type &optional banner &rest banner-args) (multiple-value-bind (vars insts) (codegen-pop codegen) - (codegen-build-function codegen name type vars insts)))) + (apply #'codegen-build-function codegen name type vars insts + banner banner-args)))) (export 'with-temporary-var) (defmacro with-temporary-var ((codegen var type) &body body) diff --git a/src/method-impl.lisp b/src/method-impl.lisp index e4aaae3..f0fd3fc 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -438,7 +438,15 @@ (defmethod compute-method-entry-functions ((method basic-effective-method)) (type (c-type (fun (lisp return-type) ("me" (* (class tail))) . entry-args)))) - (codegen-pop-function codegen name type) + (codegen-pop-function codegen name type + "~@(~@[~A ~]entry~) function ~:_~ + for method `~A.~A' ~:_~ + via chain headed by `~A' ~:_~ + defined on `~A'." + (if parm-n "Indirect argument-tail" nil) + (sod-class-nickname message-class) + (sod-message-name message) + head class) ;; If this is a varargs method then we've made the ;; `:valist' role. Also make the `nil' role. @@ -458,7 +466,15 @@ (defmethod compute-method-entry-functions ((method basic-effective-method)) (deliver-expr codegen target call) (deliver-call codegen :void "va_end" *sod-ap*))) - (codegen-pop-function codegen main main-type)))))) + (codegen-pop-function codegen main main-type + "Variable-length argument list ~:_~ + entry function ~:_~ + for method `~A.~A' ~:_~ + via chain headed by `~A' ~:_~ + defined on `~A'." + (sod-class-nickname message-class) + (sod-message-name message) + head class)))))) ;; Generate the method body. We'll work out what to do with it later. (codegen-push codegen) @@ -492,7 +508,12 @@ (defmethod compute-method-entry-functions ((method basic-effective-method)) ;; function and call it a lot. (codegen-build-function codegen emf-name emf-type vars (nconc insts (and result - (list (make-return-inst result))))) + (list (make-return-inst result)))) + "Effective method function ~:_for `~A.~A' ~:_~ + defined on `~A'." + (sod-class-nickname message-class) + (sod-message-name message) + (effective-method-class method)) (let ((call (apply #'make-call-inst emf-name "sod__obj" (mapcar #'argument-name emf-arg-tail)))) diff --git a/src/method-proto.lisp b/src/method-proto.lisp index 60a10eb..e0d8742 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -333,6 +333,8 @@ (defun make-trampoline (codegen super body) (let* ((message (codegen-message codegen)) (message-type (sod-message-type message)) + (message-class (sod-message-class message)) + (method (codegen-method codegen)) (return-type (c-type-subtype message-type)) (raw-args (sod-message-argument-tail message)) (arguments (if (varargs-message-p message) @@ -345,7 +347,12 @@ (defun make-trampoline (codegen super body) (codegen-pop-function codegen (temporary-function) (c-type (fun (lisp return-type) ("me" (* (class super))) - . arguments))))) + . arguments)) + "Delegation-chain trampoline ~:_~ + for `~A.~A' ~:_on `~A'." + (sod-class-nickname message-class) + (sod-message-name message) + (effective-method-class method)))) ;;;-------------------------------------------------------------------------- ;;; Method entry protocol.