mdw@git.distorted.org.uk Git - sod/blob - src/impl-codegen.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 Sensble 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 (defmethod commentify-argument-name ((name temporary-name))
  41   nil)
  42
  43 (export 'temporary-function)
  44 (defun temporary-function ()
  45   "Return a temporary function name."
  46   (make-instance 'temporary-function
  47                  :tag (prog1 *temporary-index* (incf *temporary-index*))))
  48
  49 (defmethod format-temporary-name ((var temporary-name) stream)
  50   (format stream "~A" (temp-tag var)))
  51 (defmethod format-temporary-name ((var temporary-argument) stream)
  52   (format stream "sod__a~A" (temp-tag var)))
  53 (defmethod format-temporary-name ((var temporary-variable) stream)
  54   (format stream "sod__v~A" (temp-tag var)))
  55 (defmethod format-temporary-name ((var temporary-function) stream)
  56   (format stream "sod__f~A" (temp-tag var)))
  57
  58 (defmethod print-object ((var temporary-name) stream)
  59   (if *print-escape*
  60       (print-unreadable-object (var stream :type t)
  61         (prin1 (temp-tag var) stream))
  62       (format-temporary-name var stream)))
  63
  64 ;;;--------------------------------------------------------------------------
  65 ;;; Instruction types.
  66
  67 ;; Compound statements.
  68
  69 (export '(if-inst make-if-inst
  70           while-inst make-while-inst
  71           do-inst make-do-inst
  72           inst-condition inst-consequent inst-alternative inst-body))
  73
  74 (definst if (stream) (condition consequent alternative)
  75   (format-compound-statement (stream consequent alternative)
  76     (format stream "if (~A)" condition))
  77   (when alternative
  78     (format-compound-statement (stream alternative)
  79       (write-string "else" stream))))
  80
  81 (definst while (stream) (condition body)
  82   (format-compound-statement (stream body)
  83     (format stream "while (~A)" condition)))
  84
  85 (definst do-while (stream) (body condition)
  86   (format-compound-statement (stream body :space)
  87     (write-string "do" stream))
  88   (format stream "while (~A);" condition))
  89
  90 ;; Special varargs hacks.
  91
  92 (export '(va-start-inst make-va-start-inst
  93           va-copy-inst make-va-copy-inst
  94           va-end-inst make-va-end-inst
  95           inst-ap inst-arg inst-to inst-from))
  96
  97 (definst va-start (stream) (ap arg)
  98   (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
  99
 100 (definst va-copy (stream) (to from)
 101   (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
 102
 103 (definst va-end (stream) (ap)
 104   (format stream "va_end(~A);" ap))
 105
 106 ;; Expressions.
 107
 108 (export '(call-inst make-call-inst inst-func inst-args))
 109
 110 (definst call (stream) (func args)
 111   (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
 112
 113 ;;;--------------------------------------------------------------------------
 114 ;;; Code generator objects.
 115
 116 (defclass basic-codegen ()
 117   ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
 118    (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
 119    (temp-index :initarg :temp-index :initform 0
 120                :type fixnum :accessor codegen-temp-index))
 121   (:documentation
 122    "Base class for code generator state.
 123
 124    This contains the bare essentials for supporting the EMIT-INST and
 125    ENSURE-VAR protocols; see the documentation for those generic functions
 126    for more details.
 127
 128    This class isn't abstract.  A full CODEGEN object uses instances of this
 129    to keep track of pending functions which haven't been completed yet.
 130
 131    Just in case that wasn't clear enough: this is nothing to do with the
 132    BASIC language."))
 133
 134 (defmethod emit-inst ((codegen basic-codegen) inst)
 135   (push inst (codegen-insts codegen)))
 136
 137 (defmethod emit-insts ((codegen basic-codegen) insts)
 138   (asetf (codegen-insts codegen) (revappend insts it)))
 139
 140 (defmethod ensure-var ((codegen basic-codegen) name type &optional init)
 141   (let* ((vars (codegen-vars codegen))
 142          (var (find name vars :key #'inst-name :test #'equal)))
 143     (cond ((not var)
 144            (setf (codegen-vars codegen)
 145                  (cons (make-var-inst name type init) vars)))
 146           ((not (c-type-equal-p type (inst-type var)))
 147            (error "(Internal) Redefining type for variable ~A." name)))
 148     name))
 149
 150 (export 'codegen)
 151 (defclass codegen (basic-codegen)
 152   ((functions :initform nil :type list :accessor codegen-functions)
 153    (stack :initform nil :type list :accessor codegen-stack))
 154   (:documentation
 155    "A full-fat code generator which can generate and track functions.
 156
 157    This is the real deal.  Subclasses may which to attach additional state
 158    for convenience's sake, but this class is self-contained.  It supports the
 159    CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
 160
 161 (defmethod codegen-push ((codegen codegen))
 162   (with-slots (vars insts temp-index stack) codegen
 163     (push (make-instance 'basic-codegen
 164                          :vars vars
 165                          :insts insts
 166                          :temp-index temp-index)
 167           stack)
 168     (setf vars nil insts nil temp-index 0)))
 169
 170 (defmethod codegen-pop ((codegen codegen))
 171   (with-slots (vars insts temp-index stack) codegen
 172     (multiple-value-prog1
 173         (values (nreverse vars) (nreverse insts))
 174       (let ((sub (pop stack)))
 175         (setf vars (codegen-vars sub)
 176               insts (codegen-insts sub)
 177               temp-index (codegen-temp-index sub))))))
 178
 179 (defmethod codegen-add-function ((codegen codegen) function)
 180   (with-slots (functions) codegen
 181     (setf functions (nconc functions (list function)))))
 182
 183 (defmethod temporary-var ((codegen basic-codegen) type)
 184   (with-slots (vars temp-index) codegen
 185     (or (some (lambda (var)
 186                 (let ((name (inst-name var)))
 187                   (if (and (not (var-in-use-p name))
 188                            (c-type-equal-p type (inst-type var)))
 189                       name
 190                       nil)))
 191               vars)
 192         (let* ((name (make-instance 'temporary-variable
 193                                     :in-use-p t
 194                                     :tag (prog1 temp-index
 195                                            (incf temp-index)))))
 196           (push (make-var-inst name type nil) vars)
 197           name))))
 198
 199 ;;;----- That's all, folks --------------------------------------------------