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