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