ast.scm

   1 ;;; definition of ast types
   2
   3 (define-type ast
   4   extender: define-type-of-ast
   5   (parent unprintable:)
   6   subasts)
   7
   8 (define (link-parent! subast parent)
   9   (ast-parent-set! subast parent)
  10   parent)
  11
  12 (define (multi-link-parent! subasts parent)
  13   (for-each (lambda (subast) (link-parent! subast parent))
  14             subasts)
  15   parent)
  16
  17 (define (unlink-parent! subast)
  18   (let ((parent (ast-parent subast)))
  19     (if (and (def-variable? subast) (def-procedure? parent))
  20         (def-procedure-params-set!
  21           parent
  22           (remove subast (def-procedure-params parent)))
  23         (ast-subasts-set!
  24          parent
  25          (remove subast (ast-subasts parent))))
  26     (ast-parent-set! subast #f)
  27     subast))
  28
  29 (define (subast1 ast) (car (ast-subasts ast)))
  30 (define (subast2 ast) (cadr (ast-subasts ast)))
  31 (define (subast3 ast) (caddr (ast-subasts ast)))
  32 (define (subast4 ast) (cadddr (ast-subasts ast)))
  33
  34 (define-type-of-ast def
  35   extender: define-type-of-def
  36   id
  37   unprintable:
  38   refs)
  39
  40 (define-type value
  41   bytes)
  42 (define (new-value bytes)
  43   (make-value bytes))
  44
  45 (define byte-cell-counter 0)
  46 (define (byte-cell-next-id) (let ((id byte-cell-counter))
  47                               (set! byte-cell-counter (+ id 1))
  48                               id))
  49 (define-type byte-cell
  50   id
  51   adr
  52   (interferes-with unprintable:) ; these 2 are stored as sets
  53   (coalesceable-with unprintable:))
  54 (define (new-byte-cell)
  55   (let ((id (byte-cell-next-id)))
  56     (make-byte-cell id (if allocate-registers? #f id)
  57                     (new-empty-set) (new-empty-set))))
  58 (define (get-register n) ;; TODO will these byte cells be used for register allocation ? do they need an id ?
  59   (make-byte-cell (byte-cell-next-id) n  (new-empty-set) (new-empty-set)))
  60
  61 (define-type byte-lit
  62   val)
  63 (define (new-byte-lit x)
  64   (make-byte-lit x))
  65
  66 (define types-bytes
  67   '((void  . 0)
  68     (bool  . 1)
  69     (int   . 1)
  70     (byte  . 1)
  71     (int8  . 1)
  72     (int16 . 2)
  73     (int24 . 3)
  74     (int32 . 4)))
  75
  76 (define (type->bytes type)
  77   (cond ((assq type types-bytes)
  78          => (lambda (x) (cdr x)))
  79         (else (error "wrong number of bytes ?"))))
  80
  81 (define (bytes->type n)
  82   (let loop ((l types-bytes))
  83     (cond ((null? l)     (error (string-append "no type contains "
  84                                                (number->string n)
  85                                                " bytes")))
  86           ((= n (cdar l)) (caar l))
  87           (else (loop (cdr l))))))
  88
  89 (define (int->value n type)
  90   (let ((len (type->bytes type)))
  91     (let loop ((len len) (n n) (rev-bytes '()))
  92       (if (= len 0)
  93           (new-value (reverse rev-bytes))
  94           (loop (- len 1)
  95                 (arithmetic-shift n -8)
  96                 (cons (new-byte-lit (modulo n 256))
  97                       rev-bytes))))))
  98 (define (value->int val)
  99   (let loop ((bytes (reverse (value-bytes val)))
 100              (n     0))
 101     (if (null? bytes)
 102         n
 103         (loop (cdr bytes)
 104               (+ (* 256 n) (byte-lit-val (car bytes)))))))
 105
 106 ;; TODO instead of carrying types around, use the length instead
 107 (define (extend value type)
 108   ;; literals must be extended with literal 0s, while variables must be
 109   ;; extended with byte cells
 110   (let* ((bytes (value-bytes value))
 111          (lit?  (byte-lit? (car bytes))))
 112     (let loop ((rev-bytes (reverse bytes))
 113                (n         (max 0 (- (type->bytes type) (length bytes)))))
 114       (if (= n 0)
 115           (new-value (reverse rev-bytes))
 116           (loop (cons (if lit? (new-byte-lit 0) (new-byte-cell))
 117                       rev-bytes)
 118                 (- n 1))))))
 119
 120 (define (alloc-value type)
 121   (let ((len (type->bytes type)))
 122     (let loop ((len len) (rev-bytes '()))
 123       (if (= len 0)
 124           (new-value (reverse rev-bytes))
 125           (loop (- len 1)
 126                 (cons (new-byte-cell)
 127                       rev-bytes))))))
 128
 129 (define-type-of-def def-variable
 130   type
 131   value
 132   unprintable:
 133   sets)
 134 (define (new-def-variable subasts id refs type value sets)
 135   (multi-link-parent!
 136    subasts
 137    (make-def-variable #f subasts id refs type value sets)))
 138
 139 (define-type-of-def def-procedure
 140   type
 141   value
 142   params
 143   entry
 144   live-after-calls) ; stored as a set
 145 (define (new-def-procedure subasts id refs type value params)
 146   (multi-link-parent!
 147    subasts
 148    (make-def-procedure #f subasts id refs type value params #f (new-empty-set))))
 149
 150
 151 (define-type-of-ast expr
 152   extender: define-type-of-expr
 153   type)
 154
 155 (define-type-of-expr literal
 156   val)
 157 (define (new-literal type val)
 158   (make-literal #f '() type val))
 159
 160 (define-type-of-expr ref
 161   def-var)
 162 (define (new-ref type def)
 163   (make-ref #f '() type def))
 164
 165 (define-type-of-expr oper
 166   op)
 167 (define (new-oper subasts type op)
 168   (multi-link-parent!
 169    subasts
 170    (make-oper #f subasts type op)))
 171
 172 (define-type-of-expr call
 173   (def-proc unprintable:))
 174 (define (new-call subasts type proc-def)
 175   (multi-link-parent!
 176    subasts
 177    (make-call #f subasts type proc-def)))
 178
 179 (define-type-of-ast block
 180   name) ; blocks that begin with a label have a name, the other have #f
 181 (define (new-block subasts)
 182   (multi-link-parent!
 183    subasts
 184    (make-block #f subasts #f)))
 185 (define (new-named-block name subasts)
 186   (multi-link-parent!
 187    subasts
 188    (make-block #f subasts name)))
 189
 190 (define-type-of-ast if)
 191 (define (new-if subasts)
 192   (multi-link-parent!
 193    subasts
 194    (make-if #f subasts)))
 195
 196 (define-type-of-ast switch)
 197 (define (new-switch subasts)
 198   (multi-link-parent!
 199    subasts
 200    (make-switch #f subasts)))
 201
 202 (define-type-of-ast while)
 203 (define (new-while subasts)
 204   (multi-link-parent!
 205    subasts
 206    (make-while #f subasts)))
 207
 208 (define-type-of-ast do-while)
 209 (define (new-do-while subasts)
 210   (multi-link-parent!
 211    subasts
 212    (make-do-while #f subasts)))
 213
 214 (define-type-of-ast for)
 215 (define (new-for subasts)
 216   (multi-link-parent!
 217    subasts
 218    (make-for #f subasts)))
 219
 220 (define-type-of-ast return)
 221 (define (new-return subasts)
 222   (multi-link-parent!
 223    subasts
 224    (make-return #f subasts)))
 225
 226 (define-type-of-ast break)
 227 (define (new-break)
 228   (make-break #f '()))
 229
 230 (define-type-of-ast continue)
 231 (define (new-continue)
 232   (make-continue #f '()))
 233
 234 (define-type-of-ast goto)
 235 (define (new-goto label)
 236   (make-goto #f (list label)))
 237
 238 (define-type-of-ast program)
 239 (define (new-program subasts) ;; TODO add support for main
 240   (multi-link-parent!
 241    subasts
 242    (make-program #f subasts)))
 243
 244 (define-type op
 245   extender: define-type-of-op
 246   (six-id unprintable:)
 247   id
 248   unprintable:
 249   type-rule
 250   constant-fold
 251   code-gen)
 252
 253 (define-type-of-op op1)
 254 (define-type-of-op op2)
 255 (define-type-of-op op3)