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
  70 (export '*null-pointer*)
  71 (defparameter *null-pointer* "NULL")
  72
  73 ;;;--------------------------------------------------------------------------
  74 ;;; Instructions.
  75
  76 ;; Classes.
  77
  78 (export 'inst)
  79 (defclass inst () ()
  80   (:documentation
  81    "A base class for instructions.
  82
  83    An `instruction' is anything which might be useful to string into a code
  84    generator.  Both statements and expressions can be represented by trees of
  85    instructions.  The `definst' macro is a convenient way of defining new
  86    instructions.
  87
  88    The only important protocol for instructions is output, which is achieved
  89    by calling `print-object' with `*print-escape*' nil.
  90
  91    This doesn't really do very much, but it acts as a handy marker for
  92    instruction subclasses."))
  93
  94 (export 'inst-metric)
  95 (defgeneric inst-metric (inst)
  96   (:documentation
  97    "Returns a `metric' describing how complicated INST is.
  98
  99    The default metric of an inst node is simply 1; `inst' subclasses
 100    generated by `definst' (q.v.) have an automatically generated method which
 101    returns one plus the sum of the metrics of the node's children.
 102
 103    This isn't intended to be a particularly rigorous definition.  Its purpose
 104    is to allow code generators to make decisions about inlining or calling
 105    code fairly simply.")
 106   (:method ((inst t))
 107     (declare (ignore inst))
 108     1)
 109   (:method ((inst null))
 110     (declare (ignore inst))
 111     1)
 112   (:method ((inst list))
 113     (reduce #'+ inst :key #'inst-metric)))
 114
 115 ;; Instruction definition.
 116
 117 (export 'definst)
 118 (defmacro definst (code (streamvar &key export) args &body body)
 119   "Define an instruction type and describe how to output it.
 120
 121    An `inst' can represent any structured piece of output syntax: a
 122    statement, expression or declaration, for example.  This macro defines the
 123    following things:
 124
 125      * A class `CODE-inst' to represent the instruction.
 126
 127      * Instance slots named after the ARGS, with matching keyword initargs,
 128        and `inst-ARG' readers.
 129
 130      * A constructor `make-CODE-inst' which accepts the ARGS (as an ordinary
 131        BVL) as arguments and returns a fresh instance.
 132
 133      * A print method, which prints a diagnostic dump if `*print-escape*' is
 134        set, or invokes the BODY (with STREAMVAR bound to the output stream)
 135        otherwise.  The BODY is expected to produce target code at this
 136        point.
 137
 138    If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
 139    symbols."
 140
 141   (let* ((inst-var (gensym "INST"))
 142          (class-name (symbolicate code '-inst))
 143          (constructor-name (symbolicate 'make- code '-inst))
 144          (slots (mapcan (lambda (arg)
 145                           (if (listp arg) (list (car arg))
 146                               (let ((name (symbol-name arg)))
 147                                 (if (and (plusp (length name))
 148                                          (char/= (char name 0) #\&))
 149                                     (list arg)
 150                                     nil))))
 151                         args))
 152          (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
 153                        slots)))
 154     `(progn
 155        (defclass ,class-name (inst)
 156          ,(mapcar (lambda (slot key)
 157                     `(,slot :initarg ,key
 158                             :reader ,(symbolicate 'inst- slot)))
 159                   slots keys))
 160        (defun ,constructor-name (,@args)
 161          (make-instance ',class-name ,@(mappend #'list keys slots)))
 162        (defmethod inst-metric ((,inst-var ,class-name))
 163          (with-slots (,@slots) ,inst-var
 164            (+ 1 ,@(mapcar (lambda (slot) `(inst-metric ,slot)) slots))))
 165        (defmethod print-object ((,inst-var ,class-name) ,streamvar)
 166          (with-slots (,@slots) ,inst-var
 167            (if *print-escape*
 168                (print-unreadable-object (,inst-var ,streamvar :type t)
 169                  (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
 170                          ,@(mappend #'list keys slots)))
 171                (block ,code ,@body))))
 172        ,@(and export `((export '(,class-name ,constructor-name
 173                                  ,@(mapcar (lambda (slot)
 174                                              (symbolicate 'inst- slot))
 175                                            slots)))))
 176        ',code)))
 177
 178 ;; Formatting utilities.
 179
 180 (defun format-compound-statement* (stream child morep thunk)
 181   "Underlying function for `format-compound-statement'."
 182   (cond ((typep child 'block-inst)
 183          (funcall thunk stream)
 184          (write-char #\space stream)
 185          (princ child stream)
 186          (when morep (write-char #\space stream)))
 187         (t
 188          (pprint-logical-block (stream nil)
 189            (funcall thunk stream)
 190            (write-char #\space stream)
 191            (pprint-indent :block 2 stream)
 192            (pprint-newline :linear stream)
 193            (princ child stream)
 194            (pprint-indent :block 0 stream)
 195            (case morep
 196              (:space
 197               (write-char #\space stream)
 198               (pprint-newline :linear stream))
 199              ((t)
 200               (pprint-newline :mandatory stream)))))))
 201
 202 (export 'format-compound-statement)
 203 (defmacro format-compound-statement
 204     ((stream child &optional morep) &body body)
 205   "Format a compound statement to STREAM.
 206
 207    The introductory material is printed by BODY.  The CHILD is formatted
 208    properly according to whether it's a `block-inst'.  If MOREP is true, then
 209    allow for more stuff following the child."
 210   `(format-compound-statement* ,stream ,child ,morep
 211                                (lambda (,stream) ,@body)))
 212
 213 (export 'format-banner-comment)
 214 (defun format-banner-comment (stream control &rest args)
 215   (format stream "~@</~@<* ~@;~?~:>~_ */~:>" control args))
 216
 217 ;; Important instruction classes.
 218
 219 ;; HACK: Some of the slot names we'd like to use are external symbols in our
 220 ;; package or the `common-lisp' package.  Use gensyms for these slot names to
 221 ;; prevent them from leaking.
 222
 223 (definst var (stream :export t) (name #1=#:type &optional init)
 224   (pprint-c-type #1# stream name)
 225   (when init
 226     (format stream " = ~A" init))
 227   (write-char #\; stream))
 228
 229 (definst function (stream :export t)
 230     (name #1=#:type body &optional #2=#:banner &rest banner-args)
 231   (pprint-logical-block (stream nil)
 232     (when #2#
 233       (apply #'format-banner-comment stream #2# banner-args)
 234       (pprint-newline :mandatory stream))
 235     (princ "static " stream)
 236     (pprint-c-type #1# stream name)
 237     (format stream "~:@_~A~:@_~:@_" body)))
 238
 239 ;; Expression statements.
 240 (definst expr (stream :export t) (#1=#:expr)
 241   (format stream "~A;" #1#))
 242 (definst set (stream :export t) (var #1=#:expr)
 243   (format stream "~@<~A = ~@_~2I~A;~:>" var #1#))
 244 (definst update (stream :export t) (var op #1=#:expr)
 245   (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op #1#))
 246
 247 ;; Special kinds of expressions.
 248 (definst call (stream :export t) (#1=#:func &rest args)
 249   (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args))
 250
 251 ;; Simple statements.
 252 (definst return (stream :export t) (#1=#:expr)
 253   (format stream "return~@[ (~A)~];" #1#))
 254 (definst break (stream :export t) ()
 255   (format stream "break;"))
 256 (definst continue (stream :export t) ()
 257   (format stream "continue;"))
 258
 259 ;; Compound statements.
 260
 261 (defvar *first-statement-p* t
 262   "True if this is the first statement in a block.
 263
 264    This is used to communicate between `block-inst' and `banner-inst' so that
 265    they get the formatting right between them.")
 266
 267 (definst banner (stream :export t) (control &rest args)
 268   (pprint-logical-block (stream nil)
 269     (unless *first-statement-p* (pprint-newline :mandatory stream))
 270     (apply #'format-banner-comment stream control args)))
 271
 272 (export 'emit-banner)
 273 (defun emit-banner (codegen control &rest args)
 274   (emit-inst codegen (apply #'make-banner-inst control args)))
 275
 276 (definst block (stream :export t) (decls body)
 277   (write-char #\{ stream)
 278   (pprint-newline :mandatory stream)
 279   (pprint-logical-block (stream nil)
 280     (let ((newlinep nil))
 281       (flet ((newline ()
 282                (if newlinep
 283                    (pprint-newline :mandatory stream)
 284                    (setf newlinep t))))
 285         (pprint-indent :block 2 stream)
 286         (write-string "  " stream)
 287         (when decls
 288           (dolist (decl decls)
 289             (newline)
 290             (write decl :stream stream))
 291           (when body (newline)))
 292         (let ((*first-statement-p* t))
 293           (dolist (inst body)
 294             (newline)
 295             (write inst :stream stream)
 296             (setf *first-statement-p* nil))))))
 297   (pprint-newline :mandatory stream)
 298   (write-char #\} stream))
 299
 300 (definst if (stream :export t) (#1=#:cond conseq &optional alt)
 301   (let ((stmt "if"))
 302     (loop (format-compound-statement (stream conseq (if alt t nil))
 303             (format stream "~A (~A)" stmt #1#))
 304           (typecase alt
 305             (null (return))
 306             (if-inst (setf stmt "else if"
 307                            #1# (inst-cond alt)
 308                            conseq (inst-conseq alt)
 309                            alt (inst-alt alt)))
 310             (t (format-compound-statement (stream alt)
 311                  (format stream "else"))
 312                (return))))))
 313
 314 (definst while (stream :export t) (#1=#:cond body)
 315   (format-compound-statement (stream body)
 316     (format stream "while (~A)" #1#)))
 317
 318 (definst do-while (stream :export t) (body #1=#:cond)
 319   (format-compound-statement (stream body :space)
 320     (write-string "do" stream))
 321   (format stream "while (~A);" #1#))
 322
 323 ;;;--------------------------------------------------------------------------
 324 ;;; Code generation.
 325
 326 ;; Accessors.
 327
 328 (export 'codegen-functions)
 329 (defgeneric codegen-functions (codegen)
 330   (:documentation
 331    "Return the list of `function-inst's of completed functions."))
 332
 333 (export 'ensure-var)
 334 (defgeneric ensure-var (codegen name type &optional init)
 335   (:documentation
 336    "Add a variable to CODEGEN's list.
 337
 338    The variable is called NAME (which should be comparable using `equal' and
 339    print to an identifier) and has the given TYPE.  If INIT is present and
 340    non-nil it is an expression `inst' used to provide the variable with an
 341    initial value."))
 342
 343 (export '(emit-inst emit-insts))
 344 (defgeneric emit-inst (codegen inst)
 345   (:documentation
 346    "Add INST to the end of CODEGEN's list of instructions."))
 347 (defgeneric emit-insts (codegen insts)
 348   (:documentation
 349    "Add a list of INSTS to the end of CODEGEN's list of instructions.")
 350   (:method (codegen insts)
 351     (dolist (inst insts) (emit-inst codegen inst))))
 352
 353 (export '(emit-decl emit-decls))
 354 (defgeneric emit-decl (codegen inst)
 355   (:documentation
 356    "Add INST to the end of CODEGEN's list of declarations."))
 357 (defgeneric emit-decls (codegen insts)
 358   (:documentation
 359    "Add a list of INSTS to the end of CODEGEN's list of declarations."))
 360
 361 (export 'codegen-push)
 362 (defgeneric codegen-push (codegen)
 363   (:documentation
 364    "Pushes the current code generation state onto a stack.
 365
 366    The state consists of the accumulated variables and instructions."))
 367
 368 (export 'codegen-pop)
 369 (defgeneric codegen-pop (codegen)
 370   (:documentation
 371    "Pops a saved state off of the CODEGEN's stack.
 372
 373    Returns the newly accumulated variables and instructions as lists, as
 374    separate values."))
 375
 376 (export 'codegen-add-function)
 377 (defgeneric codegen-add-function (codegen function)
 378   (:documentation
 379    "Adds a function to CODEGEN's list.
 380
 381    Actually, we're not picky: FUNCTION can be any kind of object that you're
 382    willing to find in the list returned by `codegen-functions'."))
 383
 384 (export 'temporary-var)
 385 (defgeneric temporary-var (codegen type)
 386   (:documentation
 387    "Return the name of a temporary variable.
 388
 389    The temporary variable will have the given TYPE, and will be marked
 390    in-use.  You should clear the in-use flag explicitly when you've finished
 391    with the variable -- or, better, use `with-temporary-var' to do the
 392    cleanup automatically."))
 393
 394 (export 'codegen-build-function)
 395 (defun codegen-build-function
 396     (codegen name type vars insts &optional banner &rest banner-args)
 397   "Build a function and add it to CODEGEN's list.
 398
 399    Returns the function's name."
 400   (codegen-add-function codegen
 401                         (apply #'make-function-inst name type
 402                                (make-block-inst vars insts)
 403                                banner banner-args))
 404   name)
 405
 406 (export 'codegen-pop-block)
 407 (defgeneric codegen-pop-block (codegen)
 408   (:documentation
 409    "Makes a block (`block-inst') out of the completed code in CODEGEN.")
 410   (:method (codegen)
 411     (multiple-value-bind (vars insts) (codegen-pop codegen)
 412       (make-block-inst vars insts))))
 413
 414 (export 'codegen-pop-function)
 415 (defgeneric codegen-pop-function
 416     (codegen name type &optional banner &rest banner-args)
 417   (:documentation
 418    "Makes a function out of the completed code in CODEGEN.
 419
 420    The NAME can be any object you like.  The TYPE should be a function type
 421    object which includes argument names.  The return value is the NAME.")
 422   (:method (codegen name type &optional banner &rest banner-args)
 423     (multiple-value-bind (vars insts) (codegen-pop codegen)
 424       (apply #'codegen-build-function codegen name type vars insts
 425              banner banner-args))))
 426
 427 (export 'with-temporary-var)
 428 (defmacro with-temporary-var ((codegen var type) &body body)
 429   "Evaluate BODY with VAR bound to a temporary variable name.
 430
 431    During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
 432    available for re-use."
 433   (multiple-value-bind (doc decls body) (parse-body body :docp nil)
 434     (declare (ignore doc))
 435     `(let ((,var (temporary-var ,codegen ,type)))
 436        ,@decls
 437        (unwind-protect
 438             (progn ,@body)
 439          (setf (var-in-use-p ,var) nil)))))
 440
 441 ;;;--------------------------------------------------------------------------
 442 ;;; Code generation idioms.
 443
 444 (export 'deliver-expr)
 445 (defun deliver-expr (codegen target expr)
 446   "Emit code to deliver the value of EXPR to the TARGET.
 447
 448    The TARGET may be one of the following.
 449
 450      * `:void', indicating that the value is to be discarded.  The expression
 451        will still be evaluated.
 452
 453      * `:void-return', indicating that the value is to be discarded (as for
 454        `:void') and furthermore a `return' from the current function should
 455        be forced after computing the value.
 456
 457      * `:return', indicating that the value is to be returned from the
 458        current function.
 459
 460      * A variable name, indicating that the value is to be stored in the
 461        variable.
 462
 463    In the cases of `:return', `:void' and `:void-return' targets, it is valid
 464    for EXPR to be nil; this signifies that no computation needs to be
 465    performed.  Variable-name targets require an expression."
 466
 467   (case target
 468     (:return (emit-inst codegen (make-return-inst expr)))
 469     (:void (when expr (emit-inst codegen (make-expr-inst expr))))
 470     (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
 471                   (emit-inst codegen (make-return-inst nil)))
 472     (t (emit-inst codegen (make-set-inst target expr)))))
 473
 474 (export 'convert-stmts)
 475 (defun convert-stmts (codegen target type func)
 476   "Invoke FUNC to deliver a value to a non-`:return' target.
 477
 478    FUNC is a function which accepts a single argument, a non-`:return'
 479    target, and generates statements which deliver a value (see
 480    `deliver-expr') of the specified TYPE to this target.  In general, the
 481    generated code will have the form
 482
 483      setup instructions...
 484      (deliver-expr CODEGEN TARGET (compute value...))
 485      cleanup instructions...
 486
 487    where the cleanup instructions are essential to the proper working of the
 488    generated program.
 489
 490    The `convert-stmts' function will call FUNC to generate code, and arrange
 491    that its value is correctly delivered to TARGET, regardless of what the
 492    TARGET is -- i.e., it lifts the restriction to non-`:return' targets.  It
 493    does this by inventing a new temporary variable."
 494
 495   (case target
 496     (:return (with-temporary-var (codegen var type)
 497                (funcall func var)
 498                (deliver-expr codegen target var)))
 499     (:void-return (funcall func :void)
 500                   (emit-inst codegen (make-return-inst nil)))
 501     (t (funcall func target))))
 502
 503 (export 'deliver-call)
 504 (defun deliver-call (codegen target func &rest args)
 505   "Emit a statement to call FUNC with ARGS and deliver the result to TARGET."
 506   (deliver-expr codegen target (apply #'make-call-inst func args)))
 507
 508 ;;;----- That's all, folks --------------------------------------------------