3 ;;; Code generation protocol
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
33 (export 'format-temporary-name)
34 (defgeneric format-temporary-name (var stream)
36 "Write the name of a temporary variable VAR to STREAM."))
38 (export 'var-in-use-p)
39 (defgeneric var-in-use-p (var)
41 "Answer whether VAR is currently being used. See `with-temporary-var'.")
43 "Non-temporary variables are always in use."
44 (declare (ignore var))
46 (defgeneric (setf var-in-use-p) (value var)
48 "Record whether VAR is currently being used. See `with-temporary-var'."))
52 (export '(temporary-name temp-tag))
53 (defclass temporary-name ()
54 ((tag :initarg :tag :reader temp-tag))
56 "Base class for temporary variable and argument names."))
58 ;; Important temporary names.
60 (export '(*sod-ap* *sod-master-ap*))
61 (defparameter *sod-ap*
62 (make-instance 'temporary-name :tag "sod__ap"))
63 (defparameter *sod-master-ap*
64 (make-instance 'temporary-name :tag "sod__master_ap"))
65 (defparameter *sod-tmp-ap*
66 (make-instance 'temporary-name :tag "sod__tmp_ap"))
67 (defparameter *sod-tmp-val*
68 (make-instance 'temporary-name :tag "sod__t"))
69 (defparameter *sod-keywords*
70 (make-instance 'temporary-name :tag "sod__kw"))
71 (defparameter *sod-key-pointer*
72 (make-instance 'temporary-name :tag "sod__keys"))
74 (export '*null-pointer*)
75 (defparameter *null-pointer* "NULL")
77 ;;;--------------------------------------------------------------------------
85 "A base class for instructions.
87 An `instruction' is anything which might be useful to string into a code
88 generator. Both statements and expressions can be represented by trees of
89 instructions. The `definst' macro is a convenient way of defining new
92 The only important protocol for instructions is output, which is achieved
93 by calling `print-object' with `*print-escape*' nil.
95 This doesn't really do very much, but it acts as a handy marker for
96 instruction subclasses."))
99 (defgeneric inst-metric (inst)
101 "Returns a `metric' describing how complicated INST is.
103 The default metric of an inst node is simply 1; `inst' subclasses
104 generated by `definst' (q.v.) have an automatically generated method which
105 returns one plus the sum of the metrics of the node's children.
107 This isn't intended to be a particularly rigorous definition. Its purpose
108 is to allow code generators to make decisions about inlining or calling
109 code fairly simply.")
111 (declare (ignore inst))
113 (:method ((inst null))
114 (declare (ignore inst))
116 (:method ((inst list))
117 (reduce #'+ inst :key #'inst-metric)))
119 ;; Instruction definition.
122 (defmacro definst (code (streamvar &key export) args &body body)
123 "Define an instruction type and describe how to output it.
125 An `inst' can represent any structured piece of output syntax: a
126 statement, expression or declaration, for example. This macro defines the
129 * A class `CODE-inst' to represent the instruction.
131 * Instance slots named after the ARGS, with matching keyword initargs,
132 and `inst-ARG' readers.
134 * A constructor `make-CODE-inst' which accepts the ARGS (as an ordinary
135 BVL) as arguments and returns a fresh instance.
137 * A print method, which prints a diagnostic dump if `*print-escape*' is
138 set, or invokes the BODY (with STREAMVAR bound to the output stream)
139 otherwise. The BODY is expected to produce target code at this
142 The ARGS are an ordinary lambda-list, with the following quirks:
144 * Where an argument-name symbol is expected (as opposed to a list), a
145 list (ARG SLOT) may be written instead. This allows the slots to be
146 named independently of the argument names, which is handy if they'd
147 otherwise conflict with exported symbol names.
149 * If an argument name begins with a `%' character, then the `%' is
150 stripped off, except when naming the actual slot. Hence, `%FOO' is
151 equivalent to a list `(FOO %FOO)', except that a `%'-symbol can be
152 used even where the lambda-list syntax permits a list.
154 If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
157 (multiple-value-bind (bvl cooked raw)
158 (let ((state :mandatory)
159 (bvl (make-list-builder))
160 (cooked (make-list-builder))
161 (raw (make-list-builder)))
162 (labels ((recurse-arg (arg path)
164 (let ((name (symbol-name arg)))
165 (if (and (plusp (length name))
166 (char= (char name 0) #\%))
167 (let ((cooked (intern (subseq name 1))))
168 (values cooked cooked arg))
169 (values arg arg arg))))
171 (error "Unexpected item ~S in lambda-list." arg))
173 (multiple-value-bind (cooked raw)
174 (if (cdr arg) (values (car arg) (cadr arg))
175 (values (car arg) (car arg)))
176 (values cooked cooked raw)))
178 (let* ((step (car path))
179 (mine (nthcdr step arg)))
180 (multiple-value-bind (full cooked raw)
181 (recurse-arg (car mine) (cdr path))
182 (values (append (subseq arg 0 step)
187 (hack-arg (arg maxdp)
188 (multiple-value-bind (full cooked-name raw-name)
189 (recurse-arg arg maxdp)
190 (lbuild-add bvl full)
191 (lbuild-add cooked cooked-name)
192 (lbuild-add raw raw-name))))
194 (cond ((or (eq arg '&optional)
199 (lbuild-add bvl arg))
200 ((eq arg '&allow-other-keys)
201 (lbuild-add bvl arg))
202 ((or (eq state :mandatory)
205 ((or (eq state '&optional)
209 (hack-arg arg '(0 1)))
211 (error "Confusion in ~S!" 'definst)))))
212 (values (lbuild-list bvl)
215 (let* ((inst-var (gensym "INST"))
216 (class-name (symbolicate code '-inst))
217 (constructor-name (symbolicate 'make- code '-inst))
218 (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
221 (defclass ,class-name (inst)
222 ,(mapcar (lambda (cooked-slot raw-slot key)
223 `(,raw-slot :initarg ,key
224 :reader ,(symbolicate 'inst- cooked-slot)))
226 (defun ,constructor-name (,@bvl)
227 (make-instance ',class-name ,@(mappend #'list keys cooked)))
228 (defmethod inst-metric ((,inst-var ,class-name))
229 (with-slots (,@raw) ,inst-var
230 (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) raw))))
231 (defmethod print-object ((,inst-var ,class-name) ,streamvar)
232 (with-slots ,(mapcar #'list cooked raw) ,inst-var
234 (print-unreadable-object (,inst-var ,streamvar :type t)
235 (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
236 ,@(mappend #'list keys cooked)))
237 (block ,code ,@body))))
238 ,@(and export `((export '(,class-name ,constructor-name
239 ,@(mapcar (lambda (slot)
240 (symbolicate 'inst- slot))
244 ;; Formatting utilities.
246 (defun format-compound-statement* (stream child morep thunk)
247 "Underlying function for `format-compound-statement'."
248 (cond ((typep child 'block-inst)
249 (funcall thunk stream)
250 (write-char #\space stream)
252 (when morep (write-char #\space stream)))
254 (pprint-logical-block (stream nil)
255 (funcall thunk stream)
256 (write-char #\space stream)
257 (pprint-indent :block 2 stream)
258 (pprint-newline :linear stream)
260 (pprint-indent :block 0 stream))
263 (write-char #\space stream)
264 (pprint-newline :linear stream))
266 (pprint-newline :mandatory stream))))))
268 (export 'format-compound-statement)
269 (defmacro format-compound-statement
270 ((stream child &optional morep) &body body)
271 "Format a compound statement to STREAM.
273 The introductory material is printed by BODY. The CHILD is formatted
274 properly according to whether it's a `block-inst'. If MOREP is true, then
275 allow for more stuff following the child."
276 `(format-compound-statement* ,stream ,child ,morep
277 (lambda (,stream) ,@body)))
279 (export 'format-banner-comment)
280 (defun format-banner-comment (stream control &rest args)
281 (format stream "~@</~@<* ~@;~?~:>~_ */~:>" control args))
283 ;; Important instruction classes.
285 ;; HACK: Some of the slot names we'd like to use are external symbols in our
286 ;; package or the `common-lisp' package. Use gensyms for these slot names to
287 ;; prevent them from leaking.
289 (definst var (stream :export t) (name %type &optional init)
290 (pprint-logical-block (stream nil)
291 (pprint-c-type type stream name)
293 (format stream " = ~2I~_~A" init))
294 (write-char #\; stream)))
296 (definst function (stream :export t)
297 (name %type body &optional %banner &rest banner-args)
298 (pprint-logical-block (stream nil)
300 (apply #'format-banner-comment stream banner banner-args)
301 (pprint-newline :mandatory stream))
302 (princ "static " stream)
303 (pprint-c-type type stream name)
304 (format stream "~:@_~A~:@_~:@_" body)))
306 ;; Expression statements.
307 (definst expr (stream :export t) (%expr)
308 (format stream "~A;" expr))
309 (definst set (stream :export t) (var %expr)
310 (format stream "~@<~A = ~2I~_~A;~:>" var expr))
311 (definst update (stream :export t) (var op %expr)
312 (format stream "~@<~A ~A= ~2I~_~A;~:>" var op expr))
314 ;; Special kinds of expressions.
315 (definst call (stream :export t) (%func &rest args)
316 (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" func args))
317 (definst cond (stream :export t) (%cond conseq alt)
318 (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" cond conseq alt))
320 ;; Simple statements.
321 (definst return (stream :export t) (%expr)
322 (format stream "return~@[ (~A)~];" expr))
323 (definst break (stream :export t) ()
324 (format stream "break;"))
325 (definst continue (stream :export t) ()
326 (format stream "continue;"))
328 ;; Compound statements.
330 (defvar *first-statement-p* t
331 "True if this is the first statement in a block.
333 This is used to communicate between `block-inst' and `banner-inst' so that
334 they get the formatting right between them.")
336 (definst banner (stream :export t) (control &rest args)
337 (pprint-logical-block (stream nil)
338 (unless *first-statement-p* (pprint-newline :mandatory stream))
339 (apply #'format-banner-comment stream control args)))
341 (export 'emit-banner)
342 (defun emit-banner (codegen control &rest args)
343 (emit-inst codegen (apply #'make-banner-inst control args)))
345 (definst block (stream :export t) (decls body)
346 (write-char #\{ stream)
347 (pprint-newline :mandatory stream)
348 (pprint-logical-block (stream nil)
349 (let ((newlinep nil))
352 (pprint-newline :mandatory stream)
354 (pprint-indent :block 2 stream)
355 (write-string " " stream)
359 (write decl :stream stream))
360 (when body (newline)))
361 (let ((*first-statement-p* t))
364 (write inst :stream stream)
365 (setf *first-statement-p* nil))))))
366 (pprint-newline :mandatory stream)
367 (write-char #\} stream))
369 (definst if (stream :export t) (%cond conseq &optional alt)
371 (loop (format-compound-statement (stream conseq (if alt t nil))
372 (format stream "~A (~A)" stmt cond))
375 (if-inst (setf stmt "else if"
377 conseq (inst-conseq alt)
379 (t (format-compound-statement (stream alt)
380 (format stream "else"))
383 (definst while (stream :export t) (%cond body)
384 (format-compound-statement (stream body)
385 (format stream "while (~A)" cond)))
387 (definst do-while (stream :export t) (body %cond)
388 (format-compound-statement (stream body :space)
389 (write-string "do" stream))
390 (format stream "while (~A);" cond))
392 (definst for (stream :export t) (init %cond update body)
393 (format-compound-statement (stream body)
394 (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
397 ;;;--------------------------------------------------------------------------
402 (export 'codegen-functions)
403 (defgeneric codegen-functions (codegen)
405 "Return the list of `function-inst's of completed functions."))
408 (defgeneric ensure-var (codegen name type &optional init)
410 "Add a variable to CODEGEN's list.
412 The variable is called NAME (which should be comparable using `equal' and
413 print to an identifier) and has the given TYPE. If INIT is present and
414 non-nil it is an expression `inst' used to provide the variable with an
417 (export '(emit-inst emit-insts))
418 (defgeneric emit-inst (codegen inst)
420 "Add INST to the end of CODEGEN's list of instructions."))
421 (defgeneric emit-insts (codegen insts)
423 "Add a list of INSTS to the end of CODEGEN's list of instructions.")
424 (:method (codegen insts)
425 (dolist (inst insts) (emit-inst codegen inst))))
427 (export '(emit-decl emit-decls))
428 (defgeneric emit-decl (codegen inst)
430 "Add INST to the end of CODEGEN's list of declarations."))
431 (defgeneric emit-decls (codegen insts)
433 "Add a list of INSTS to the end of CODEGEN's list of declarations."))
435 (export 'codegen-push)
436 (defgeneric codegen-push (codegen)
438 "Pushes the current code generation state onto a stack.
440 The state consists of the accumulated variables and instructions."))
442 (export 'codegen-pop)
443 (defgeneric codegen-pop (codegen)
445 "Pops a saved state off of the CODEGEN's stack.
447 Returns the newly accumulated variables and instructions as lists, as
450 (export 'codegen-add-function)
451 (defgeneric codegen-add-function (codegen function)
453 "Adds a function to CODEGEN's list.
455 Actually, we're not picky: FUNCTION can be any kind of object that you're
456 willing to find in the list returned by `codegen-functions'."))
458 (export 'temporary-var)
459 (defgeneric temporary-var (codegen type)
461 "Return the name of a temporary variable.
463 The temporary variable will have the given TYPE, and will be marked
464 in-use. You should clear the in-use flag explicitly when you've finished
465 with the variable -- or, better, use `with-temporary-var' to do the
466 cleanup automatically."))
468 (export 'codegen-build-function)
469 (defun codegen-build-function
470 (codegen name type vars insts &optional banner &rest banner-args)
471 "Build a function and add it to CODEGEN's list.
473 Returns the function's name."
474 (codegen-add-function codegen
475 (apply #'make-function-inst name type
476 (make-block-inst vars insts)
480 (export 'codegen-pop-block)
481 (defgeneric codegen-pop-block (codegen)
483 "Makes a block (`block-inst') out of the completed code in CODEGEN.")
485 (multiple-value-bind (vars insts) (codegen-pop codegen)
486 (make-block-inst vars insts))))
488 (export 'codegen-pop-function)
489 (defgeneric codegen-pop-function
490 (codegen name type &optional banner &rest banner-args)
492 "Makes a function out of the completed code in CODEGEN.
494 The NAME can be any object you like. The TYPE should be a function type
495 object which includes argument names. The return value is the NAME.")
496 (:method (codegen name type &optional banner &rest banner-args)
497 (multiple-value-bind (vars insts) (codegen-pop codegen)
498 (apply #'codegen-build-function codegen name type vars insts
499 banner banner-args))))
501 (export 'with-temporary-var)
502 (defmacro with-temporary-var ((codegen var type) &body body)
503 "Evaluate BODY with VAR bound to a temporary variable name.
505 During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
506 available for re-use."
507 (multiple-value-bind (doc decls body) (parse-body body :docp nil)
508 (declare (ignore doc))
509 `(let ((,var (temporary-var ,codegen ,type)))
513 (setf (var-in-use-p ,var) nil)))))
515 ;;;--------------------------------------------------------------------------
516 ;;; Code generation idioms.
518 (export 'deliver-expr)
519 (defun deliver-expr (codegen target expr)
520 "Emit code to deliver the value of EXPR to the TARGET.
522 The TARGET may be one of the following.
524 * `:void', indicating that the value is to be discarded. The expression
525 will still be evaluated.
527 * `:void-return', indicating that the value is to be discarded (as for
528 `:void') and furthermore a `return' from the current function should
529 be forced after computing the value.
531 * `:return', indicating that the value is to be returned from the
534 * A variable name, indicating that the value is to be stored in the
537 In the cases of `:return', `:void' and `:void-return' targets, it is valid
538 for EXPR to be nil; this signifies that no computation needs to be
539 performed. Variable-name targets require an expression."
542 (:return (emit-inst codegen (make-return-inst expr)))
543 (:void (when expr (emit-inst codegen (make-expr-inst expr))))
544 (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
545 (emit-inst codegen (make-return-inst nil)))
546 (t (emit-inst codegen (make-set-inst target expr)))))
548 (export 'convert-stmts)
549 (defun convert-stmts (codegen target type func)
550 "Invoke FUNC to deliver a value to a non-`:return' target.
552 FUNC is a function which accepts a single argument, a non-`:return'
553 target, and generates statements which deliver a value (see
554 `deliver-expr') of the specified TYPE to this target. In general, the
555 generated code will have the form
557 setup instructions...
558 (deliver-expr CODEGEN TARGET (compute value...))
559 cleanup instructions...
561 where the cleanup instructions are essential to the proper working of the
564 The `convert-stmts' function will call FUNC to generate code, and arrange
565 that its value is correctly delivered to TARGET, regardless of what the
566 TARGET is -- i.e., it lifts the restriction to non-`:return' targets. It
567 does this by inventing a new temporary variable."
570 (:return (with-temporary-var (codegen var type)
572 (deliver-expr codegen target var)))
573 (:void-return (funcall func :void)
574 (emit-inst codegen (make-return-inst nil)))
575 (t (funcall func target))))
577 (export 'deliver-call)
578 (defun deliver-call (codegen target func &rest args)
579 "Emit a statement to call FUNC with ARGS and deliver the result to TARGET."
580 (deliver-expr codegen target (apply #'make-call-inst func args)))
582 ;;;----- That's all, folks --------------------------------------------------