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