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 public private)
158 (let ((state :mandatory)
159 (bvl (make-list-builder))
160 (public (make-list-builder))
161 (private (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 ((public (intern (subseq name 1))))
168 (values public public arg))
169 (values arg arg arg))))
171 (error "Unexpected item ~S in lambda-list." arg))
173 (multiple-value-bind (public private)
174 (if (cdr arg) (values (car arg) (cadr arg))
175 (values (car arg) (car arg)))
176 (values public public private)))
178 (let* ((step (car path))
179 (mine (nthcdr step arg)))
180 (multiple-value-bind (full public private)
181 (recurse-arg (car mine) (cdr path))
182 (values (append (subseq arg 0 step)
187 (hack-arg (arg maxdp)
188 (multiple-value-bind (full public-name private-name)
189 (recurse-arg arg maxdp)
190 (lbuild-add bvl full)
191 (lbuild-add public public-name)
192 (lbuild-add private private-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)
214 (lbuild-list private)))
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 (public-slot private-slot key)
223 `(,private-slot :initarg ,key
224 :reader ,(symbolicate 'inst- public-slot)))
225 public private keys))
226 (defun ,constructor-name (,@bvl)
227 (make-instance ',class-name ,@(mappend #'list keys public)))
228 (defmethod inst-metric ((,inst-var ,class-name))
229 (with-slots (,@private) ,inst-var
230 (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) private))))
231 (defmethod print-object ((,inst-var ,class-name) ,streamvar)
232 (with-slots ,(mapcar #'list public private) ,inst-var
234 (print-unreadable-object (,inst-var ,streamvar :type t)
235 (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
236 ,@(mappend #'list keys public)))
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 (definst var (stream :export t) (name %type &optional init)
286 (pprint-logical-block (stream nil)
287 (pprint-c-type type stream name)
289 (format stream " = ~2I~_~A" init))
290 (write-char #\; stream)))
292 (definst function (stream :export t)
293 (name %type body &optional %banner &rest banner-args)
294 (pprint-logical-block (stream nil)
296 (apply #'format-banner-comment stream banner banner-args)
297 (pprint-newline :mandatory stream))
298 (princ "static " stream)
299 (pprint-c-type type stream name)
300 (format stream "~:@_~A~:@_~:@_" body)))
302 ;; Expression statements.
303 (definst expr (stream :export t) (%expr)
304 (format stream "~A;" expr))
305 (definst set (stream :export t) (var %expr)
306 (format stream "~@<~A = ~2I~_~A;~:>" var expr))
307 (definst update (stream :export t) (var op %expr)
308 (format stream "~@<~A ~A= ~2I~_~A;~:>" var op expr))
310 ;; Special kinds of expressions.
311 (definst call (stream :export t) (%func &rest args)
312 (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" func args))
313 (definst cond (stream :export t) (%cond conseq alt)
314 (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" cond conseq alt))
316 ;; Simple statements.
317 (definst return (stream :export t) (%expr)
318 (format stream "return~@[ (~A)~];" expr))
319 (definst break (stream :export t) ()
320 (format stream "break;"))
321 (definst continue (stream :export t) ()
322 (format stream "continue;"))
324 ;; Compound statements.
326 (defvar *first-statement-p* t
327 "True if this is the first statement in a block.
329 This is used to communicate between `block-inst' and `banner-inst' so that
330 they get the formatting right between them.")
332 (definst banner (stream :export t) (control &rest args)
333 (pprint-logical-block (stream nil)
334 (unless *first-statement-p* (pprint-newline :mandatory stream))
335 (apply #'format-banner-comment stream control args)))
337 (export 'emit-banner)
338 (defun emit-banner (codegen control &rest args)
339 (emit-inst codegen (apply #'make-banner-inst control args)))
341 (definst block (stream :export t) (decls body)
342 (write-char #\{ stream)
343 (pprint-newline :mandatory stream)
344 (pprint-logical-block (stream nil)
345 (let ((newlinep nil))
348 (pprint-newline :mandatory stream)
350 (pprint-indent :block 2 stream)
351 (write-string " " stream)
355 (write decl :stream stream))
356 (when body (newline)))
357 (let ((*first-statement-p* t))
360 (write inst :stream stream)
361 (setf *first-statement-p* nil))))))
362 (pprint-newline :mandatory stream)
363 (write-char #\} stream))
365 (definst if (stream :export t) (%cond conseq &optional alt)
367 (loop (format-compound-statement (stream conseq (if alt t nil))
368 (format stream "~A (~A)" stmt cond))
371 (if-inst (setf stmt "else if"
373 conseq (inst-conseq alt)
375 (t (format-compound-statement (stream alt)
376 (format stream "else"))
379 (definst while (stream :export t) (%cond body)
380 (format-compound-statement (stream body)
381 (format stream "while (~A)" cond)))
383 (definst do-while (stream :export t) (body %cond)
384 (format-compound-statement (stream body :space)
385 (write-string "do" stream))
386 (format stream "while (~A);" cond))
388 (definst for (stream :export t) (init %cond update body)
389 (format-compound-statement (stream body)
390 (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
393 ;;;--------------------------------------------------------------------------
398 (export 'codegen-functions)
399 (defgeneric codegen-functions (codegen)
401 "Return the list of `function-inst's of completed functions."))
404 (defgeneric ensure-var (codegen name type &optional init)
406 "Add a variable to CODEGEN's list.
408 The variable is called NAME (which should be comparable using `equal' and
409 print to an identifier) and has the given TYPE. If INIT is present and
410 non-nil it is an expression `inst' used to provide the variable with an
413 (export '(emit-inst emit-insts))
414 (defgeneric emit-inst (codegen inst)
416 "Add INST to the end of CODEGEN's list of instructions."))
417 (defgeneric emit-insts (codegen insts)
419 "Add a list of INSTS to the end of CODEGEN's list of instructions.")
420 (:method (codegen insts)
421 (dolist (inst insts) (emit-inst codegen inst))))
423 (export '(emit-decl emit-decls))
424 (defgeneric emit-decl (codegen inst)
426 "Add INST to the end of CODEGEN's list of declarations."))
427 (defgeneric emit-decls (codegen insts)
429 "Add a list of INSTS to the end of CODEGEN's list of declarations."))
431 (export 'codegen-push)
432 (defgeneric codegen-push (codegen)
434 "Pushes the current code generation state onto a stack.
436 The state consists of the accumulated variables and instructions."))
438 (export 'codegen-pop)
439 (defgeneric codegen-pop (codegen)
441 "Pops a saved state off of the CODEGEN's stack.
443 Returns the newly accumulated variables and instructions as lists, as
446 (export 'codegen-add-function)
447 (defgeneric codegen-add-function (codegen function)
449 "Adds a function to CODEGEN's list.
451 Actually, we're not picky: FUNCTION can be any kind of object that you're
452 willing to find in the list returned by `codegen-functions'."))
454 (export 'temporary-var)
455 (defgeneric temporary-var (codegen type)
457 "Return the name of a temporary variable.
459 The temporary variable will have the given TYPE, and will be marked
460 in-use. You should clear the in-use flag explicitly when you've finished
461 with the variable -- or, better, use `with-temporary-var' to do the
462 cleanup automatically."))
464 (export 'codegen-build-function)
465 (defun codegen-build-function
466 (codegen name type vars insts &optional banner &rest banner-args)
467 "Build a function and add it to CODEGEN's list.
469 Returns the function's name."
470 (codegen-add-function codegen
471 (apply #'make-function-inst name type
472 (make-block-inst vars insts)
476 (export 'codegen-pop-block)
477 (defgeneric codegen-pop-block (codegen)
479 "Makes a block (`block-inst') out of the completed code in CODEGEN.")
481 (multiple-value-bind (vars insts) (codegen-pop codegen)
482 (make-block-inst vars insts))))
484 (export 'codegen-pop-function)
485 (defgeneric codegen-pop-function
486 (codegen name type &optional banner &rest banner-args)
488 "Makes a function out of the completed code in CODEGEN.
490 The NAME can be any object you like. The TYPE should be a function type
491 object which includes argument names. The return value is the NAME.")
492 (:method (codegen name type &optional banner &rest banner-args)
493 (multiple-value-bind (vars insts) (codegen-pop codegen)
494 (apply #'codegen-build-function codegen name type vars insts
495 banner banner-args))))
497 (export 'with-temporary-var)
498 (defmacro with-temporary-var ((codegen var type) &body body)
499 "Evaluate BODY with VAR bound to a temporary variable name.
501 During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
502 available for re-use."
503 (multiple-value-bind (doc decls body) (parse-body body :docp nil)
504 (declare (ignore doc))
505 `(let ((,var (temporary-var ,codegen ,type)))
509 (setf (var-in-use-p ,var) nil)))))
511 ;;;--------------------------------------------------------------------------
512 ;;; Code generation idioms.
514 (export 'deliver-expr)
515 (defun deliver-expr (codegen target expr)
516 "Emit code to deliver the value of EXPR to the TARGET.
518 The TARGET may be one of the following.
520 * `:void', indicating that the value is to be discarded. The expression
521 will still be evaluated.
523 * `:void-return', indicating that the value is to be discarded (as for
524 `:void') and furthermore a `return' from the current function should
525 be forced after computing the value.
527 * `:return', indicating that the value is to be returned from the
530 * A variable name, indicating that the value is to be stored in the
533 In the cases of `:return', `:void' and `:void-return' targets, it is valid
534 for EXPR to be nil; this signifies that no computation needs to be
535 performed. Variable-name targets require an expression."
538 (:return (emit-inst codegen (make-return-inst expr)))
539 (:void (when expr (emit-inst codegen (make-expr-inst expr))))
540 (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
541 (emit-inst codegen (make-return-inst nil)))
542 (t (emit-inst codegen (make-set-inst target expr)))))
544 (export 'convert-stmts)
545 (defun convert-stmts (codegen target type func)
546 "Invoke FUNC to deliver a value to a non-`:return' target.
548 FUNC is a function which accepts a single argument, a non-`:return'
549 target, and generates statements which deliver a value (see
550 `deliver-expr') of the specified TYPE to this target. In general, the
551 generated code will have the form
553 setup instructions...
554 (deliver-expr CODEGEN TARGET (compute value...))
555 cleanup instructions...
557 where the cleanup instructions are essential to the proper working of the
560 The `convert-stmts' function will call FUNC to generate code, and arrange
561 that its value is correctly delivered to TARGET, regardless of what the
562 TARGET is -- i.e., it lifts the restriction to non-`:return' targets. It
563 does this by inventing a new temporary variable."
566 (:return (with-temporary-var (codegen var type)
568 (deliver-expr codegen target var)))
569 (:void-return (funcall func :void)
570 (emit-inst codegen (make-return-inst nil)))
571 (t (funcall func target))))
573 (export 'deliver-call)
574 (defun deliver-call (codegen target func &rest args)
575 "Emit a statement to call FUNC with ARGS and deliver the result to TARGET."
576 (deliver-expr codegen target (apply #'make-call-inst func args)))
578 ;;;----- That's all, folks --------------------------------------------------