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 (definst cond (stream :export t) (#1=#:cond conseq alt)
 251   (format stream "~@<~A ~2I~@_~@<? ~A ~_: ~A~:>~:>" #1# conseq alt))
 252
 253 ;; Simple statements.
 254 (definst return (stream :export t) (#1=#:expr)
 255   (format stream "return~@[ (~A)~];" #1#))
 256 (definst break (stream :export t) ()
 257   (format stream "break;"))
 258 (definst continue (stream :export t) ()
 259   (format stream "continue;"))
 260
 261 ;; Compound statements.
 262
 263 (defvar *first-statement-p* t
 264   "True if this is the first statement in a block.
 265
 266    This is used to communicate between `block-inst' and `banner-inst' so that
 267    they get the formatting right between them.")
 268
 269 (definst banner (stream :export t) (control &rest args)
 270   (pprint-logical-block (stream nil)
 271     (unless *first-statement-p* (pprint-newline :mandatory stream))
 272     (apply #'format-banner-comment stream control args)))
 273
 274 (export 'emit-banner)
 275 (defun emit-banner (codegen control &rest args)
 276   (emit-inst codegen (apply #'make-banner-inst control args)))
 277
 278 (definst block (stream :export t) (decls body)
 279   (write-char #\{ stream)
 280   (pprint-newline :mandatory stream)
 281   (pprint-logical-block (stream nil)
 282     (let ((newlinep nil))
 283       (flet ((newline ()
 284                (if newlinep
 285                    (pprint-newline :mandatory stream)
 286                    (setf newlinep t))))
 287         (pprint-indent :block 2 stream)
 288         (write-string "  " stream)
 289         (when decls
 290           (dolist (decl decls)
 291             (newline)
 292             (write decl :stream stream))
 293           (when body (newline)))
 294         (let ((*first-statement-p* t))
 295           (dolist (inst body)
 296             (newline)
 297             (write inst :stream stream)
 298             (setf *first-statement-p* nil))))))
 299   (pprint-newline :mandatory stream)
 300   (write-char #\} stream))
 301
 302 (definst if (stream :export t) (#1=#:cond conseq &optional alt)
 303   (let ((stmt "if"))
 304     (loop (format-compound-statement (stream conseq (if alt t nil))
 305             (format stream "~A (~A)" stmt #1#))
 306           (typecase alt
 307             (null (return))
 308             (if-inst (setf stmt "else if"
 309                            #1# (inst-cond alt)
 310                            conseq (inst-conseq alt)
 311                            alt (inst-alt alt)))
 312             (t (format-compound-statement (stream alt)
 313                  (format stream "else"))
 314                (return))))))
 315
 316 (definst while (stream :export t) (#1=#:cond body)
 317   (format-compound-statement (stream body)
 318     (format stream "while (~A)" #1#)))
 319
 320 (definst do-while (stream :export t) (body #1=#:cond)
 321   (format-compound-statement (stream body :space)
 322     (write-string "do" stream))
 323   (format stream "while (~A);" #1#))
 324
 325 (definst for (stream :export t) (init #1=#:cond update body)
 326   (format-compound-statement (stream body)
 327     (format stream "for (~@<~@[~A~];~@[ ~_~A~];~@[ ~_~A~]~:>)"
 328             init #1# update)))
 329
 330 ;;;--------------------------------------------------------------------------
 331 ;;; Code generation.
 332
 333 ;; Accessors.
 334
 335 (export 'codegen-functions)
 336 (defgeneric codegen-functions (codegen)
 337   (:documentation
 338    "Return the list of `function-inst's of completed functions."))
 339
 340 (export 'ensure-var)
 341 (defgeneric ensure-var (codegen name type &optional init)
 342   (:documentation
 343    "Add a variable to CODEGEN's list.
 344
 345    The variable is called NAME (which should be comparable using `equal' and
 346    print to an identifier) and has the given TYPE.  If INIT is present and
 347    non-nil it is an expression `inst' used to provide the variable with an
 348    initial value."))
 349
 350 (export '(emit-inst emit-insts))
 351 (defgeneric emit-inst (codegen inst)
 352   (:documentation
 353    "Add INST to the end of CODEGEN's list of instructions."))
 354 (defgeneric emit-insts (codegen insts)
 355   (:documentation
 356    "Add a list of INSTS to the end of CODEGEN's list of instructions.")
 357   (:method (codegen insts)
 358     (dolist (inst insts) (emit-inst codegen inst))))
 359
 360 (export '(emit-decl emit-decls))
 361 (defgeneric emit-decl (codegen inst)
 362   (:documentation
 363    "Add INST to the end of CODEGEN's list of declarations."))
 364 (defgeneric emit-decls (codegen insts)
 365   (:documentation
 366    "Add a list of INSTS to the end of CODEGEN's list of declarations."))
 367
 368 (export 'codegen-push)
 369 (defgeneric codegen-push (codegen)
 370   (:documentation
 371    "Pushes the current code generation state onto a stack.
 372
 373    The state consists of the accumulated variables and instructions."))
 374
 375 (export 'codegen-pop)
 376 (defgeneric codegen-pop (codegen)
 377   (:documentation
 378    "Pops a saved state off of the CODEGEN's stack.
 379
 380    Returns the newly accumulated variables and instructions as lists, as
 381    separate values."))
 382
 383 (export 'codegen-add-function)
 384 (defgeneric codegen-add-function (codegen function)
 385   (:documentation
 386    "Adds a function to CODEGEN's list.
 387
 388    Actually, we're not picky: FUNCTION can be any kind of object that you're
 389    willing to find in the list returned by `codegen-functions'."))
 390
 391 (export 'temporary-var)
 392 (defgeneric temporary-var (codegen type)
 393   (:documentation
 394    "Return the name of a temporary variable.
 395
 396    The temporary variable will have the given TYPE, and will be marked
 397    in-use.  You should clear the in-use flag explicitly when you've finished
 398    with the variable -- or, better, use `with-temporary-var' to do the
 399    cleanup automatically."))
 400
 401 (export 'codegen-build-function)
 402 (defun codegen-build-function
 403     (codegen name type vars insts &optional banner &rest banner-args)
 404   "Build a function and add it to CODEGEN's list.
 405
 406    Returns the function's name."
 407   (codegen-add-function codegen
 408                         (apply #'make-function-inst name type
 409                                (make-block-inst vars insts)
 410                                banner banner-args))
 411   name)
 412
 413 (export 'codegen-pop-block)
 414 (defgeneric codegen-pop-block (codegen)
 415   (:documentation
 416    "Makes a block (`block-inst') out of the completed code in CODEGEN.")
 417   (:method (codegen)
 418     (multiple-value-bind (vars insts) (codegen-pop codegen)
 419       (make-block-inst vars insts))))
 420
 421 (export 'codegen-pop-function)
 422 (defgeneric codegen-pop-function
 423     (codegen name type &optional banner &rest banner-args)
 424   (:documentation
 425    "Makes a function out of the completed code in CODEGEN.
 426
 427    The NAME can be any object you like.  The TYPE should be a function type
 428    object which includes argument names.  The return value is the NAME.")
 429   (:method (codegen name type &optional banner &rest banner-args)
 430     (multiple-value-bind (vars insts) (codegen-pop codegen)
 431       (apply #'codegen-build-function codegen name type vars insts
 432              banner banner-args))))
 433
 434 (export 'with-temporary-var)
 435 (defmacro with-temporary-var ((codegen var type) &body body)
 436   "Evaluate BODY with VAR bound to a temporary variable name.
 437
 438    During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
 439    available for re-use."
 440   (multiple-value-bind (doc decls body) (parse-body body :docp nil)
 441     (declare (ignore doc))
 442     `(let ((,var (temporary-var ,codegen ,type)))
 443        ,@decls
 444        (unwind-protect
 445             (progn ,@body)
 446          (setf (var-in-use-p ,var) nil)))))
 447
 448 ;;;--------------------------------------------------------------------------
 449 ;;; Code generation idioms.
 450
 451 (export 'deliver-expr)
 452 (defun deliver-expr (codegen target expr)
 453   "Emit code to deliver the value of EXPR to the TARGET.
 454
 455    The TARGET may be one of the following.
 456
 457      * `:void', indicating that the value is to be discarded.  The expression
 458        will still be evaluated.
 459
 460      * `:void-return', indicating that the value is to be discarded (as for
 461        `:void') and furthermore a `return' from the current function should
 462        be forced after computing the value.
 463
 464      * `:return', indicating that the value is to be returned from the
 465        current function.
 466
 467      * A variable name, indicating that the value is to be stored in the
 468        variable.
 469
 470    In the cases of `:return', `:void' and `:void-return' targets, it is valid
 471    for EXPR to be nil; this signifies that no computation needs to be
 472    performed.  Variable-name targets require an expression."
 473
 474   (case target
 475     (:return (emit-inst codegen (make-return-inst expr)))
 476     (:void (when expr (emit-inst codegen (make-expr-inst expr))))
 477     (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
 478                   (emit-inst codegen (make-return-inst nil)))
 479     (t (emit-inst codegen (make-set-inst target expr)))))
 480
 481 (export 'convert-stmts)
 482 (defun convert-stmts (codegen target type func)
 483   "Invoke FUNC to deliver a value to a non-`:return' target.
 484
 485    FUNC is a function which accepts a single argument, a non-`:return'
 486    target, and generates statements which deliver a value (see
 487    `deliver-expr') of the specified TYPE to this target.  In general, the
 488    generated code will have the form
 489
 490      setup instructions...
 491      (deliver-expr CODEGEN TARGET (compute value...))
 492      cleanup instructions...
 493
 494    where the cleanup instructions are essential to the proper working of the
 495    generated program.
 496
 497    The `convert-stmts' function will call FUNC to generate code, and arrange
 498    that its value is correctly delivered to TARGET, regardless of what the
 499    TARGET is -- i.e., it lifts the restriction to non-`:return' targets.  It
 500    does this by inventing a new temporary variable."
 501
 502   (case target
 503     (:return (with-temporary-var (codegen var type)
 504                (funcall func var)
 505                (deliver-expr codegen target var)))
 506     (:void-return (funcall func :void)
 507                   (emit-inst codegen (make-return-inst nil)))
 508     (t (funcall func target))))
 509
 510 (export 'deliver-call)
 511 (defun deliver-call (codegen target func &rest args)
 512   "Emit a statement to call FUNC with ARGS and deliver the result to TARGET."
 513   (deliver-expr codegen target (apply #'make-call-inst func args)))
 514
 515 ;;;----- That's all, folks --------------------------------------------------