chiark - git - mdw - sod/blob - codegen.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Code generator for effective methods
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  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 (defclass temporary-name ()
  32   ((tag :initarg :tag :reader temp-tag))
  33   (:documentation
  34    "Base class for temporary variable and argument names."))
  35
  36 (defclass temporary-argument (temporary-name) ())
  37 (defclass temporary-function (temporary-name) ())
  38
  39 (defclass temporary-variable (temporary-name)
  40   ((in-use-p :initarg :in-use-p :initform nil
  41              :type boolean :accessor var-in-use-p)))
  42
  43 (defmethod var-in-use-p ((var t))
  44   "Non-temporary variables are always in use."
  45   t)
  46
  47 (defmethod commentify-argument-name ((name temporary-name))
  48   nil)
  49
  50 (defparameter *temporary-index* 0
  51   "Index for temporary name generation.
  52
  53    This is automatically reset to zero before the output functions are
  54    invoked to write a file.  This way, we can ensure that the same output
  55    file is always produced from the same input.")
  56
  57 (defun temporary-function ()
  58   "Return a temporary function name."
  59   (make-instance 'temporary-function
  60                  :tag (prog1 *temporary-index* (incf *temporary-index*))))
  61
  62 (defgeneric format-temporary-name (var stream)
  63   (:method ((var temporary-name) stream)
  64     (format stream "~A" (temp-tag var)))
  65   (:method ((var temporary-argument) stream)
  66     (format stream "sod__a~A" (temp-tag var)))
  67   (:method ((var temporary-variable) stream)
  68     (format stream "sod__v~A" (temp-tag var)))
  69   (:method ((var temporary-function) stream)
  70     (format stream "sod__f~A" (temp-tag var))))
  71
  72 (defmethod print-object ((var temporary-name) stream)
  73   (if *print-escape*
  74       (print-unreadable-object (var stream :type t)
  75         (prin1 (temp-tag var) stream))
  76       (format-temporary-name var stream)))
  77
  78 (defparameter *sod-ap*
  79   (make-instance 'temporary-name :tag "sod__ap"))
  80 (defparameter *sod-master-ap*
  81   (make-instance 'temporary-name :tag "sod__master_ap"))
  82
  83 ;;;--------------------------------------------------------------------------
  84 ;;; Instructions.
  85
  86 (defclass inst () ()
  87   (:documentation
  88    "A base class for instructions.
  89
  90    An `instruction' is anything which might be useful to string into a code
  91    generator.  Both statements and expressions map can be represented by
  92    trees of instructions.  The DEFINST macro is a convenient way of defining
  93    new instructions.
  94
  95    The only important protocol for instructions is output, which is achieved
  96    by calling PRINT-OBJECT with *PRINT-ESCAPE* nil.
  97
  98    This doesn't really do very much, but it acts as a handy marker for
  99    instruction subclasses."))
 100
 101 (defgeneric inst-metric (inst)
 102   (:documentation
 103    "Returns a `metric' describing how complicated INST is.
 104
 105    The default metric of an inst node is simply 1; INST subclasses generated
 106    by DEFINST (q.v.) have an automatically generated method which returns one
 107    plus the sum of the metrics of the node's children.
 108
 109    This isn't intended to be a particularly rigorous definition.  Its purpose
 110    is to allow code generators to make decisions about inlining or calling
 111    code fairly simply.")
 112   (:method (inst) 1))
 113
 114 (defmacro definst (code (streamvar) args &body body)
 115   "Define an instruction type and describe how to output it.
 116
 117    An INST can represent any structured piece of output syntax: a statement,
 118    expression or declaration, for example.  This macro defines the following
 119    things:
 120
 121      * A class CODE-INST to represent the instruction.
 122
 123      * Instance slots named after the ARGS, with matching keyword initargs,
 124        and INST-ARG readers.
 125
 126      * A constructor MAKE-CODE-INST which accepts the ARGS (in order, not
 127        with keywords) as arguments and returns a fresh instance.
 128
 129      * A print method, which prints a diagnostic dump if *PRINT-ESCAPE* is
 130        set, or invokes the BODY (with STREAMVAR bound to the output stream)
 131        otherwise.  The BODY is expected to produce target code at this
 132        point."
 133
 134   (let ((inst-var (gensym "INST"))
 135         (class-name (symbolicate code '-inst))
 136         (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
 137                       args)))
 138     `(progn
 139        (defclass ,class-name (inst)
 140          ,(mapcar (lambda (arg key)
 141                     `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg)))
 142                   args keys))
 143        (defun ,(symbolicate 'make- code '-inst) (,@args)
 144          (make-instance ',class-name ,@(mappend #'list keys args)))
 145        (defmethod inst-metric ((,inst-var ,class-name))
 146          (with-slots (,@args) ,inst-var
 147            (+ 1 ,@(mapcar (lambda (arg) `(inst-metric ,arg)) args))))
 148        (defmethod print-object ((,inst-var ,class-name) ,streamvar)
 149          (with-slots (,@args) ,inst-var
 150            (if *print-escape*
 151                (print-unreadable-object (,inst-var ,streamvar :type t)
 152                  (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
 153                          ,@(mappend #'list keys args)))
 154                (progn ,@body)))))))
 155
 156 (defun format-compound-statement* (stream child morep thunk)
 157   "Underlying function for FORMAT-COMPOUND-STATEMENT."
 158   (cond ((typep child 'block-inst)
 159          (funcall thunk stream)
 160          (write-char #\space stream)
 161          (princ child stream)
 162          (when morep (write-char #\space stream)))
 163         (t
 164          (pprint-logical-block (stream nil)
 165            (funcall thunk stream)
 166            (write-char #\space stream)
 167            (pprint-indent :block 2 stream)
 168            (pprint-newline :linear stream)
 169            (princ child stream)
 170            (pprint-indent :block 0 stream)
 171            (case morep
 172              (:space
 173               (write-char #\space stream)
 174               (pprint-newline :linear stream))
 175              (t
 176               (pprint-newline :mandatory stream)))))))
 177
 178 (defmacro format-compound-statement
 179     ((stream child &optional morep) &body body)
 180   "Format a compound statement to STREAM.
 181
 182    The introductory material is printed by BODY.  The CHILD is formatted
 183    properly according to whether it's a BLOCK-INST.  If MOREP is true, then
 184    allow for more stuff following the child."
 185   `(format-compound-statement* ,stream ,child ,morep
 186                                (lambda (,stream) ,@body)))
 187
 188 ;;;--------------------------------------------------------------------------
 189 ;;; Instruction types.
 190
 191 ;; Compound statements.
 192
 193 (definst block (stream) (decls body)
 194   (format stream "{~:@_~@<  ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
 195           decls body))
 196
 197 (definst if (stream) (condition consequent alternative)
 198   (format-compound-statement (stream consequent alternative)
 199     (format stream "if (~A)" condition))
 200   (when alternative
 201     (format-compound-statement (stream alternative)
 202       (write-string "else" stream))))
 203
 204 (definst while (stream) (condition body)
 205   (format-compound-statement (stream body)
 206     (format stream "while (~A)" condition)))
 207
 208 (definst do-while (stream) (body condition)
 209   (format-compound-statement (stream body :space)
 210     (write-string "do" stream))
 211   (format stream "while (~A);" condition))
 212
 213 ;; Simple statements.
 214
 215 (definst set (stream) (var expr)
 216   (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
 217
 218 (definst return (stream) (expr)
 219   (format stream "return~@[ (~A)~];" expr))
 220
 221 (definst expr (stream) (expr)
 222   (format stream "~A;" expr))
 223
 224 ;; Special varargs hacks.
 225
 226 (definst va-start (stream) (ap arg)
 227   (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
 228
 229 (definst va-copy (stream) (to from)
 230   (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
 231
 232 (definst va-end (stream) (ap)
 233   (format stream "va_end(~A);" ap))
 234
 235 ;; Declarations.  These should appear at the heads of BLOCK-INSTs.
 236
 237 (definst var (stream) (name type init)
 238   (pprint-c-type type stream name)
 239   (when init
 240     (format stream " = ~A" init)))
 241
 242 ;; Expressions.
 243
 244 (definst call (stream) (func args)
 245   (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
 246
 247 ;; Top level things.
 248
 249 (definst function (stream) (name type body)
 250   (pprint-logical-block (stream nil)
 251     (pprint-c-type type stream name)
 252     (format stream "~:@_~A~:@_~:@_" body)))
 253
 254 ;;;--------------------------------------------------------------------------
 255 ;;; Code generator objects.
 256
 257 (defclass basic-codegen ()
 258   ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
 259    (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
 260    (temp-index :initarg :temp-index :initform 0
 261                :type fixnum :accessor codegen-temp-index))
 262   (:documentation
 263    "Base class for code generator state.
 264
 265    This contains the bare essentials for supporting the EMIT-INST and
 266    ENSURE-VAR protocols; see the documentation for those generic functions
 267    for more details.
 268
 269    This class isn't abstract.  A full CODEGEN object uses instances of this
 270    to keep track of pending functions which haven't been completed yet.
 271
 272    Just in case that wasn't clear enough: this is nothing to do with the
 273    BASIC language."))
 274
 275 (defgeneric emit-inst (codegen inst)
 276   (:documentation
 277    "Add INST to the end of CODEGEN's list of instructions.")
 278   (:method ((codegen basic-codegen) inst)
 279     (push inst (codegen-insts codegen))))
 280
 281 (defgeneric emit-insts (codegen insts)
 282   (:documentation
 283    "Add a list of INSTS to the end of CODEGEN's list of instructions.")
 284   (:method ((codegen basic-codegen) insts)
 285     (setf (codegen-insts codegen)
 286           (revappend insts (codegen-insts codegen)))))
 287
 288 (defgeneric ensure-var (codegen name type &optional init)
 289   (:documentation
 290    "Add a variable to CODEGEN's list.
 291
 292    The variable is called NAME (which should be comparable using EQUAL and
 293    print to an identifier) and has the given TYPE.  If INIT is present and
 294    non-nil it is an expression INST used to provide the variable with an
 295    initial value.")
 296   (:method ((codegen basic-codegen) name type &optional init)
 297     (let* ((vars (codegen-vars codegen))
 298            (var (find name vars :key #'inst-name :test #'equal)))
 299       (cond ((not var)
 300              (setf (codegen-vars codegen)
 301                    (cons (make-var-inst name type init) vars)))
 302             ((not (c-type-equal-p type (inst-type var)))
 303              (error "(Internal) Redefining type for variable ~A." name)))
 304       name)))
 305
 306 (defclass codegen (basic-codegen)
 307   ((functions :initform nil :type list :accessor codegen-functions)
 308    (stack :initform nil :type list :accessor codegen-stack))
 309   (:documentation
 310    "A full-fat code generator which can generate and track functions.
 311
 312    This is the real deal.  Subclasses may which to attach additional state
 313    for convenience's sake, but this class is self-contained.  It supports the
 314    CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
 315
 316 (defgeneric codegen-push (codegen)
 317   (:documentation
 318    "Pushes the current code generation state onto a stack.
 319
 320    The state consists of the accumulated variables and instructions, i.e.,
 321    what is representable by a BASIC-CODEGEN.")
 322   (:method ((codegen codegen))
 323     (with-slots (vars insts temp-index stack) codegen
 324       (push (make-instance 'basic-codegen
 325                            :vars vars
 326                            :insts insts
 327                            :temp-index temp-index)
 328             stack)
 329       (setf vars nil insts nil temp-index 0))))
 330
 331 (defgeneric codegen-pop (codegen)
 332   (:documentation
 333    "Pops a saved state off of the CODEGEN's stack.
 334
 335    Returns the newly accumulated variables and instructions as lists, as
 336    separate values.")
 337   (:method ((codegen codegen))
 338     (with-slots (vars insts temp-index stack) codegen
 339       (multiple-value-prog1
 340           (values (nreverse vars) (nreverse insts))
 341         (let ((sub (pop stack)))
 342           (setf vars (codegen-vars sub)
 343                 insts (codegen-insts sub)
 344                 temp-index (codegen-temp-index sub)))))))
 345
 346 (defgeneric codegen-add-function (codegen function)
 347   (:documentation
 348    "Adds a function to CODEGEN's list.
 349
 350    Actually, we're not picky: FUNCTION can be any kind of object that you're
 351    willing to find in the list returned by CODEGEN-FUNCTIONS.")
 352   (:method ((codegen codegen) function)
 353     (with-slots (functions) codegen
 354       (setf functions (nconc functions (list function))))))
 355
 356 (defun codegen-build-function (codegen name type vars insts)
 357   "Build a function and add it to CODEGEN's list.
 358
 359    Returns the function's name."
 360   (codegen-add-function codegen
 361                         (make-function-inst name type
 362                                             (make-block-inst vars insts)))
 363   name)
 364
 365 (defgeneric codegen-pop-function (codegen name type)
 366   (:documentation
 367    "Makes a function out of the completed code in CODEGEN.
 368
 369    The NAME can be any object you like.  The TYPE should be a function type
 370    object which includes argument names.  The return value is the NAME.")
 371   (:method ((codegen codegen) name type)
 372     (multiple-value-bind (vars insts) (codegen-pop codegen)
 373       (codegen-build-function codegen name type vars insts))))
 374
 375 (defgeneric temporary-var (codegen type)
 376   (:documentation
 377    "Return the name of a temporary variable.
 378
 379    The temporary variable will have the given TYPE, and will be marked
 380    in-use.  You should clear the in-use flag explicitly when you've finished
 381    with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
 382    automatically."))
 383
 384 (defmethod temporary-var ((codegen basic-codegen) type)
 385   (with-slots (vars temp-index) codegen
 386     (or (find-if (lambda (var)
 387                    (and (not (var-in-use-p (inst-name var)))
 388                         (c-type-equal-p type (inst-type var))))
 389                  vars)
 390         (let* ((name (make-instance 'temporary-variable
 391                                     :tag (prog1 temp-index
 392                                            (incf temp-index)))))
 393           (push (make-var-inst name type nil) vars)
 394           name))))
 395
 396 (defmacro with-temporary-var ((codegen var type) &body body)
 397   "Evaluate BODY with VAR bound to a temporary variable name.
 398
 399    During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
 400   available for re-use."
 401   `(let ((,var (temporary-var ,codegen ,type)))
 402      (unwind-protect
 403           (progn ,@body)
 404        (setf (var-in-use-p ,var) nil))))
 405
 406 ;;;--------------------------------------------------------------------------
 407 ;;; Code generation idioms.
 408
 409 (defun deliver-expr (codegen target expr)
 410   "Emit code to deliver the value of EXPR to the TARGET.
 411
 412    The TARGET may be one of the following.
 413
 414      * :VOID, indicating that the value is to be discarded.  The expression
 415        will still be evaluated.
 416
 417      * :VOID-RETURN, indicating that the value is to be discarded (as for
 418        :VOID) and furthermore a `return' from the current function should be
 419        forced after computing the value.
 420
 421      * :RETURN, indicating that the value is to be returned from the current
 422        function.
 423
 424      * A variable name, indicating that the value is to be stored in the
 425        variable.
 426
 427    In the cases of :RETURN, :VOID and :VOID-RETURN targets, it is valid for
 428    EXPR to be nil; this signifies that no computation needs to be performed.
 429    Variable-name targets require an expression."
 430
 431   (case target
 432     (:return (emit-inst codegen (make-return-inst expr)))
 433     (:void (when expr (emit-inst codegen (make-expr-inst expr))))
 434     (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
 435                   (emit-inst codegen (make-return-inst nil)))
 436     (t (emit-inst codegen (make-set-inst target expr)))))
 437
 438 (defun convert-stmts (codegen target type func)
 439   "Invoke FUNC to deliver a value to a non-:RETURN target.
 440
 441    FUNC is a function which accepts a single argument, a non-:RETURN target,
 442    and generates statements which deliver a value (see DELIVER-EXPR) of the
 443    specified TYPE to this target.  In general, the generated code will have
 444    the form
 445
 446      setup instructions...
 447      (DELIVER-EXPR CODEGEN TARGET (compute value...))
 448      cleanup instructions...
 449
 450    where the cleanup instructions are essential to the proper working of the
 451    generated program.
 452
 453    CONVERT-STMTS will call FUNC to generate code, and arrange that its value
 454    is correctly delivered to TARGET, regardless of what the TARGET is --
 455    i.e., it lifts the restriction to non-:RETURN targets.  It does this by
 456    inventing a new temporary variable."
 457
 458   (case target
 459     (:return (with-temporary-var (codegen var type)
 460                (funcall func var)
 461                (deliver-expr codegen target var)))
 462     (:void-return (funcall func :void)
 463                   (emit-inst codegen (make-return-inst nil)))
 464     (t (funcall func target))))
 465
 466 ;;;----- That's all, folks --------------------------------------------------