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