ast.scm

   1 ;;; definition of ast types
   2
   3 (define-type ast
   4   extender: define-type-of-ast
   5   (parent unprintable: equality-skip:)
   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   (refs unprintable: equality-skip:))
  38
  39 (define-type value
  40   bytes)
  41 (define (new-value bytes)
  42   (make-value bytes))
  43
  44 (define byte-cell-counter 0)
  45 (define (byte-cell-next-id) (let ((id byte-cell-counter))
  46                               (set! byte-cell-counter (+ id 1))
  47                               id))
  48 (define all-byte-cells (make-table)) ;; TODO does not contain those defined (using make-byte-cell) in cte.scm
  49 (define-type byte-cell
  50   id
  51   adr
  52   name ; to display in the listing
  53   bb   ; label of the basic in which this byte-cell is used
  54   def-proc-id ; id of the procedure it was defined in
  55   (interferes-with   unprintable: equality-skip:)  ; bitset
  56   nb-neighbours ; cached length of interferes-with
  57   (coalesceable-with unprintable: equality-skip:)  ; set
  58   (coalesced-with    unprintable: equality-skip:)) ; set
  59 (define (new-byte-cell def-proc-id #!optional (name #f) (bb #f))
  60   (let* ((id   (byte-cell-next-id))
  61          (cell (make-byte-cell
  62                 id (if allocate-registers? #f id)
  63                 name bb def-proc-id #f 0 (new-empty-set) (new-empty-set))))
  64     (table-set! all-byte-cells id cell)
  65     cell))
  66 (define (get-register n)
  67   (let* ((id   (byte-cell-next-id))
  68          (cell (make-byte-cell
  69                 id n (symbol->string (cdr (assv n file-reg-names))) #f #f
  70                 #f 0 (new-empty-set) (new-empty-set))))
  71     (table-set! all-byte-cells id cell)
  72     cell))
  73
  74 (define-type byte-lit
  75   val)
  76 (define (new-byte-lit x)
  77   (make-byte-lit x))
  78
  79 (define types-bytes
  80   '((void   . 0)
  81     (bool   . 1)
  82     (int    . 2)
  83     (byte   . 1)
  84     (uint8  . 1)
  85     (uint16 . 2)
  86     (uint24 . 3)
  87     (uint32 . 4)))
  88
  89 (define (val->type n) ;; TODO negative literals won't work
  90   (cond ((and (>= n 0) (< n 256))   'uint8)
  91         ((and (>= n 0) (< n 65536)) 'uint16)
  92         (else                       'uint32)))
  93 (define (type->bytes type)
  94   (cond ((assq type types-bytes)
  95          => (lambda (x) (cdr x)))
  96         (else (error "wrong type?"))))
  97 (define (bytes->type n)
  98   (let loop ((l types-bytes))
  99     (cond ((null? l)     (error (string-append "no type contains "
 100                                                (number->string n)
 101                                                " bytes")))
 102           ((= n (cdar l)) (caar l))
 103           (else (loop (cdr l))))))
 104
 105 (define (int->value n type)
 106   (let ((len (type->bytes type)))
 107     (let loop ((len len) (n n) (rev-bytes '()))
 108       (if (= len 0)
 109           (new-value (reverse rev-bytes))
 110           (loop (- len 1)
 111                 (arithmetic-shift n -8)
 112                 (cons (new-byte-lit (modulo n 256))
 113                       rev-bytes))))))
 114 (define (value->int val)
 115   (let loop ((bytes (reverse (value-bytes val)))
 116              (n     0))
 117     (if (null? bytes)
 118         n
 119         (loop (cdr bytes)
 120               (+ (* 256 n) (byte-lit-val (car bytes)))))))
 121
 122 (define (alloc-value type def-proc-id #!optional (name #f) (bb #f))
 123   (let ((len (type->bytes type)))
 124     (let loop ((len len) (rev-bytes '()))
 125       (if (= len 0)
 126           (new-value rev-bytes)
 127           (loop (- len 1)
 128                 (cons (new-byte-cell
 129                        def-proc-id
 130                        (if name
 131                            ;; the lsb is 0, and so on
 132                            (string-append (symbol->string name) "$"
 133                                           (number->string (- len 1)))
 134                            #f)
 135                        bb)
 136                       rev-bytes))))))
 137
 138 (define-type-of-def def-variable
 139   type
 140   value
 141   (sets unprintable: equality-skip:)
 142   def-proc-id) ; name of the procedure it was defined in, #f if global
 143 (define (new-def-variable subasts id refs type value sets def-proc-id)
 144   (multi-link-parent!
 145    subasts
 146    (make-def-variable #f subasts id refs type value sets def-proc-id)))
 147
 148 (define-type-of-def def-procedure
 149   type
 150   value
 151   params
 152   entry
 153   (live-after-calls unprintable: equality-skip:) ; bitset
 154   ;; used for common subexpression elimination
 155   (computed-expressions unprintable: equality-skip:))
 156 (define all-def-procedures (make-table))
 157 (define (new-def-procedure subasts id refs type value params)
 158   (multi-link-parent!
 159    subasts
 160    (let ((d (make-def-procedure
 161              #f subasts id refs type value params #f #f
 162              (make-table)))) ; needs an equal? hash-table
 163      (table-set! all-def-procedures id d)
 164      d)))
 165
 166
 167 (define-type-of-ast expr
 168   extender: define-type-of-expr
 169   type)
 170
 171 (define-type-of-expr literal
 172   val)
 173 (define (new-literal type val)
 174   (make-literal #f '() type val))
 175
 176 (define-type-of-expr ref
 177   def-var)
 178 (define (new-ref type def)
 179   (make-ref #f '() type def))
 180
 181 (define-type-of-expr oper
 182   op)
 183 (define (new-oper subasts type op)
 184   (multi-link-parent!
 185    subasts
 186    (make-oper #f subasts type op)))
 187
 188 (define-type-of-expr call
 189   (def-proc unprintable: equality-skip:))
 190 (define (new-call subasts type proc-def)
 191   (multi-link-parent!
 192    subasts
 193    (make-call #f subasts type proc-def)))
 194
 195 (define-type-of-ast block
 196   name) ; blocks that begin with a label have a name, the other have #f
 197 (define (new-block subasts)
 198   (multi-link-parent!
 199    subasts
 200    (make-block #f subasts #f)))
 201 (define (new-named-block name subasts)
 202   (multi-link-parent!
 203    subasts
 204    (make-block #f subasts name)))
 205
 206 (define-type-of-ast if)
 207 (define (new-if subasts)
 208   (multi-link-parent!
 209    subasts
 210    (make-if #f subasts)))
 211
 212 (define-type-of-ast switch)
 213 (define (new-switch subasts)
 214   (multi-link-parent!
 215    subasts
 216    (make-switch #f subasts)))
 217
 218 (define-type-of-ast while)
 219 (define (new-while subasts)
 220   (multi-link-parent!
 221    subasts
 222    (make-while #f subasts)))
 223
 224 (define-type-of-ast do-while)
 225 (define (new-do-while subasts)
 226   (multi-link-parent!
 227    subasts
 228    (make-do-while #f subasts)))
 229
 230 (define-type-of-ast for)
 231 (define (new-for subasts)
 232   (multi-link-parent!
 233    subasts
 234    (make-for #f subasts)))
 235
 236 (define-type-of-ast return)
 237 (define (new-return subasts)
 238   (multi-link-parent!
 239    subasts
 240    (make-return #f subasts)))
 241
 242 (define-type-of-ast break)
 243 (define (new-break)
 244   (make-break #f '()))
 245
 246 (define-type-of-ast continue)
 247 (define (new-continue)
 248   (make-continue #f '()))
 249
 250 (define-type-of-ast goto)
 251 (define (new-goto label)
 252   (make-goto #f (list label)))
 253
 254 (define-type-of-ast program)
 255 (define (new-program subasts) ;; TODO add support for main
 256   (multi-link-parent!
 257    subasts
 258    (make-program #f subasts)))
 259
 260 (define-type op
 261   extender: define-type-of-op
 262   (six-id unprintable:)
 263   id
 264   unprintable:
 265   type-rule
 266   constant-fold
 267   code-gen)
 268
 269 (define-type-of-op op1)
 270 (define-type-of-op op2)
 271 (define-type-of-op op3)