3 ;;; Code generator for effective methods
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Simple Object Definition system.
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 ;;;--------------------------------------------------------------------------
31 (defclass temporary-name ()
32 ((tag :initarg :tag :reader temp-tag))
34 "Base class for temporary variable and argument names."))
36 (defclass temporary-argument (temporary-name) ())
37 (defclass temporary-function (temporary-name) ())
39 (defclass temporary-variable (temporary-name)
40 ((in-use-p :initarg :in-use-p
43 :accessor var-in-use-p)))
45 (defmethod var-in-use-p ((var t))
46 "Non-temporary variables are always in use."
49 (defmethod commentify-argument-name ((name temporary-name))
52 (defparameter *temporary-index* 0
53 "Index for temporary name generation.
55 This is automatically reset to zero before the output functions are
56 invoked to write a file. This way, we can ensure that the same output
57 file is always produced from the same input.")
59 (defun temporary-function ()
60 "Return a temporary function name."
61 (make-instance 'temporary-function
62 :tag (prog1 *temporary-index* (incf *temporary-index*))))
64 (defgeneric format-temporary-name (var stream)
65 (:method ((var temporary-name) stream)
66 (format stream "~A" (temp-tag var)))
67 (:method ((var temporary-argument) stream)
68 (format stream "sod__a~A" (temp-tag var)))
69 (:method ((var temporary-variable) stream)
70 (format stream "sod__v~A" (temp-tag var)))
71 (:method ((var temporary-function) stream)
72 (format stream "sod__f~A" (temp-tag var))))
74 (defmethod print-object ((var temporary-name) stream)
76 (print-unreadable-object (var stream :type t)
77 (prin1 (temp-tag var) stream))
78 (format-temporary-name var stream)))
80 (defparameter *sod-ap*
81 (make-instance 'temporary-name :tag "sod__ap"))
82 (defparameter *sod-master-ap*
83 (make-instance 'temporary-name :tag "sod__master_ap"))
85 ;;;--------------------------------------------------------------------------
90 "A base class for instructions.
92 An `instruction' is anything which might be useful to string into a code
93 generator. Both statements and expressions map can be represented by
94 trees of instructions. The DEFINST macro is a convenient way of defining
97 The only important protocol for instructions is output, which is achieved
98 by calling PRINT-OBJECT with *PRINT-ESCAPE* nil.
100 This doesn't really do very much, but it acts as a handy marker for
101 instruction subclasses."))
103 (defgeneric inst-metric (inst)
105 "Returns a `metric' describing how complicated INST is.
107 The default metric of an inst node is simply 1; INST subclasses generated
108 by DEFINST (q.v.) have an automatically generated method which returns one
109 plus the sum of the metrics of the node's children.
111 This isn't intended to be a particularly rigorous definition. Its purpose
112 is to allow code generators to make decisions about inlining or calling
113 code fairly simply.")
116 (defmacro definst (code (streamvar) args &body body)
117 "Define an instruction type and describe how to output it.
119 An INST can represent any structured piece of output syntax: a statement,
120 expression or declaration, for example. This macro defines the following
123 * A class CODE-INST to represent the instruction.
125 * Instance slots named after the ARGS, with matching keyword initargs,
126 and INST-ARG readers.
128 * A constructor MAKE-CODE-INST which accepts the ARGS (in order, not
129 with keywords) as arguments and returns a fresh instance.
131 * A print method, which prints a diagnostic dump if *PRINT-ESCAPE* is
132 set, or invokes the BODY (with STREAMVAR bound to the output stream)
133 otherwise. The BODY is expected to produce target code at this
136 (let ((inst-var (gensym "INST"))
137 (class-name (symbolicate code '-inst))
138 (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
141 (defclass ,class-name (inst)
142 ,(mapcar (lambda (arg key)
143 `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg)))
145 (defun ,(symbolicate 'make- code '-inst) (,@args)
146 (make-instance ',class-name ,@(mappend #'list keys args)))
147 (defmethod inst-metric ((,inst-var ,class-name))
148 (with-slots (,@args) ,inst-var
149 (+ 1 ,@(mapcar (lambda (arg) `(inst-metric ,arg)) args))))
150 (defmethod print-object ((,inst-var ,class-name) ,streamvar)
151 (with-slots (,@args) ,inst-var
153 (print-unreadable-object (,inst-var ,streamvar :type t)
154 (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
155 ,@(mappend #'list keys args)))
158 (defun format-compound-statement* (stream child morep thunk)
159 "Underlying function for FORMAT-COMPOUND-STATEMENT."
160 (cond ((typep child 'block-inst)
161 (funcall thunk stream)
162 (write-char #\space stream)
164 (when morep (write-char #\space stream)))
166 (pprint-logical-block (stream nil)
167 (funcall thunk stream)
168 (write-char #\space stream)
169 (pprint-indent :block 2 stream)
170 (pprint-newline :linear stream)
172 (pprint-indent :block 0 stream)
175 (write-char #\space stream)
176 (pprint-newline :linear stream))
178 (pprint-newline :mandatory stream)))))))
180 (defmacro format-compound-statement
181 ((stream child &optional morep) &body body)
182 "Format a compound statement to STREAM.
184 The introductory material is printed by BODY. The CHILD is formatted
185 properly according to whether it's a BLOCK-INST. If MOREP is true, then
186 allow for more stuff following the child."
187 `(format-compound-statement* ,stream ,child ,morep
188 (lambda (,stream) ,@body)))
190 ;;;--------------------------------------------------------------------------
191 ;;; Instruction types.
193 ;; Compound statements.
195 (definst block (stream) (decls body)
196 (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
199 (definst if (stream) (condition consequent alternative)
200 (format-compound-statement (stream consequent alternative)
201 (format stream "if (~A)" condition))
203 (format-compound-statement (stream alternative)
204 (write-string "else" stream))))
206 (definst while (stream) (condition body)
207 (format-compound-statement (stream body)
208 (format stream "while (~A)" condition)))
210 (definst do-while (stream) (body condition)
211 (format-compound-statement (stream body :space)
212 (write-string "do" stream))
213 (format stream "while (~A);" condition))
215 ;; Simple statements.
217 (definst set (stream) (var expr)
218 (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
220 (definst return (stream) (expr)
221 (format stream "return~@[ (~A)~];" expr))
223 (definst expr (stream) (expr)
224 (format stream "~A;" expr))
226 ;; Special varargs hacks.
228 (definst va-start (stream) (ap arg)
229 (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
231 (definst va-copy (stream) (to from)
232 (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
234 (definst va-end (stream) (ap)
235 (format stream "va_end(~A);" ap))
237 ;; Declarations. These should appear at the heads of BLOCK-INSTs.
239 (definst var (stream) (name type init)
240 (pprint-c-type type stream name)
242 (format stream " = ~A" init)))
246 (definst call (stream) (func args)
247 (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
251 (definst function (stream) (name type body)
252 (pprint-logical-block (stream nil)
253 (pprint-c-type type stream name)
254 (format stream "~:@_~A~:@_~:@_" body)))
256 ;;;--------------------------------------------------------------------------
257 ;;; Code generator objects.
259 (defclass basic-codegen ()
260 ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
261 (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
262 (temp-index :initarg :temp-index
265 :accessor codegen-temp-index))
267 "Base class for code generator state.
269 This contains the bare essentials for supporting the EMIT-INST and
270 ENSURE-VAR protocols; see the documentation for those generic functions
273 This class isn't abstract. A full CODEGEN object uses instances of this
274 to keep track of pending functions which haven't been completed yet.
276 Just in case that wasn't clear enough: this is nothing to do with the
279 (defgeneric emit-inst (codegen inst)
281 "Add INST to the end of CODEGEN's list of instructions.")
282 (:method ((codegen basic-codegen) inst)
283 (push inst (codegen-insts codegen))))
285 (defgeneric emit-insts (codegen insts)
287 "Add a list of INSTS to the end of CODEGEN's list of instructions.")
288 (:method ((codegen basic-codegen) insts)
289 (setf (codegen-insts codegen)
290 (revappend insts (codegen-insts codegen)))))
292 (defgeneric ensure-var (codegen name type &optional init)
294 "Add a variable to CODEGEN's list.
296 The variable is called NAME (which should be comparable using EQUAL and
297 print to an identifier) and has the given TYPE. If INIT is present and
298 non-nil it is an expression INST used to provide the variable with an
300 (:method ((codegen basic-codegen) name type &optional init)
301 (let* ((vars (codegen-vars codegen))
302 (var (find name vars :key #'inst-name :test #'equal)))
304 (setf (codegen-vars codegen)
305 (cons (make-var-inst name type init) vars)))
306 ((not (c-type-equal-p type (inst-type var)))
307 (error "(Internal) Redefining type for variable ~A." name)))
310 (defclass codegen (basic-codegen)
311 ((functions :initform nil :type list :accessor codegen-functions)
312 (stack :initform nil :type list :accessor codegen-stack))
314 "A full-fat code generator which can generate and track functions.
316 This is the real deal. Subclasses may which to attach additional state
317 for convenience's sake, but this class is self-contained. It supports the
318 CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
320 (defgeneric codegen-push (codegen)
322 "Pushes the current code generation state onto a stack.
324 The state consists of the accumulated variables and instructions, i.e.,
325 what is representable by a BASIC-CODEGEN.")
326 (:method ((codegen codegen))
327 (with-slots (vars insts temp-index stack) codegen
328 (push (make-instance 'basic-codegen
331 :temp-index temp-index)
333 (setf vars nil insts nil temp-index 0))))
335 (defgeneric codegen-pop (codegen)
337 "Pops a saved state off of the CODEGEN's stack.
339 Returns the newly accumulated variables and instructions as lists, as
341 (:method ((codegen codegen))
342 (with-slots (vars insts temp-index stack) codegen
343 (multiple-value-prog1
344 (values (nreverse vars) (nreverse insts))
345 (let ((sub (pop stack)))
346 (setf vars (codegen-vars sub)
347 insts (codegen-insts sub)
348 temp-index (codegen-temp-index sub)))))))
350 (defgeneric codegen-add-function (codegen function)
352 "Adds a function to CODEGEN's list.
354 Actually, we're not picky: FUNCTION can be any kind of object that you're
355 willing to find in the list returned by CODEGEN-FUNCTIONS.")
356 (:method ((codegen codegen) function)
357 (with-slots (functions) codegen
358 (setf functions (nconc functions (list function))))))
360 (defun codegen-build-function (codegen name type vars insts)
361 "Build a function and add it to CODEGEN's list.
363 Returns the function's name."
364 (codegen-add-function codegen
365 (make-function-inst name type
366 (make-block-inst vars insts)))
369 (defgeneric codegen-pop-function (codegen name type)
371 "Makes a function out of the completed code in CODEGEN.
373 The NAME can be any object you like. The TYPE should be a function type
374 object which includes argument names. The return value is the NAME.")
375 (:method ((codegen codegen) name type)
376 (multiple-value-bind (vars insts) (codegen-pop codegen)
377 (codegen-build-function codegen name type vars insts))))
379 (defgeneric temporary-var (codegen type)
381 "Return the name of a temporary variable.
383 The temporary variable will have the given TYPE, and will be marked
384 in-use. You should clear the in-use flag explicitly when you've finished
385 with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
388 (defmethod temporary-var ((codegen basic-codegen) type)
389 (with-slots (vars temp-index) codegen
390 (or (find-if (lambda (var)
391 (and (not (var-in-use-p (inst-name var)))
392 (c-type-equal-p type (inst-type var))))
394 (let* ((name (make-instance 'temporary-variable
395 :tag (prog1 temp-index
396 (incf temp-index)))))
397 (push (make-var-inst name type nil) vars)
400 (defmacro with-temporary-var ((codegen var type) &body body)
401 "Evaluate BODY with VAR bound to a temporary variable name.
403 During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
404 available for re-use."
405 `(let ((,var (temporary-var ,codegen ,type)))
408 (setf (var-in-use-p ,var) nil))))
410 ;;;--------------------------------------------------------------------------
411 ;;; Code generation idioms.
413 (defun deliver-expr (codegen target expr)
414 "Emit code to deliver the value of EXPR to the TARGET.
416 The TARGET may be one of the following.
418 * :VOID, indicating that the value is to be discarded. The expression
419 will still be evaluated.
421 * :VOID-RETURN, indicating that the value is to be discarded (as for
422 :VOID) and furthermore a `return' from the current function should be
423 forced after computing the value.
425 * :RETURN, indicating that the value is to be returned from the current
428 * A variable name, indicating that the value is to be stored in the
431 In the cases of :RETURN, :VOID and :VOID-RETURN targets, it is valid for
432 EXPR to be nil; this signifies that no computation needs to be performed.
433 Variable-name targets require an expression."
436 (:return (emit-inst codegen (make-return-inst expr)))
437 (:void (when expr (emit-inst codegen (make-expr-inst expr))))
438 (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
439 (emit-inst codegen (make-return-inst nil)))
440 (t (emit-inst codegen (make-set-inst target expr)))))
442 (defun convert-stmts (codegen target type func)
443 "Invoke FUNC to deliver a value to a non-:RETURN target.
445 FUNC is a function which accepts a single argument, a non-:RETURN target,
446 and generates statements which deliver a value (see DELIVER-EXPR) of the
447 specified TYPE to this target. In general, the generated code will have
450 setup instructions...
451 (DELIVER-EXPR CODEGEN TARGET (compute value...))
452 cleanup instructions...
454 where the cleanup instructions are essential to the proper working of the
457 CONVERT-STMTS will call FUNC to generate code, and arrange that its value
458 is correctly delivered to TARGET, regardless of what the TARGET is --
459 i.e., it lifts the restriction to non-:RETURN targets. It does this by
460 inventing a new temporary variable."
463 (:return (with-temporary-var (codegen var type)
465 (deliver-expr codegen target var)))
466 (:void-return (funcall func :void)
467 (emit-inst codegen (make-return-inst nil)))
468 (t (funcall func target))))
470 ;;;----- That's all, folks --------------------------------------------------