chiark - git - mdw - sod/blob - src/codegen-proto.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Code generation protocol
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible Object Design, an object system for C.
  11 ;;;
  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.
  16 ;;;
  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.
  21 ;;;
  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.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Temporary names.
  30
  31 ;; Protocol.
  32
  33 (export 'format-temporary-name)
  34 (defgeneric format-temporary-name (var stream)
  35   (:documentation
  36    "Write the name of a temporary variable VAR to STREAM."))
  37
  38 (export 'var-in-use-p)
  39 (defgeneric var-in-use-p (var)
  40   (:documentation
  41    "Answer whether VAR is currently being used.  See `with-temporary-var'.")
  42   (:method (var)
  43     "Non-temporary variables are always in use."
  44     (declare (ignore var))
  45     t))
  46 (defgeneric (setf var-in-use-p) (value var)
  47   (:documentation
  48    "Record whether VAR is currently being used.  See `with-temporary-var'."))
  49
  50 ;; Root class.
  51
  52 (export '(temporary-name temp-tag))
  53 (defclass temporary-name ()
  54   ((tag :initarg :tag :reader temp-tag))
  55   (:documentation
  56    "Base class for temporary variable and argument names."))
  57
  58 ;; Important temporary names.
  59
  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"))
  73
  74 (export '*null-pointer*)
  75 (defparameter *null-pointer* "NULL")
  76
  77 ;;;--------------------------------------------------------------------------
  78 ;;; Instructions.
  79
  80 ;; Classes.
  81
  82 (export 'inst)
  83 (defclass inst () ()
  84   (:documentation
  85    "A base class for instructions.
  86
  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
  90    instructions.
  91
  92    The only important protocol for instructions is output, which is achieved
  93    by calling `print-object' with `*print-escape*' nil.
  94
  95    This doesn't really do very much, but it acts as a handy marker for
  96    instruction subclasses."))
  97
  98 (export 'inst-metric)
  99 (defgeneric inst-metric (inst)
 100   (:documentation
 101    "Returns a `metric' describing how complicated INST is.
 102
 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.
 106
 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.")
 110   (:method ((inst t))
 111     (declare (ignore inst))
 112     1)
 113   (:method ((inst null))
 114     (declare (ignore inst))
 115     1)
 116   (:method ((inst list))
 117     (reduce #'+ inst :key #'inst-metric)))
 118
 119 ;; Instruction definition.
 120
 121 (export 'definst)
 122 (defmacro definst (code (streamvar &key export) args &body body)
 123   "Define an instruction type and describe how to output it.
 124
 125    An `inst' can represent any structured piece of output syntax: a
 126    statement, expression or declaration, for example.  This macro defines the
 127    following things:
 128
 129      * A class `CODE-inst' to represent the instruction.
 130
 131      * Instance slots named after the ARGS, with matching keyword initargs,
 132        and `inst-ARG' readers.
 133
 134      * A constructor `make-CODE-inst' which accepts the ARGS (as an ordinary
 135        BVL) as arguments and returns a fresh instance.
 136
 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
 140        point.
 141
 142    The ARGS are an ordinary lambda-list, with the following quirks:
 143
 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.
 148
 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.
 153
 154    If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
 155    symbols."
 156
 157   (multiple-value-bind (bvl public private)
 158       ;; The hard part of this is digging through the BVL to find the slot
 159       ;; names.  Collect them into an actual BVL which will be acceptable to
 160       ;; `defun', and (matching) lists of the PUBLIC and PRIVATE names of the
 161       ;; slots.
 162
 163       (let ((state :mandatory)
 164             (bvl (make-list-builder))
 165             (public (make-list-builder))
 166             (private (make-list-builder)))
 167
 168         (labels ((recurse-arg (arg path)
 169                    ;; Figure out the argument name in ARG, which might be a
 170                    ;; symbol or a list with the actual argument name buried
 171                    ;; in it somewhere.  Once we've found it, return the
 172                    ;; appropriate entries to add to the BVL, PUBLIC, and
 173                    ;; PRIVATE lists.
 174                    ;;
 175                    ;; The PATH indicates a route to take through the tree to
 176                    ;; find the actual argument name: it's a list of
 177                    ;; nonnegative integers, one for each level of structure:
 178                    ;; the integer indicates which element of the list at that
 179                    ;; level to descend into to find the argument name
 180                    ;; according to the usual BVL syntax.  It's always
 181                    ;; acceptable for a level to actually be a symbol, which
 182                    ;; is then the argument name we were after.  If we reach
 183                    ;; the bottom and we still have a list, then it must be a
 184                    ;; (PUBLIC PRIVATE) pair.
 185
 186                    (cond ((symbolp arg)
 187                           ;; We've bottommed out at a symbol.  If it starts
 188                           ;; with a `%' then that's the private name: strip
 189                           ;; the `%' to find the public name.  Otherwise, the
 190                           ;; symbol is all we have.
 191
 192                           (let ((name (symbol-name arg)))
 193                             (if (and (plusp (length name))
 194                                      (char= (char name 0) #\%))
 195                                 (let ((public (intern (subseq name 1))))
 196                                   (values public public arg))
 197                                 (values arg arg arg))))
 198
 199                          ((atom arg)
 200                           ;; Any other kind of atom is obviously bogus.
 201                           (error "Unexpected item ~S in lambda-list." arg))
 202
 203                          ((null path)
 204                           ;; We've bottommed out of the path and still have a
 205                           ;; list.  It must be (PUBLIC PRIVATE).
 206
 207                           (multiple-value-bind (public private)
 208                               (if (cdr arg) (values (car arg) (cadr arg))
 209                                   (values (car arg) (car arg)))
 210                             (values public public private)))
 211
 212                          (t
 213                           ;; We have a list.  Take the first step in the
 214                           ;; PATH, and recursively process corresponding list
 215                           ;; element with the remainder of the PATH.  The
 216                           ;; PUBLIC and PRIVATE slot names are fine, but we
 217                           ;; must splice the given BVL entry into our list
 218                           ;; structure.
 219
 220                           (let* ((step (car path))
 221                                  (mine (nthcdr step arg)))
 222                             (multiple-value-bind (full public private)
 223                                 (recurse-arg (car mine) (cdr path))
 224                               (values (append (subseq arg 0 step)
 225                                               full
 226                                               (cdr mine))
 227                                       public
 228                                       private))))))
 229
 230                  (hack-arg (arg maxdp)
 231                    ;; Find the actual argument name in a BVL entry, and add
 232                    ;; the appropriate entries to the `bvl', `public', and
 233                    ;; `private' lists.
 234
 235                    (multiple-value-bind (full public-name private-name)
 236                        (recurse-arg arg maxdp)
 237                      (lbuild-add bvl full)
 238                      (lbuild-add public public-name)
 239                      (lbuild-add private private-name))))
 240
 241           ;; Process the augmented BVL, extracting a standard BVL suitable
 242           ;; for `defun', and the public and private slot names into our
 243           ;; list.
 244           (dolist (arg args)
 245             (cond ((or (eq arg '&optional)
 246                        (eq arg '&rest)
 247                        (eq arg '&key)
 248                        (eq arg '&aux))
 249                    (setf state arg)
 250                    (lbuild-add bvl arg))
 251
 252                   ((eq arg '&allow-other-keys)
 253                    (lbuild-add bvl arg))
 254
 255                   ((or (eq state :mandatory)
 256                        (eq state '&rest))
 257                    (hack-arg arg '()))
 258
 259                   ((or (eq state '&optional)
 260                        (eq state '&aux))
 261                    (hack-arg arg '(0)))
 262
 263                   ((eq state '&key)
 264                    (hack-arg arg '(0 1)))
 265
 266                   (t
 267                    (error "Confusion in ~S!" 'definst)))))
 268
 269         ;; Done!  That was something of a performance.
 270         (values (lbuild-list bvl)
 271                 (lbuild-list public)
 272                 (lbuild-list private)))
 273
 274     ;; Now we can actually build the pieces of the code-generation machinery.
 275     (let* ((inst-var (gensym "INST"))
 276            (class-name (symbolicate code '-inst))
 277            (constructor-name (symbolicate 'make- code '-inst))
 278            (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
 279                          public)))
 280       (multiple-value-bind (docs decls body) (parse-body body)
 281
 282         ;; We have many jobs to do in the expansion.
 283         `(progn
 284
 285            ;; A class to hold the data.
 286            (defclass ,class-name (inst)
 287              ,(mapcar (lambda (public-slot private-slot key)
 288                         `(,private-slot :initarg ,key
 289                                         :reader
 290                                           ,(symbolicate 'inst- public-slot)))
 291                       public private keys))
 292
 293            ;; A constructor to make an instance of the class.
 294            (defun ,constructor-name (,@bvl)
 295              (make-instance ',class-name ,@(mappend #'list keys public)))
 296
 297            ;; A method on `inst-metric', to feed into inlining heuristics.
 298            (defmethod inst-metric ((,inst-var ,class-name))
 299              (with-slots (,@private) ,inst-var
 300                (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot))
 301                               private))))
 302
 303            ;; A method to actually produce the necessary output.
 304            (defmethod print-object ((,inst-var ,class-name) ,streamvar)
 305              (with-slots ,(mapcar #'list public private) ,inst-var
 306                (if *print-escape*
 307                    (print-unreadable-object (,inst-var ,streamvar :type t)
 308                      (format ,streamvar "~@<~@{~S ~@_~S~^ ~_~}~:>"
 309                              ,@(mappend #'list keys public)))
 310                    (block ,code
 311                      ,@(if (null decls) body
 312                            `((locally ,@decls ,@body)))))))
 313
 314            ;; Maybe export all of this stuff.
 315            ,@(and export `((export '(,class-name ,constructor-name
 316                                      ,@(mapcar (lambda (slot)
 317                                                  (symbolicate 'inst- slot))
 318                                                public)))))
 319
 320            ;; Remember the documentation.
 321            ,@(and docs `((setf (get ',class-name 'inst-documentation)
 322                                  ,@docs)))
 323
 324            ;; And try not to spam a REPL.
 325            ',code)))))
 326
 327 (defmethod documentation ((symbol symbol) (doc-type (eql 'inst)))
 328   (get symbol 'inst-documentation))
 329 (defmethod (setf documentation) (doc (symbol symbol) (doc-type (eql 'inst)))
 330   (setf (get symbol 'inst-documentation) doc))
 331
 332 ;; Formatting utilities.
 333
 334 (defun format-compound-statement* (stream child morep thunk)
 335   "Underlying function for `format-compound-statement'."
 336   (cond ((typep child 'block-inst)
 337          (funcall thunk stream)
 338          (write-char #\space stream)
 339          (princ child stream)
 340          (when morep (write-char #\space stream)))
 341         (t
 342          (pprint-logical-block (stream nil)
 343            (funcall thunk stream)
 344            (write-char #\space stream)
 345            (pprint-indent :block 2 stream)
 346            (pprint-newline :linear stream)
 347            (princ child stream)
 348            (pprint-indent :block 0 stream))
 349          (case morep
 350            (:space
 351             (write-char #\space stream)
 352             (pprint-newline :linear stream))
 353            ((t)
 354             (pprint-newline :mandatory stream))))))
 355
 356 (export 'format-compound-statement)
 357 (defmacro format-compound-statement
 358     ((stream child &optional morep) &body body)
 359   "Format a compound statement to STREAM.
 360
 361    The introductory material is printed by BODY.  The CHILD is formatted
 362    properly according to whether it's a `block-inst'.  If MOREP is true, then
 363    allow for more stuff following the child."
 364   `(format-compound-statement* ,stream ,child ,morep
 365                                (lambda (,stream) ,@body)))
 366
 367 (export 'format-banner-comment)
 368 (defun format-banner-comment (stream control &rest args)
 369   "Format a comment, built from a `format' CONTROL string and ARGS.
 370
 371    The comment is wrapped in the usual `/* ... */' C comment delimiters, and
 372    word-wrapped if necessary.  If multiple lines are needed, then a column of
 373    `*'s is left down the left hand side, and the final `*/' ends up properly
 374    aligned on a line by itself."
 375   (format stream "~@</~@<* ~@;~?~:>~_ */~:>" control args))
 376
 377 ;; Important instruction classes.
 378
 379 (definst var (stream :export t) (name %type &optional init)
 380   "Declare a variable: TYPE NAME [= INIT].
 381
 382    This usually belongs in the DECLS of a `block'."
 383   (pprint-logical-block (stream nil)
 384     (pprint-c-type type stream name)
 385     (when init
 386       (format stream " = ~2I~_~A" init))
 387     (write-char #\; stream)))
 388
 389 (definst function (stream :export t)
 390     (name %type body &optional %banner &rest banner-args)
 391   "Define a function.
 392
 393    The TYPE must be a function type.  The BANNER and BANNER-ARGS are a
 394    `format' control string and its argument list.  Output looks like:
 395
 396         /* BANNER */
 397         TYPE NAME(ARGS-FROM-TYPE)
 398         {
 399           BODY
 400         }"
 401   (pprint-logical-block (stream nil)
 402     (when banner
 403       (apply #'format-banner-comment stream banner banner-args)
 404       (pprint-newline :mandatory stream))
 405     (princ "static " stream)
 406     (pprint-c-type type stream name)
 407     (format stream "~:@_~A~:@_~:@_" body)))
 408
 409 ;; Expression statements.
 410 (definst expr (stream :export t) (%expr)
 411   "An expression statement: EXPR;"
 412   (format stream "~A;" expr))
 413 (definst set (stream :export t) (var %expr)
 414   "An assignment statement: VAR = EXPR;"
 415   (format stream "~@<~A = ~2I~_~A;~:>" var expr))
 416 (definst update (stream :export t) (var op %expr)
 417   "An update statement: VAR OP= EXPR;"
 418   (format stream "~@<~A ~A= ~2I~_~A;~:>" var op expr))
 419
 420 ;; Special kinds of expressions.
 421 (definst call (stream :export t) (%func &rest args)
 422   "A function-call expression: FUNC(ARGS)"
 423   (format stream "~@<~A~4I~_(~@<~{~A~^, ~_~}~:>)~:>" func args))
 424 (definst cond (stream :export t) (%cond conseq alt)
 425   "A conditional expression: COND ? CONSEQ : ALT"
 426   (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" cond conseq alt))
 427
 428 ;; Simple statements.
 429 (definst return (stream :export t) (%expr)
 430   "A `return' statement: return [(EXPR)];"
 431   (format stream "return~@[ (~A)~];" expr))
 432 (definst break (stream :export t) ()
 433   "A `break' statement: break;"
 434   (format stream "break;"))
 435 (definst continue (stream :export t) ()
 436   "A `continue' statement: continue;"
 437   (format stream "continue;"))
 438
 439 ;; Compound statements.
 440
 441 (defvar *first-statement-p* t
 442   "True if this is the first statement in a block.
 443
 444    This is used to communicate between `block-inst' and `banner-inst' so that
 445    they get the formatting right between them.")
 446
 447 (definst banner (stream :export t) (control &rest args)
 448   "A banner comment, built from a `format' CONTROL string and ARGS.
 449
 450    See `format-banner-comment' for more details."
 451   (pprint-logical-block (stream nil)
 452     (unless *first-statement-p* (pprint-newline :mandatory stream))
 453     (apply #'format-banner-comment stream control args)))
 454
 455 (export 'emit-banner)
 456 (defun emit-banner (codegen control &rest args)
 457   "Emit a `banner-inst' to CODEGEN, with the given CONTROL and ARGS."
 458   (emit-inst codegen (apply #'make-banner-inst control args)))
 459
 460 (definst block (stream :export t) (decls body)
 461   "A compound statement.
 462
 463    The output looks like
 464
 465         {
 466           DECLS
 467
 468           BODY
 469         }
 470
 471    If controlled by `if', `while', etc., then the leading brace ends up on
 472    the same line, following K&R conventions."
 473   (write-char #\{ stream)
 474   (pprint-newline :mandatory stream)
 475   (pprint-logical-block (stream nil)
 476     (let ((newlinep nil))
 477       (flet ((newline ()
 478                (if newlinep
 479                    (pprint-newline :mandatory stream)
 480                    (setf newlinep t))))
 481         (pprint-indent :block 2 stream)
 482         (write-string "  " stream)
 483         (when decls
 484           (dolist (decl decls)
 485             (newline)
 486             (write decl :stream stream))
 487           (when body (newline)))
 488         (let ((*first-statement-p* t))
 489           (dolist (inst body)
 490             (newline)
 491             (write inst :stream stream)
 492             (setf *first-statement-p* nil))))))
 493   (pprint-newline :mandatory stream)
 494   (write-char #\} stream))
 495
 496 (definst if (stream :export t) (%cond conseq &optional alt)
 497   "An `if' statement: if (COND) CONSEQ [else ALT]"
 498   (let ((stmt "if"))
 499     (loop (format-compound-statement (stream conseq (if alt t nil))
 500             (format stream "~A (~A)" stmt cond))
 501           (typecase alt
 502             (null (return))
 503             (if-inst (setf stmt "else if"
 504                            cond (inst-cond alt)
 505                            conseq (inst-conseq alt)
 506                            alt (inst-alt alt)))
 507             (t (format-compound-statement (stream alt)
 508                  (format stream "else"))
 509                (return))))))
 510
 511 (definst while (stream :export t) (%cond body)
 512   "A `while' statement: while (COND) BODY"
 513   (format-compound-statement (stream body)
 514     (format stream "while (~A)" cond)))
 515
 516 (definst do-while (stream :export t) (body %cond)
 517   "A `do'/`while' statement: do BODY while (COND);"
 518   (format-compound-statement (stream body :space)
 519     (write-string "do" stream))
 520   (format stream "while (~A);" cond))
 521
 522 (definst for (stream :export t) (init %cond update body)
 523   "A `for' statement: for (INIT; COND; UPDATE) BODY"
 524   (format-compound-statement (stream body)
 525     (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
 526             init cond update)))
 527
 528 ;;;--------------------------------------------------------------------------
 529 ;;; Code generation.
 530
 531 ;; Accessors.
 532
 533 (export 'codegen-functions)
 534 (defgeneric codegen-functions (codegen)
 535   (:documentation
 536    "Return the list of `function-inst's of completed functions."))
 537
 538 (export 'ensure-var)
 539 (defgeneric ensure-var (codegen name type &optional init)
 540   (:documentation
 541    "Add a variable to CODEGEN's list.
 542
 543    The variable is called NAME (which should be comparable using `equal' and
 544    print to an identifier) and has the given TYPE.  If INIT is present and
 545    non-nil it is an expression `inst' used to provide the variable with an
 546    initial value."))
 547
 548 (export '(emit-inst emit-insts))
 549 (defgeneric emit-inst (codegen inst)
 550   (:documentation
 551    "Add INST to the end of CODEGEN's list of instructions."))
 552 (defgeneric emit-insts (codegen insts)
 553   (:documentation
 554    "Add a list of INSTS to the end of CODEGEN's list of instructions.")
 555   (:method (codegen insts)
 556     (dolist (inst insts) (emit-inst codegen inst))))
 557
 558 (export '(emit-decl emit-decls))
 559 (defgeneric emit-decl (codegen inst)
 560   (:documentation
 561    "Add INST to the end of CODEGEN's list of declarations."))
 562 (defgeneric emit-decls (codegen insts)
 563   (:documentation
 564    "Add a list of INSTS to the end of CODEGEN's list of declarations."))
 565
 566 (export 'codegen-push)
 567 (defgeneric codegen-push (codegen)
 568   (:documentation
 569    "Pushes the current code generation state onto a stack.
 570
 571    The state consists of the accumulated variables and instructions."))
 572
 573 (export 'codegen-pop)
 574 (defgeneric codegen-pop (codegen)
 575   (:documentation
 576    "Pops a saved state off of the CODEGEN's stack.
 577
 578    Returns the newly accumulated variables and instructions as lists, as
 579    separate values."))
 580
 581 (export 'codegen-add-function)
 582 (defgeneric codegen-add-function (codegen function)
 583   (:documentation
 584    "Adds a function to CODEGEN's list.
 585
 586    Actually, we're not picky: FUNCTION can be any kind of object that you're
 587    willing to find in the list returned by `codegen-functions'."))
 588
 589 (export 'temporary-var)
 590 (defgeneric temporary-var (codegen type)
 591   (:documentation
 592    "Return the name of a temporary variable.
 593
 594    The temporary variable will have the given TYPE, and will be marked
 595    in-use.  You should clear the in-use flag explicitly when you've finished
 596    with the variable -- or, better, use `with-temporary-var' to do the
 597    cleanup automatically."))
 598
 599 (export 'codegen-build-function)
 600 (defun codegen-build-function
 601     (codegen name type vars insts &optional banner &rest banner-args)
 602   "Build a function and add it to CODEGEN's list.
 603
 604    Returns the function's name."
 605   (codegen-add-function codegen
 606                         (apply #'make-function-inst name type
 607                                (make-block-inst vars insts)
 608                                banner banner-args))
 609   name)
 610
 611 (export 'codegen-pop-block)
 612 (defgeneric codegen-pop-block (codegen)
 613   (:documentation
 614    "Makes a block (`block-inst') out of the completed code in CODEGEN.")
 615   (:method (codegen)
 616     (multiple-value-bind (vars insts) (codegen-pop codegen)
 617       (make-block-inst vars insts))))
 618
 619 (export 'codegen-pop-function)
 620 (defgeneric codegen-pop-function
 621     (codegen name type &optional banner &rest banner-args)
 622   (:documentation
 623    "Makes a function out of the completed code in CODEGEN.
 624
 625    The NAME can be any object you like.  The TYPE should be a function type
 626    object which includes argument names.  The return value is the NAME.")
 627   (:method (codegen name type &optional banner &rest banner-args)
 628     (multiple-value-bind (vars insts) (codegen-pop codegen)
 629       (apply #'codegen-build-function codegen name type vars insts
 630              banner banner-args))))
 631
 632 (export 'with-temporary-var)
 633 (defmacro with-temporary-var ((codegen var type) &body body)
 634   "Evaluate BODY with VAR bound to a temporary variable name.
 635
 636    During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
 637    available for re-use."
 638   (multiple-value-bind (doc decls body) (parse-body body :docp nil)
 639     (declare (ignore doc))
 640     `(let ((,var (temporary-var ,codegen ,type)))
 641        ,@decls
 642        (unwind-protect
 643             (progn ,@body)
 644          (setf (var-in-use-p ,var) nil)))))
 645
 646 ;;;--------------------------------------------------------------------------
 647 ;;; Code generation idioms.
 648
 649 (export 'deliver-expr)
 650 (defun deliver-expr (codegen target expr)
 651   "Emit code to deliver the value of EXPR to the TARGET.
 652
 653    The TARGET may be one of the following.
 654
 655      * `:void', indicating that the value is to be discarded.  The expression
 656        will still be evaluated.
 657
 658      * `:void-return', indicating that the value is to be discarded (as for
 659        `:void') and furthermore a `return' from the current function should
 660        be forced after computing the value.
 661
 662      * `:return', indicating that the value is to be returned from the
 663        current function.
 664
 665      * A variable name, indicating that the value is to be stored in the
 666        variable.
 667
 668    In the cases of `:return', `:void' and `:void-return' targets, it is valid
 669    for EXPR to be nil; this signifies that no computation needs to be
 670    performed.  Variable-name targets require an expression."
 671
 672   (case target
 673     (:return (emit-inst codegen (make-return-inst expr)))
 674     (:void (when expr (emit-inst codegen (make-expr-inst expr))))
 675     (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
 676                   (emit-inst codegen (make-return-inst nil)))
 677     (t (emit-inst codegen (make-set-inst target expr)))))
 678
 679 (export 'convert-stmts)
 680 (defun convert-stmts (codegen target type func)
 681   "Invoke FUNC to deliver a value to a non-`:return' target.
 682
 683    FUNC is a function which accepts a single argument, a non-`:return'
 684    target, and generates statements which deliver a value (see
 685    `deliver-expr') of the specified TYPE to this target.  In general, the
 686    generated code will have the form
 687
 688      setup instructions...
 689      (deliver-expr CODEGEN TARGET (compute value...))
 690      cleanup instructions...
 691
 692    where the cleanup instructions are essential to the proper working of the
 693    generated program.
 694
 695    The `convert-stmts' function will call FUNC to generate code, and arrange
 696    that its value is correctly delivered to TARGET, regardless of what the
 697    TARGET is -- i.e., it lifts the restriction to non-`:return' targets.  It
 698    does this by inventing a new temporary variable."
 699
 700   (case target
 701     (:return (with-temporary-var (codegen var type)
 702                (funcall func var)
 703                (deliver-expr codegen target var)))
 704     (:void-return (funcall func :void)
 705                   (emit-inst codegen (make-return-inst nil)))
 706     (t (funcall func target))))
 707
 708 (export 'deliver-call)
 709 (defun deliver-call (codegen target func &rest args)
 710   "Emit a statement to call FUNC with ARGS and deliver the result to TARGET."
 711   (deliver-expr codegen target (apply #'make-call-inst func args)))
 712
 713 ;;;----- That's all, folks --------------------------------------------------