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