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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Code generation protocol implementation
   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 (export '(temporary-argument temporary-function))
  32 (defclass temporary-argument (temporary-name) ())
  33 (defclass temporary-function (temporary-name) ())
  34
  35 (export 'temporary-variable)
  36 (defclass temporary-variable (temporary-name)
  37   ((in-use-p :initarg :in-use-p :initform nil
  38              :type boolean :accessor var-in-use-p)))
  39
  40 (define-module-var *temporary-index* 0
  41   "Index for temporary name generation.
  42
  43    This is automatically reset to zero before the output functions are
  44    invoked to write a file.  This way, we can ensure that the same output
  45    file is always produced from the same input.")
  46
  47 (define-clear-the-decks reset-codegen-index
  48   (setf *temporary-index* 0))
  49
  50 (defmethod commentify-argument-name ((name temporary-name))
  51   nil)
  52
  53 (defun temporary-function ()
  54   "Return a temporary function name."
  55   (make-instance 'temporary-function
  56                  :tag (prog1 *temporary-index* (incf *temporary-index*))))
  57
  58 (defmethod format-temporary-name ((var temporary-name) stream)
  59   (format stream "~A" (temp-tag var)))
  60 (defmethod format-temporary-name ((var temporary-argument) stream)
  61   (format stream "sod__a~A" (temp-tag var)))
  62 (defmethod format-temporary-name ((var temporary-variable) stream)
  63   (format stream "sod__v~A" (temp-tag var)))
  64 (defmethod format-temporary-name ((var temporary-function) stream)
  65   (format stream "sod__f~A" (temp-tag var)))
  66
  67 (defmethod print-object ((var temporary-name) stream)
  68   (if *print-escape*
  69       (print-unreadable-object (var stream :type t)
  70         (prin1 (temp-tag var) stream))
  71       (format-temporary-name var stream)))
  72
  73 ;;;--------------------------------------------------------------------------
  74 ;;; Code generator objects.
  75
  76 (defclass basic-codegen ()
  77   ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
  78    (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
  79    (temp-index :initarg :temp-index :initform 0
  80                :type fixnum :accessor codegen-temp-index))
  81   (:documentation
  82    "Base class for code generator state.
  83
  84    This contains the bare essentials for supporting the `emit-inst' and
  85    `ensure-var' protocols; see the documentation for those generic functions
  86    for more details.
  87
  88    This class isn't abstract.  A full `codegen' object uses instances of this
  89    to keep track of pending functions which haven't been completed yet.
  90
  91    Just in case that wasn't clear enough: this is nothing to do with the
  92    BASIC language."))
  93
  94 (defmethod emit-inst ((codegen basic-codegen) inst)
  95   (push inst (codegen-insts codegen)))
  96
  97 (defmethod emit-insts ((codegen basic-codegen) insts)
  98   (asetf (codegen-insts codegen) (revappend insts it)))
  99
 100 (defmethod emit-decl ((codegen basic-codegen) inst)
 101   (push inst (codegen-vars codegen)))
 102
 103 (defmethod emit-decls ((codegen basic-codegen) insts)
 104   (asetf (codegen-vars codegen) (revappend insts it)))
 105
 106 (defmethod ensure-var ((codegen basic-codegen) name type &optional init)
 107   (let* ((vars (codegen-vars codegen))
 108          (var (find name
 109                     (remove-if-not (lambda (var) (typep var 'var-inst)) vars)
 110                     :key #'inst-name :test #'equal)))
 111     (cond ((not var)
 112            (setf (codegen-vars codegen)
 113                  (cons (make-var-inst name type init) vars)))
 114           ((not (c-type-equal-p type (inst-type var)))
 115            (error "(Internal) Redefining type for variable ~A." name)))
 116     name))
 117
 118 (export 'codegen)
 119 (defclass codegen (basic-codegen)
 120   ((functions :initform nil :type list :accessor codegen-functions)
 121    (stack :initform nil :type list :accessor codegen-stack))
 122   (:documentation
 123    "A full-fat code generator which can generate and track functions.
 124
 125    This is the real deal.  Subclasses may which to attach additional state
 126    for convenience's sake, but this class is self-contained.  It supports the
 127    `codegen-push', `codegen-pop' and `codegen-pop-function' protocols."))
 128
 129 (defmethod codegen-push ((codegen codegen))
 130   (with-slots (vars insts temp-index stack) codegen
 131     (push (make-instance 'basic-codegen
 132                          :vars vars
 133                          :insts insts
 134                          :temp-index temp-index)
 135           stack)
 136     (setf vars nil insts nil temp-index 0)))
 137
 138 (defmethod codegen-pop ((codegen codegen))
 139   (with-slots (vars insts temp-index stack) codegen
 140     (multiple-value-prog1
 141         (values (nreverse vars) (nreverse insts))
 142       (let ((sub (pop stack)))
 143         (setf vars (codegen-vars sub)
 144               insts (codegen-insts sub)
 145               temp-index (codegen-temp-index sub))))))
 146
 147 (defmethod codegen-add-function ((codegen codegen) function)
 148   (with-slots (functions) codegen
 149     (setf functions (nconc functions (list function)))))
 150
 151 (defmethod temporary-var ((codegen basic-codegen) type)
 152   (with-slots (vars temp-index) codegen
 153     (or (some (lambda (var)
 154                 (let ((name (inst-name var)))
 155                   (if (and (not (var-in-use-p name))
 156                            (c-type-equal-p type (inst-type var)))
 157                       name
 158                       nil)))
 159               (remove-if-not (lambda (var) (typep var 'var-inst)) vars))
 160         (let* ((name (make-instance 'temporary-variable
 161                                     :in-use-p t
 162                                     :tag (prog1 temp-index
 163                                            (incf temp-index)))))
 164           (push (make-var-inst name type) vars)
 165           name))))
 166
 167 ;;;----- That's all, folks --------------------------------------------------