operators.scm

   1 ;;; operators
   2
   3 (define operators '())
   4
   5 (define (define-op1 six-id id type-rule constant-fold code-gen)
   6   (set! operators
   7         (cons (make-op1 six-id id type-rule constant-fold code-gen)
   8               operators)))
   9
  10 (define (define-op2 six-id id type-rule constant-fold code-gen)
  11   (set! operators
  12         (cons (make-op2 six-id id type-rule constant-fold code-gen)
  13               operators)))
  14
  15 ;; no need for type checks, every type sixpic supports can be casted to / from
  16 ;; ints (except void, but this is a non-issue) and promotion (by padding) and
  17 ;; truncation is done at the cfg level
  18 ;; TODO really ignore the void issue ? assigning the "result" of a void function to an int variable should be an error
  19 (define (type-rule-int-op1 ast)
  20   (expr-type (subast1 ast)))
  21
  22 (define (largest t1 t2)
  23   (if (> (type->bytes t1) (type->bytes t2))
  24       t1
  25       t2))
  26
  27 (define (type-rule-int-op2 ast)
  28   ;; used for any binary operation involving two integers where the result is
  29   ;; of the size of the biggest operand (subtraction, bitwise operations, ...)
  30   (let ((t1 (expr-type (subast1 ast)))
  31         (t2 (expr-type (subast2 ast))))
  32     (largest t1 t2)))
  33
  34 (define (type-rule-assign ast)
  35   (let ((t1 (expr-type (subast1 ast))))
  36     ;; the type of the rhs is irrelevant, since it will be promoted
  37     ;; or truncated at the cfg level
  38     t1))
  39
  40 (define (type-rule-int-comp-op2 ast)
  41   'bool) ;; TODO why even bother ? anything can be casted to int to be used as argument here, old version is in garbage (and in version control) if needed
  42
  43 (define (type-rule-bool-op2 ast)
  44   'bool) ;; TODO same here
  45
  46 (define-op1 'six.!x '!x
  47   type-rule-int-op1
  48   (lambda (ast) ;; TODO implement these ?
  49     ast)
  50   (lambda (ast)
  51     ...))
  52
  53
  54 (define-op1 'six.++x '++x
  55   ;; unlike addition, we do not need to add an extra byte just in case
  56   ;; since the destination and the source are the same, we won't have any
  57   ;; unexpected truncation problems
  58   type-rule-int-op1
  59   (lambda (ast)
  60     ast)
  61   (lambda (ast)
  62     ...))
  63
  64 (define-op1 'six.x++ 'x++
  65   type-rule-int-op1
  66   (lambda (ast)
  67     ast)
  68   (lambda (ast)
  69     ...))
  70
  71 (define-op1 'six.--x '--x
  72   type-rule-int-op1
  73   (lambda (ast)
  74     ast)
  75   (lambda (ast)
  76     ...))
  77
  78 (define-op1 'six.x-- 'x--
  79   type-rule-int-op1
  80   (lambda (ast)
  81     ast)
  82   (lambda (ast)
  83     ...))
  84
  85 (define-op1 'six.~x '~x
  86   type-rule-int-op1
  87   (lambda (ast)
  88     ast)
  89   (lambda (ast)
  90     ...))
  91
  92 (define-op2 'six.x%y 'x%y
  93   (lambda (ast)
  94     ;; if we know the second operand, we can have an upper bound on the size
  95     ;; of the result
  96     (if (literal? (subast1 ast))
  97         ;; the number of bits needed by the result is lg(y)
  98         (bytes->type (ceiling (/ (log y) (log 2) 8)))
  99         ;; fall back to the general case
 100         (type-rule-int-op2 ast)))
 101   (lambda (ast)
 102     ast)
 103   (lambda (ast)
 104     ...))
 105
 106 (define-op2 'six.x*y 'x*y
 107   ;; products can be as wide as the sum of the widths of the operands
 108   (lambda (ast)
 109     (let ((l1 (type->bytes (expr-type (subast1 ast))))
 110           (l2 (type->bytes (expr-type (subast2 ast)))))
 111       (bytes->type (+ l1 l2))))
 112   (lambda (ast)
 113     ast)
 114   (lambda (ast)
 115     ...))
 116
 117 (define-op1 'six.*x '*x
 118   (lambda (ast)
 119     'byte) ; we only have byte arrays
 120   (lambda (ast)
 121     ast)
 122   (lambda (ast)
 123     ...))
 124
 125 (define-op2 'six.index 'index
 126   (lambda (ast)
 127     'byte) ; we only have byte arrays
 128   (lambda (ast)
 129     ast)
 130   (lambda (asr)
 131     ...))
 132
 133 (define-op2 'six.x/y 'x/y
 134   (lambda (ast)
 135     ;; if we know the second operand, we can have an upper bound on the size
 136     ;; of the result
 137     (if (literal? (subast1 ast))
 138         ;; for every byte over 1 in the length of y, we can remove a byte from
 139         ;; the result
 140         ;; ex : the smallest value which needs 2 bytes to encode is 256, and
 141         ;; dividing by 256 is equivalent to truncating the 8 lowest bits, and
 142         ;; so on
 143         (let (((l1 (type->bytes (expr-type (subast1 ast))))
 144                (l2 (ceiling (/ (log y) (log 2) 8)))))
 145           (bytes->type (- (max l1 l2) (- l2 1))))
 146         ;; fall back to the general case
 147         (type-rule-int-op2 ast)))
 148   type-rule-int-op2
 149   (lambda (ast)
 150     ast)
 151   (lambda (ast)
 152     ...))
 153
 154 (define-op2 'six.x+y 'x+y
 155   (lambda (ast)
 156     (let ((l1 (type->bytes (expr-type (subast1 ast))))
 157           (l2 (type->bytes (expr-type (subast2 ast)))))
 158       ;; the extra byte is needed in some cases
 159       ;; for example : 200 + 200 = 400
 160       ;; both operands are 1  byte wide, but the result is 2 bytes wide
 161       (bytes->type (+ (max l1 l2) 1))))
 162   (lambda (ast)
 163     ast)
 164   (lambda (ast)
 165     ...))
 166
 167 (define-op1 'six.+x '+x
 168   type-rule-int-op1
 169   (lambda (ast)
 170     (subast1 ast))
 171   (lambda (ast)
 172     ...))
 173
 174 (define-op2 'six.x-y 'x-y
 175   type-rule-int-op2
 176   (lambda (ast)
 177     ast)
 178   (lambda (ast)
 179     ...))
 180
 181 (define-op1 'six.-x '-x
 182   type-rule-int-op1
 183   (lambda (ast)
 184     ast)
 185   (lambda (ast)
 186     ...))
 187
 188 (define-op2 'six.x<<y 'x<<y ;; TODO for the general case, would give scary results (a single byte for y can still mean a shift by 255)
 189   (lambda (ast)
 190     (if (not (literal? (subast2 ast)))
 191         (error "only shifting by literals is supported"))
 192     (let ((l1 (type->bytes (expr-type (subast1 ast))))
 193           (v2 (literal-val (subast2 ast))))
 194       ;; we might have to add some bytes to the result
 195       (bytes->type (+ l1 (ceiling (/ v2 8))))))
 196   (lambda (ast)
 197     ast)
 198   (lambda (ast)
 199     ...))
 200
 201 (define-op2 'six.x>>y 'x>>y
 202   (lambda (ast)
 203     (if (not (literal? (subast2 ast)))
 204         (error "only shifting by literals is supported"))
 205     (let ((l1 (type->bytes (expr-type (subast1 ast))))
 206           (v2 (literal-val (subast2 ast))))
 207       ;; we might be able to shave some bytes off
 208       (bytes->type (- l1 (floor (/ v2 8))))))
 209   (lambda (ast)
 210     ast)
 211   (lambda (ast)
 212     ...))
 213
 214 (define-op2 'six.x<y 'x<y
 215   type-rule-int-comp-op2
 216   (lambda (ast)
 217     ast)
 218   (lambda (ast)
 219     ...))
 220
 221 (define-op2 'six.x<=y 'x<=y
 222   type-rule-int-comp-op2
 223   (lambda (ast)
 224     ast)
 225   (lambda (ast)
 226     ...))
 227
 228 (define-op2 'six.x>y 'x>y
 229   type-rule-int-comp-op2
 230   (lambda (ast)
 231     ast)
 232   (lambda (ast)
 233     ...))
 234
 235 (define-op2 'six.x>=y 'x>=y
 236   type-rule-int-comp-op2
 237   (lambda (ast)
 238     ast)
 239   (lambda (ast)
 240     ...))
 241
 242 (define-op2 'six.x!=y 'x!=y
 243   type-rule-int-comp-op2
 244   (lambda (ast)
 245     ast)
 246   (lambda (ast)
 247     ...))
 248
 249 (define-op2 'six.x==y 'x==y
 250   type-rule-int-comp-op2
 251   (lambda (ast)
 252     ast)
 253   (lambda (ast)
 254     ...))
 255
 256 (define-op2 'six.x&y 'x&y
 257   type-rule-int-op2
 258   (lambda (ast)
 259     ast)
 260   (lambda (ast)
 261     ...))
 262
 263 (define-op1 'six.&x '&x
 264   (lambda (ast)
 265     ...)
 266   (lambda (ast)
 267     ast)
 268   (lambda (ast)
 269     ...))
 270
 271 (define-op2 'six.x^y 'x^y
 272   type-rule-int-op2
 273   (lambda (ast)
 274     ast)
 275   (lambda (ast)
 276     ...))
 277
 278 (define-op2 '|six.x\|y| '|x\|y|
 279   type-rule-int-op2
 280   (lambda (ast)
 281     ast)
 282   (lambda (ast)
 283     ...))
 284
 285 (define-op2 'six.x&&y 'x&&y
 286   type-rule-bool-op2
 287   (lambda (ast)
 288     ast)
 289   (lambda (ast)
 290     ...))
 291
 292 (define-op2 '|six.x\|\|y| '|x\|\|y|
 293   type-rule-bool-op2
 294   (lambda (ast)
 295     ast)
 296   (lambda (ast)
 297     ...))
 298
 299 (define-op2 'six.x?y:z 'x?y:z
 300   (lambda (ast)
 301     ...)
 302   (lambda (ast)
 303     ast)
 304   (lambda (ast)
 305     ...))
 306
 307 (define-op2 'six.x:y 'x:y
 308   (lambda (ast)
 309     ...)
 310   (lambda (ast)
 311     ast)
 312   (lambda (ast)
 313     ...))
 314
 315 (define-op2 'six.x%=y 'x%=y ;; TODO these don't work
 316   type-rule-assign
 317   (lambda (ast)
 318     ast)
 319   (lambda (ast)
 320     ...))
 321
 322 (define-op2 'six.x&=y 'x&=y
 323   type-rule-assign
 324   (lambda (ast)
 325     ast)
 326   (lambda (ast)
 327     ...))
 328
 329 (define-op2 'six.x*=y 'x*=y
 330   type-rule-assign
 331   (lambda (ast)
 332     ast)
 333   (lambda (ast)
 334     ...))
 335
 336 (define-op2 'six.x+=y 'x+=y
 337   type-rule-assign
 338   (lambda (ast)
 339     ast)
 340   (lambda (ast)
 341     ...))
 342
 343 (define-op2 'six.x-=y 'x-=y
 344   type-rule-assign
 345   (lambda (ast)
 346     ast)
 347   (lambda (ast)
 348     ...))
 349
 350 (define-op2 'six.x/=y 'x/=y
 351   type-rule-assign
 352   (lambda (ast)
 353     ast)
 354   (lambda (ast)
 355     ...))
 356
 357 (define-op2 'six.x<<=y 'x<<=y
 358   type-rule-assign
 359   (lambda (ast)
 360     ast)
 361   (lambda (ast)
 362     ...))
 363
 364 (define-op2 'six.x=y 'x=y
 365   type-rule-assign
 366   (lambda (ast)
 367     ast)
 368   (lambda (ast)
 369     ...))
 370
 371 (define-op2 'six.x>>=y 'x>>=y
 372   type-rule-assign
 373   (lambda (ast)
 374     ast)
 375   (lambda (ast)
 376     ...))
 377
 378 (define-op2 'six.x^=y 'x^=y
 379   type-rule-assign
 380   (lambda (ast)
 381     ast)
 382   (lambda (ast)
 383     ...))
 384
 385 (define-op2 '|six.x\|=y| '|x\|=y|
 386   type-rule-assign
 387   (lambda (ast)
 388     ast)
 389   (lambda (ast)
 390     ...))
 391
 392 (define-op2 'six.x:=y 'x:=y
 393   (lambda (ast)
 394     ...)
 395   (lambda (ast)
 396     ...)
 397   (lambda (ast)
 398     ...))
 399
 400 (define-op2 '|six.x,y| '|x,y|
 401   (lambda (ast)
 402     ...)
 403   (lambda (ast)
 404     ...)
 405   (lambda (ast)
 406     ...))
 407
 408 (define-op2 'six.x:-y 'x:-y
 409   (lambda (ast)
 410     ...)
 411   (lambda (ast)
 412     ...)
 413   (lambda (ast)
 414     ...))
 415
 416 (define (operation? source)
 417   (and (pair? source)
 418        (let ((x (car source)))
 419          (let loop ((lst operators))
 420            (cond ((null? lst)
 421                   #f)
 422                  ((eq? (op-six-id (car lst)) x)
 423                   (car lst))
 424                  (else
 425                   (loop (cdr lst))))))))