X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/8db2259b25024c83cda8a1d0869b282d115983d7..684d95c7eb6ec755d38efacbc377e9e60ba7044e:/src/codegen-proto.lisp diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 2dcd5ad..0c5040c 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -154,92 +154,180 @@ If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst' symbols." - (multiple-value-bind (bvl cooked raw) + (multiple-value-bind (bvl public private) + ;; The hard part of this is digging through the BVL to find the slot + ;; names. Collect them into an actual BVL which will be acceptable to + ;; `defun', and (matching) lists of the PUBLIC and PRIVATE names of the + ;; slots. + (let ((state :mandatory) (bvl (make-list-builder)) - (cooked (make-list-builder)) - (raw (make-list-builder))) + (public (make-list-builder)) + (private (make-list-builder))) + (labels ((recurse-arg (arg path) + ;; Figure out the argument name in ARG, which might be a + ;; symbol or a list with the actual argument name buried + ;; in it somewhere. Once we've found it, return the + ;; appropriate entries to add to the BVL, PUBLIC, and + ;; PRIVATE lists. + ;; + ;; The PATH indicates a route to take through the tree to + ;; find the actual argument name: it's a list of + ;; nonnegative integers, one for each level of structure: + ;; the integer indicates which element of the list at that + ;; level to descend into to find the argument name + ;; according to the usual BVL syntax. It's always + ;; acceptable for a level to actually be a symbol, which + ;; is then the argument name we were after. If we reach + ;; the bottom and we still have a list, then it must be a + ;; (PUBLIC PRIVATE) pair. + (cond ((symbolp arg) + ;; We've bottommed out at a symbol. If it starts + ;; with a `%' then that's the private name: strip + ;; the `%' to find the public name. Otherwise, the + ;; symbol is all we have. + (let ((name (symbol-name arg))) (if (and (plusp (length name)) (char= (char name 0) #\%)) - (let ((cooked (intern (subseq name 1)))) - (values cooked cooked arg)) + (let ((public (intern (subseq name 1)))) + (values public public arg)) (values arg arg arg)))) + ((atom arg) + ;; Any other kind of atom is obviously bogus. (error "Unexpected item ~S in lambda-list." arg)) + ((null path) - (multiple-value-bind (cooked raw) + ;; We've bottommed out of the path and still have a + ;; list. It must be (PUBLIC PRIVATE). + + (multiple-value-bind (public private) (if (cdr arg) (values (car arg) (cadr arg)) (values (car arg) (car arg))) - (values cooked cooked raw))) + (values public public private))) + (t + ;; We have a list. Take the first step in the + ;; PATH, and recursively process corresponding list + ;; element with the remainder of the PATH. The + ;; PUBLIC and PRIVATE slot names are fine, but we + ;; must splice the given BVL entry into our list + ;; structure. + (let* ((step (car path)) (mine (nthcdr step arg))) - (multiple-value-bind (full cooked raw) + (multiple-value-bind (full public private) (recurse-arg (car mine) (cdr path)) (values (append (subseq arg 0 step) full (cdr mine)) - cooked - raw)))))) + public + private)))))) + (hack-arg (arg maxdp) - (multiple-value-bind (full cooked-name raw-name) + ;; Find the actual argument name in a BVL entry, and add + ;; the appropriate entries to the `bvl', `public', and + ;; `private' lists. + + (multiple-value-bind (full public-name private-name) (recurse-arg arg maxdp) (lbuild-add bvl full) - (lbuild-add cooked cooked-name) - (lbuild-add raw raw-name)))) - (dolist (arg args) - (cond ((or (eq arg '&optional) - (eq arg '&rest) - (eq arg '&key) - (eq arg '&aux)) - (setf state arg) - (lbuild-add bvl arg)) - ((eq arg '&allow-other-keys) - (lbuild-add bvl arg)) - ((or (eq state :mandatory) - (eq state '&rest)) - (hack-arg arg '())) - ((or (eq state '&optional) - (eq state '&aux)) - (hack-arg arg '(0))) - ((eq state '&key) - (hack-arg arg '(0 1))) - (t - (error "Confusion in ~S!" 'definst))))) + (lbuild-add public public-name) + (lbuild-add private private-name)))) + + ;; Process the augmented BVL, extracting a standard BVL suitable + ;; for `defun', and the public and private slot names into our + ;; list. + (dolist (arg args) + (cond ((or (eq arg '&optional) + (eq arg '&rest) + (eq arg '&key) + (eq arg '&aux)) + (setf state arg) + (lbuild-add bvl arg)) + + ((eq arg '&allow-other-keys) + (lbuild-add bvl arg)) + + ((or (eq state :mandatory) + (eq state '&rest)) + (hack-arg arg '())) + + ((or (eq state '&optional) + (eq state '&aux)) + (hack-arg arg '(0))) + + ((eq state '&key) + (hack-arg arg '(0 1))) + + (t + (error "Confusion in ~S!" 'definst))))) + + ;; Done! That was something of a performance. (values (lbuild-list bvl) - (lbuild-list cooked) - (lbuild-list raw))) + (lbuild-list public) + (lbuild-list private))) + + ;; Now we can actually build the pieces of the code-generation machinery. (let* ((inst-var (gensym "INST")) (class-name (symbolicate code '-inst)) (constructor-name (symbolicate 'make- code '-inst)) (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword)) - cooked))) - `(progn - (defclass ,class-name (inst) - ,(mapcar (lambda (cooked-slot raw-slot key) - `(,raw-slot :initarg ,key - :reader ,(symbolicate 'inst- cooked-slot))) - cooked raw keys)) - (defun ,constructor-name (,@bvl) - (make-instance ',class-name ,@(mappend #'list keys cooked))) - (defmethod inst-metric ((,inst-var ,class-name)) - (with-slots (,@raw) ,inst-var - (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) raw)))) - (defmethod print-object ((,inst-var ,class-name) ,streamvar) - (with-slots ,(mapcar #'list cooked raw) ,inst-var - (if *print-escape* - (print-unreadable-object (,inst-var ,streamvar :type t) - (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>" - ,@(mappend #'list keys cooked))) - (block ,code ,@body)))) - ,@(and export `((export '(,class-name ,constructor-name - ,@(mapcar (lambda (slot) - (symbolicate 'inst- slot)) - cooked))))) - ',code)))) + public))) + (multiple-value-bind (docs decls body) (parse-body body) + + ;; We have many jobs to do in the expansion. + `(progn + + ;; A class to hold the data. + (defclass ,class-name (inst) + ,(mapcar (lambda (public-slot private-slot key) + `(,private-slot :initarg ,key + :reader + ,(symbolicate 'inst- public-slot))) + public private keys)) + + ;; A constructor to make an instance of the class. + (defun ,constructor-name (,@bvl) + (make-instance ',class-name ,@(mappend #'list keys public))) + + ;; A method on `inst-metric', to feed into inlining heuristics. + (defmethod inst-metric ((,inst-var ,class-name)) + (with-slots (,@private) ,inst-var + (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) + private)))) + + ;; A method to actually produce the necessary output. + (defmethod print-object ((,inst-var ,class-name) ,streamvar) + (with-slots ,(mapcar #'list public private) ,inst-var + (if *print-escape* + (print-unreadable-object (,inst-var ,streamvar :type t) + (format ,streamvar "~@<~@{~S ~@_~S~^ ~_~}~:>" + ,@(mappend #'list keys public))) + (block ,code + ,@(if (null decls) body + `((locally ,@decls ,@body))))))) + + ;; Maybe export all of this stuff. + ,@(and export `((export '(,class-name ,constructor-name + ,@(mapcar (lambda (slot) + (symbolicate 'inst- slot)) + public))))) + + ;; Remember the documentation. + ,@(and docs `((setf (get ',class-name 'inst-documentation) + ,@docs))) + + ;; And try not to spam a REPL. + ',code))))) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'inst))) + (get symbol 'inst-documentation)) +(defmethod (setf documentation) (doc (symbol symbol) (doc-type (eql 'inst))) + (setf (get symbol 'inst-documentation) doc)) ;; Formatting utilities. @@ -278,15 +366,20 @@ (export 'format-banner-comment) (defun format-banner-comment (stream control &rest args) + "Format a comment, built from a `format' CONTROL string and ARGS. + + The comment is wrapped in the usual `/* ... */' C comment delimiters, and + word-wrapped if necessary. If multiple lines are needed, then a column of + `*'s is left down the left hand side, and the final `*/' ends up properly + aligned on a line by itself." (format stream "~@~_ */~:>" control args)) ;; 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 %type &optional init) + "Declare a variable: TYPE NAME [= INIT]. + + This usually belongs in the DECLS of a `block'." (pprint-logical-block (stream nil) (pprint-c-type type stream name) (when init @@ -295,6 +388,16 @@ (definst function (stream :export t) (name %type body &optional %banner &rest banner-args) + "Define a function. + + The TYPE must be a function type. The BANNER and BANNER-ARGS are a + `format' control string and its argument list. Output looks like: + + /* BANNER */ + TYPE NAME(ARGS-FROM-TYPE) + { + BODY + }" (pprint-logical-block (stream nil) (when banner (apply #'format-banner-comment stream banner banner-args) @@ -305,24 +408,32 @@ ;; Expression statements. (definst expr (stream :export t) (%expr) + "An expression statement: EXPR;" (format stream "~A;" expr)) (definst set (stream :export t) (var %expr) + "An assignment statement: VAR = EXPR;" (format stream "~@<~A = ~2I~_~A;~:>" var expr)) (definst update (stream :export t) (var op %expr) + "An update statement: VAR OP= EXPR;" (format stream "~@<~A ~A= ~2I~_~A;~:>" var op expr)) ;; Special kinds of expressions. (definst call (stream :export t) (%func &rest args) + "A function-call expression: FUNC(ARGS)" (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" func args)) (definst cond (stream :export t) (%cond conseq alt) + "A conditional expression: COND ? CONSEQ : ALT" (format stream "~@<~A ~2I~@_~@~:>" cond conseq alt)) ;; Simple statements. (definst return (stream :export t) (%expr) + "A `return' statement: return [(EXPR)];" (format stream "return~@[ (~A)~];" expr)) (definst break (stream :export t) () + "A `break' statement: break;" (format stream "break;")) (definst continue (stream :export t) () + "A `continue' statement: continue;" (format stream "continue;")) ;; Compound statements. @@ -334,15 +445,31 @@ they get the formatting right between them.") (definst banner (stream :export t) (control &rest args) + "A banner comment, built from a `format' CONTROL string and ARGS. + + See `format-banner-comment' for more details." (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 a `banner-inst' to CODEGEN, with the given CONTROL and ARGS." (emit-inst codegen (apply #'make-banner-inst control args))) (definst block (stream :export t) (decls body) + "A compound statement. + + The output looks like + + { + DECLS + + BODY + } + + If controlled by `if', `while', etc., then the leading brace ends up on + the same line, following K&R conventions." (write-char #\{ stream) (pprint-newline :mandatory stream) (pprint-logical-block (stream nil) @@ -367,6 +494,7 @@ (write-char #\} stream)) (definst if (stream :export t) (%cond conseq &optional alt) + "An `if' statement: if (COND) CONSEQ [else ALT]" (let ((stmt "if")) (loop (format-compound-statement (stream conseq (if alt t nil)) (format stream "~A (~A)" stmt cond)) @@ -381,15 +509,18 @@ (return)))))) (definst while (stream :export t) (%cond body) + "A `while' statement: while (COND) BODY" (format-compound-statement (stream body) (format stream "while (~A)" cond))) (definst do-while (stream :export t) (body %cond) + "A `do'/`while' statement: do BODY while (COND);" (format-compound-statement (stream body :space) (write-string "do" stream)) (format stream "while (~A);" cond)) (definst for (stream :export t) (init %cond update body) + "A `for' statement: for (INIT; COND; UPDATE) BODY" (format-compound-statement (stream body) (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)" init cond update)))