1;;; pb.ss 2 3;; The pb (portable bytecode) interpreter is implemented by "pb.c". 4;; The intent is that the machine uses 64-bit Scheme object 5;; representations and a runtime-determined endianness, so code 6;; compiled as portable bytecode can run on any machine (as long as 7;; the C compiler supports 64-bit integers for the kernel's 8;; implementation, where care is taken for the conversion between C 9;; pointers and Scheme object addresses). That way, a single set of pb 10;; boot files can be used to bootstrap the compiler for any supporrted 11;; platform. 12 13;; The pb machine can be configured (through ".def") for 32-bit Scheme 14;; object representations and a specific endianness, but that's not 15;; the main intended use. 16 17;; In all configurations, the pb machine uses 32-bit instructions. The 18;; fasl format of instructuctions is always little-endian, and the 19;; machine-code content is swapped on load for a big-endian 20;; environment. 21 22;; The pb binstruction set is load--store and vaguely similar to Arm. 23;; One difference is that there's a single flag for branching: 24;; signalling arithemtic, bitwise, and comparison operations set the 25;; flag for a specific condition, such as "overflow" or "equal", and 26;; the branch variants are "branch if true" or "branch if false". 27 28;; Each 32-bit instruction has one of these formats, shown in byte 29;; order for a little-endian machine: 30;; 31;; low byte high byte 32;; 8 8 8 8 33;; ----------------------------------------------- 34;; | op | reg | immed/reg | 35;; ----------------------------------------------- 36;; ----------------------------------------------- 37;; | op | reg reg | immed/reg | 38;; ----------------------------------------------- 39;; ----------------------------------------------- 40;; | op | reg | immed | 41;; ----------------------------------------------- 42;; ----------------------------------------------- 43;; | op | immed | 44;; ----------------------------------------------- 45;; 46;; Integer and floating-point registers (up to 16 of each) are 47;; different, and an `op` determines which bank is meant for a `reg` 48;; reference. The low-bits `reg` in the byte after the `op` tends to 49;; be the destination register. The long `immed` form is mainly for 50;; branches. See "cmacros.ss" for the `op` constructions. 51 52;; Foreign-procedure calls are supported only for specific prototypes, 53;; which are generally the ones for functions implemented the Chez 54;; Scheme kernel. Supported prototypes are specified in "cmacros.ss". 55;; Foreign callables are not supported. All foreign-call arguments and 56;; results are passed in registers. 57 58;;; SECTION 1: registers 59 60(define-registers 61 (reserved 62 [%tc #t 0 uptr] 63 [%sfp #t 1 uptr] 64 [%ap #t 2 uptr] 65 [%trap #t 3 uptr]) 66 (allocable 67 [%ac0 #f 4 uptr] 68 [%xp #f 5 uptr] 69 [%ts #f 6 uptr] 70 [%td #f 7 uptr] 71 [%cp #f 8 uptr] 72 [%r9 %Carg1 %Cretval #f 9 uptr] 73 [%r10 %Carg2 #f 10 uptr] 74 [%r11 %Carg3 #f 11 uptr] 75 [%r12 %Carg4 #f 12 uptr] 76 [%r13 %Carg5 #f 13 uptr] 77 [%r14 %Carg6 #f 14 uptr] 78 [%r15 %Carg7 #f 15 uptr] 79 [%fp1 #f 0 fp] 80 [%fp2 %Cfparg1 %Cfpretval #f 1 fp] 81 [%fp3 %Cfparg2 #f 2 fp] 82 [%fp4 %Cfparg3 #f 3 fp] 83 [%fp5 %Cfparg4 #f 4 fp] 84 [%fp6 %Cfparg5 #f 5 fp] 85 [%fp7 %Cfparg6 #f 6 fp] 86 [%fp8 #f 7 fp]) 87 (machine-dependent)) 88 89;;; SECTION 2: instructions 90(module (md-handle-jump ; also sets primitive handlers 91 mem->mem 92 fpmem->fpmem 93 coercible? 94 coerce-opnd) 95 (import asm-module) 96 97 (define imm-signed16? 98 (lambda (x) 99 (nanopass-case (L15c Triv) x 100 [(immediate ,imm) (signed16? imm)] 101 [else #f]))) 102 103 (define mref->mref 104 (lambda (a k) 105 (define return 106 (lambda (x0 x1 imm type) 107 ;; load & store instructions support index or offset, but not both 108 (safe-assert (or (eq? x1 %zero) (eqv? imm 0))) 109 (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type))))) 110 (nanopass-case (L15c Triv) a 111 [(mref ,lvalue0 ,lvalue1 ,imm ,type) 112 (lvalue->ur lvalue0 113 (lambda (x0) 114 (lvalue->ur lvalue1 115 (lambda (x1) 116 (cond 117 [(and (eq? x1 %zero) (signed16? imm)) 118 (return x0 %zero imm type)] 119 [(and (not (eq? x1 %zero)) (signed16? imm)) 120 (if (eqv? imm 0) 121 (return x0 x1 0 type) 122 (let ([u (make-tmp 'u)]) 123 (seq 124 (build-set! ,u (asm ,null-info ,(asm-add #f) ,x1 (immediate ,imm))) 125 (return x0 u 0 type))))] 126 [else 127 (let ([u (make-tmp 'u)]) 128 (seq 129 (build-set! ,u (immediate ,imm)) 130 (if (eq? x1 %zero) 131 (return x0 u 0 type) 132 (seq 133 (build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1)) 134 (return x0 u 0 type)))))])))))]))) 135 136 (define mem->mem 137 (lambda (a k) 138 (cond 139 [(literal@? a) 140 (let ([u (make-tmp 'u)]) 141 (seq 142 (build-set! ,u ,(literal@->literal a)) 143 (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))] 144 [else (mref->mref a k)]))) 145 146 (define fpmem->fpmem mem->mem) 147 148 ;; `define-instruction` code takes care of `ur` and `fpur`, to which 149 ;; all type-compatible values must convert 150 (define-syntax coercible? 151 (syntax-rules () 152 [(_ ?a ?aty*) 153 (let ([a ?a] [aty* ?aty*]) 154 (or (and (memq 'signed16 aty*) (imm-signed16? a)) 155 (and (memq 'mem aty*) (mem? a)) 156 (and (memq 'fpmem aty*) (fpmem? a))))])) 157 158 ;; `define-instruction` doesn't try to cover `ur` and `fpur` 159 (define-syntax coerce-opnd ; passes k something compatible with aty* 160 (syntax-rules () 161 [(_ ?a ?aty* ?k) 162 (let ([a ?a] [aty* ?aty*] [k ?k]) 163 (cond 164 [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)] 165 [(and (memq 'fpmem aty*) (fpmem? a)) (fpmem->fpmem a k)] 166 [(and (memq 'signed16 aty*) (imm-signed16? a)) (k (imm->imm a))] 167 [(or (memq 'ur aty*) 168 (memq 'fpur aty*)) 169 (cond 170 [(ur? a) (k a)] 171 [(imm? a) 172 (let ([u (make-tmp 'u)]) 173 (seq 174 (build-set! ,u ,(imm->imm a)) 175 (k u)))] 176 [(or (mem? a) (fpmem? a)) 177 (let ([type (if (fpmem? a) 'fp 'uptr)]) 178 (mem->mem a 179 (lambda (a) 180 (let ([u (make-tmp 'u type)]) 181 (seq 182 (build-set! ,u ,a) 183 (k u))))))] 184 [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])] 185 [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))])) 186 187 (define md-handle-jump 188 (lambda (t) 189 (with-output-language (L15d Tail) 190 (define long-form 191 (lambda (e) 192 (let ([tmp (make-tmp 'utmp)]) 193 (values 194 (in-context Effect `(set! ,(make-live-info) ,tmp ,e)) 195 `(jump ,tmp))))) 196 (nanopass-case (L15c Triv) t 197 [,lvalue 198 (if (mem? lvalue) 199 (mem->mem lvalue (lambda (e) (values '() `(jump ,e)))) 200 (values '() `(jump ,lvalue)))] 201 [(literal ,info) 202 (guard (and (not (info-literal-indirect? info)) 203 (memq (info-literal-type info) '(entry library-code)))) 204 (values '() `(jump (literal ,info)))] 205 [(label-ref ,l ,offset) 206 (values '() `(jump (label-ref ,l ,offset)))] 207 [else (long-form t)])))) 208 209 (define info-cc-eq (make-info-condition-code 'eq? #f #t)) 210 (define asm-eq (asm-relop info-cc-eq)) 211 212 ; x is not the same as z in any clause that follows a clause where (x z) 213 ; and y is coercible to one of its types, however: 214 ; WARNING: do not assume that if x isn't the same as z then x is independent 215 ; of z, since x might be an mref with z as it's base or index 216 217 (define-instruction value (- -/ovfl -/eq -/pos) 218 [(op (z ur) (x ur) (y signed16)) 219 `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub op) ,x ,y))] 220 [(op (z ur) (x ur) (y ur)) 221 `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub op) ,x ,y))]) 222 223 (define-instruction value (+ +/ovfl +/carry) 224 [(op (z ur) (x ur) (y signed16)) 225 `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))] 226 [(op (z ur) (x signed16) (y ur)) 227 `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))] 228 [(op (z ur) (x ur) (y ur)) 229 `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]) 230 231 (define-instruction value (* */ovfl) 232 [(op (z ur) (x ur) (y signed16)) 233 `(set! ,(make-live-info) ,z (asm ,info ,(asm-mul (memq op '(*/ovfl))) ,x ,y))] 234 [(op (z ur) (x signed16) (y ur)) 235 `(set! ,(make-live-info) ,z (asm ,info ,(asm-mul (memq op '(*/ovfl))) ,y ,x))] 236 [(op (z ur) (x ur) (y ur)) 237 `(set! ,(make-live-info) ,z (asm ,info ,(asm-mul (memq op '(*/ovfl))) ,x ,y))]) 238 239 (define-instruction value (/) 240 [(op (z ur) (x ur) (y ur)) 241 `(set! ,(make-live-info) ,z (asm ,info ,asm-div ,x ,y))]) 242 243 (define-instruction value (logand logor logxor) 244 [(op (z ur) (x ur) (y signed16)) 245 `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,x ,y))] 246 [(op (z ur) (x signed16) (y ur)) 247 `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,y ,x))] 248 [(op (z ur) (x ur) (y ur)) 249 `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,x ,y))]) 250 251 (define-instruction value (lognot) 252 [(op (z ur) (x ur)) 253 `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,x))]) 254 255 (define-instruction value (sll srl sra slol) 256 [(op (z ur) (x ur) (y signed16 ur)) 257 `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,x ,y))]) 258 259 (define-instruction value (move) 260 [(op (z mem) (x ur)) 261 `(set! ,(make-live-info) ,z ,x)] 262 [(op (z ur) (x ur mem signed16)) 263 `(set! ,(make-live-info) ,z ,x)]) 264 265 (let () 266 (define build-lea1 267 (lambda (info z x) 268 (let ([offset (info-lea-offset info)]) 269 (with-output-language (L15d Effect) 270 (cond 271 [(signed16? offset) 272 `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x (immediate ,offset)))] 273 [else 274 (let ([u (make-tmp 'u)]) 275 (seq 276 `(set! ,(make-live-info) ,u (immediate ,offset)) 277 `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x ,u))))]))))) 278 279 (define-instruction value lea1 280 [(op (z ur) (x ur)) (build-lea1 info z x)]) 281 282 (define-instruction value lea2 283 [(op (z ur) (x ur) (y ur)) 284 (let ([u (make-tmp 'u)]) 285 (seq 286 (build-lea1 info u x) 287 `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,y ,u))))])) 288 289 (let () 290 (define imm-zero (with-output-language (L15d Triv) `(immediate 0))) 291 (define load/store 292 (lambda (x y w k) ; x ur, y ur, w ur or imm 293 (with-output-language (L15d Effect) 294 (if (ur? w) 295 (if (eq? y %zero) 296 (k x w) 297 (let ([u (make-tmp 'u)]) 298 (seq 299 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w)) 300 (k x u)))) 301 (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) 302 (cond 303 [(and (eq? y %zero) (signed16? n)) 304 (let ([w (in-context Triv `(immediate ,n))]) 305 (k x w))] 306 [(eqv? n 0) 307 (k x y)] 308 [(signed16? n) 309 (let ([u (make-tmp 'u)]) 310 (seq 311 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,n))) 312 (k u y)))] 313 [else 314 (let ([u (make-tmp 'u)]) 315 (seq 316 `(set! ,(make-live-info) ,u (immediate ,n)) 317 (if (eq? y %zero) 318 (k x u) 319 (seq 320 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,u)) 321 (k u y)))))])))))) 322 (define-instruction value (load) 323 [(op (z ur) (x ur) (y ur) (w ur signed16)) 324 (let ([type (info-load-type info)]) 325 (load/store x y w 326 (lambda (x y) 327 (let ([instr `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-load type) ,x ,y))]) 328 (if (info-load-swapped? info) 329 (seq 330 instr 331 `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-swap type) ,z))) 332 instr)))))]) 333 (define-instruction effect (store) 334 [(op (x ur) (y ur) (w ur signed16) (z ur)) 335 (let ([type (info-load-type info)]) 336 (load/store x y w 337 (lambda (x y) 338 (if (info-load-swapped? info) 339 (let ([u (make-tmp 'unique-bob)]) 340 (seq 341 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-swap type) ,z)) 342 `(asm ,null-info ,(asm-store type) ,x ,y ,u))) 343 `(asm ,null-info ,(asm-store type) ,x ,y ,z)))))])) 344 345 (define-instruction value (load-single->double) 346 [(op (x fpur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,null-info ,asm-fpmove-single ,y))]) 347 348 (define-instruction effect (store-double->single) 349 [(op (x fpmem) (y fpur)) `(asm ,info ,asm-fpmove-single ,x ,y)]) 350 351 (define-instruction value (single->double double->single) 352 [(op (x fpur) (y fpur)) 353 `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))]) 354 355 (define-instruction value (fpt) 356 [(op (x fpur) (y ur)) 357 `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))]) 358 359 (define-instruction value (fptrunc) 360 [(op (x ur) (y fpur)) 361 `(set! ,(make-live-info) ,x (asm ,info ,asm-fptrunc ,y))]) 362 363 (define-instruction value (fpsingle) 364 [(op (x fpur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsingle ,y))]) 365 366 (define-instruction value (fpmove) 367 [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)] 368 [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)]) 369 370 (constant-case ptr-bits 371 [(64) 372 (let () 373 (define (mem->mem mem new-type) 374 (nanopass-case (L15d Triv) mem 375 [(mref ,x0 ,x1 ,imm ,type) 376 (with-output-language (L15d Lvalue) `(mref ,x0 ,x1 ,imm ,new-type))])) 377 378 (define-instruction value (fpcastto) 379 [(op (x mem) (y fpur)) `(set! ,(make-live-info) ,(mem->mem x 'fp) ,y)] 380 [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastto ,y))]) 381 382 (define-instruction value (fpcastfrom) 383 [(op (x fpmem) (y ur)) `(set! ,(make-live-info) ,(mem->mem x 'uptr) ,y)] 384 [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,y))]))] 385 [(32) 386 (let () 387 (define (mem->mem mem delta) 388 (nanopass-case (L15d Triv) mem 389 [(mref ,x0 ,x1 ,imm ,type) 390 (let ([delta (constant-case native-endianness 391 [(little) (if (eq? delta 'lo) 0 4)] 392 [(big) (if (eq? delta 'hi) 0 4)])]) 393 (with-output-language (L15d Lvalue) `(mref ,x0 ,x1 ,(fx+ imm delta) uptr)))])) 394 395 (define-instruction value (fpcastto/hi) 396 [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(mem->mem y 'hi))] 397 [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'hi) ,y))]) 398 399 (define-instruction value (fpcastto/lo) 400 [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(mem->mem y 'lo))] 401 [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'lo) ,y))]) 402 403 (define-instruction value (fpcastfrom) 404 [(op (x fpmem) (hi ur) (lo ur)) (seq 405 `(set! ,(make-live-info) ,(mem->mem x 'lo) ,lo) 406 `(set! ,(make-live-info) ,(mem->mem x 'hi) ,hi))] 407 [(op (x fpur) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,lo ,hi))]))]) 408 409 (define-instruction value (fp+ fp- fp/ fp*) 410 [(op (x fpur) (y fpur) (z fpur)) 411 `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))]) 412 413 (define-instruction value (fpsqrt) 414 [(op (x fpur) (y fpur)) 415 `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))]) 416 417 (define-instruction pred (fp= fp< fp<=) 418 [(op (x fpur) (y fpur)) 419 (let ([info (make-info-condition-code op #f #f)]) 420 (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]) 421 422 (define-instruction effect (inc-cc-counter) 423 [(op (x ur) (w signed16) (z ur signed16)) 424 (let ([u (make-tmp 'u)]) 425 (seq 426 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,w)) 427 `(asm ,info ,asm-inc! ,u ,z)))]) 428 429 (define-instruction effect (inc-profile-counter) 430 [(op (x mem) (y signed16)) 431 (nanopass-case (L15d Triv) x 432 [(mref ,x0 ,x1 ,imm ,type) 433 (let ([u (make-tmp 'u)]) 434 (seq 435 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x0 ,(if (eq? x1 %zero) 436 `(immediate ,imm) 437 x1))) 438 `(asm ,info ,asm-inc! ,u ,y)))])]) 439 440 (define-instruction value (read-time-stamp-counter) 441 [(op (z ur)) `(set! ,(make-live-info) ,z (immediate 0))]) 442 443 (define-instruction value (read-performance-monitoring-counter) 444 [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (immediate 0))]) 445 446 (define-instruction value (asmlibcall) 447 [(op (z ur)) 448 (let ([u (make-tmp 'u)]) 449 (seq 450 `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) 451 `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info)) ,u ,(info-kill*-live*-live* info) ...))))]) 452 453 (define-instruction effect (asmlibcall!) 454 [(op) 455 (let ([u (make-tmp 'u)]) 456 (seq 457 `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) 458 `(asm ,info ,(asm-library-call! (info-asmlib-libspec info)) ,u ,(info-kill*-live*-live* info) ...)))]) 459 460 (define-instruction effect (c-simple-call) 461 [(op) 462 (let ([u (make-tmp 'u)]) 463 (seq 464 `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) 465 `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info)) ,u)))]) 466 467 (define-instruction pred (eq? u< < > <= >= logtest log!test) 468 [(op (y signed16) (x ur)) 469 (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #t #t))]) 470 (values '() `(asm ,info ,(asm-relop info) ,x ,y)))] 471 [(op (x ur) (y ur signed16)) 472 (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #f #t))]) 473 (values '() `(asm ,info ,(asm-relop info) ,x ,y)))]) 474 475 (define-instruction pred (condition-code) 476 [(op) (values '() `(asm ,info ,(asm-condition-code info)))]) 477 478 (define-instruction pred (type-check?) 479 [(op (x ur) (mask signed16 ur) (type signed16 ur)) 480 (let ([tmp (make-tmp 'u)]) 481 (values 482 (with-output-language (L15d Effect) 483 `(set! ,(make-live-info) ,tmp (asm ,null-info ,(asm-logical 'logand) ,x ,mask))) 484 `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))]) 485 486 (let () 487 (define (addr-reg x y w k) 488 (with-output-language (L15d Effect) 489 (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) 490 (cond 491 [(and (eq? y %zero) (fx= n 0)) 492 (k x)] 493 [else 494 (let ([u (make-tmp 'u)]) 495 (cond 496 [(eq? y %zero) 497 (seq 498 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,w)) 499 (k u))] 500 [(fx= n 0) 501 (seq 502 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y)) 503 (k u))] 504 [else 505 (seq 506 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y)) 507 `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,u ,w)) 508 (k u))]))])))) 509 510 (define-instruction pred (lock!) 511 [(op (x ur) (y ur) (w signed16)) 512 (addr-reg x y w (lambda (u) 513 (values '() `(asm ,info-cc-eq ,(asm-lock! info-cc-eq) ,u))))]) 514 515 (define-instruction effect (locked-incr!) 516 [(op (x ur) (y ur) (w signed16)) 517 (addr-reg x y w (lambda (u) 518 ;; signals on zero after increment 519 `(asm ,info ,asm-inc! ,u (immediate 1))))]) 520 (define-instruction effect (locked-decr!) 521 [(op (x ur) (y ur) (w signed16)) 522 (addr-reg x y w (lambda (u) 523 ;; signals on zero after decrement 524 `(asm ,info ,asm-inc! ,u (immediate -1))))]) 525 526 (define-instruction effect (cas) 527 [(op (x ur) (y ur) (w signed16) (old ur) (new ur)) 528 (addr-reg x y w (lambda (u) 529 ;; signals on successful swap 530 `(asm ,info ,asm-cas! ,u ,old ,new)))])) 531 532 (define-instruction effect (pause) 533 ;; NB: use sqrt or something like that? 534 [(op) '()]) 535 536 (define-instruction effect (c-call) 537 [(op (x ur) (y signed16)) `(asm ,info ,asm-indirect-call ,x ,y ,(info-kill*-live*-live* info) ...)]) 538 539 (define-instruction effect save-flrv 540 [(op) '()]) 541 542 (define-instruction effect restore-flrv 543 [(op) '()]) 544 545 (define-instruction effect (invoke-prelude) 546 [(op) '()]) 547) 548 549;;; SECTION 3: assembler 550(module asm-module (; required exports 551 asm-move asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump 552 asm-mul asm-div asm-add asm-sub asm-logical asm-lognot 553 asm-fp-relop asm-relop 554 asm-indirect-jump asm-literal-jump 555 asm-direct-jump asm-return-address asm-jump asm-conditional-jump 556 asm-indirect-call asm-condition-code 557 asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom 558 asm-fptrunc asm-fpsingle 559 asm-inc! asm-lock! asm-cas! 560 asm-fpop-2 asm-fpsqrt asm-c-simple-call 561 asm-return asm-c-return asm-size 562 asm-enter asm-foreign-call asm-foreign-callable 563 asm-kill 564 signed16?) 565 566 (define ax-register? 567 (case-lambda 568 [(x) (record-case x [(reg) r #t] [else #f])] 569 [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])])) 570 571 (define-who ax-ea-reg-code 572 (lambda (ea) 573 (record-case ea 574 [(reg) r (reg-mdinfo r)] 575 [else (sorry! who "ea=~s" ea)]))) 576 577 (define ax-reg? 578 (lambda (ea) 579 (record-case ea 580 [(reg) ignore #t] 581 [else #f]))) 582 583 (define ax-imm? 584 (lambda (ea) 585 (record-case ea 586 [(imm) ignore #t] 587 [else #f]))) 588 589 (define-who ax-imm-data 590 (lambda (ea) 591 (record-case ea 592 [(imm) (n) n] 593 [else (sorry! who "ax-imm-data ea=~s" ea)]))) 594 595 ; define-op sets up assembly op macros-- 596 ; the opcode and all other expressions are passed to the specified handler-- 597 (define-syntax define-op 598 (lambda (x) 599 (syntax-case x () 600 [(k op handler e ...) 601 (with-syntax ([op (construct-name #'k "asmop-" #'op)]) 602 #'(define-syntax op 603 (syntax-rules () 604 [(_ mneu arg (... ...)) 605 (handler 'mneu e ... arg (... ...))])))]))) 606 607 (define-syntax emit 608 (lambda (x) 609 (syntax-case x () 610 [(k op x ...) 611 (with-syntax ([emit-op (construct-name #'k "asmop-" #'op)]) 612 #'(emit-op op x ...))]))) 613 614 (define-op mov mov-op (constant pb-i->i)) 615 (define-op fpmov mov-op (constant pb-d->d)) 616 617 (define-op movzi movi-op #f) ; 16-bit immediate, shifted 618 (define-op movki movi-op #t) ; 16-bit immediate, shifted 619 620 (define-op add signal-bin-op (constant pb-add)) 621 (define-op sub signal-bin-op (constant pb-sub)) 622 (define-op mul signal-bin-op (constant pb-mul)) 623 (define-op div bin-op (constant pb-div)) 624 625 (define-op subz signal-bin-op (constant pb-subz)) ; signals on 0 instead of overflow 626 (define-op subp signal-bin-op (constant pb-subp)) ; signals on positive 627 628 (define-op land bin-op (constant pb-and)) 629 (define-op lior bin-op (constant pb-ior)) 630 (define-op lxor bin-op (constant pb-xor)) 631 (define-op lnot un-op (constant pb-not)) 632 633 (define-op lsl bin-op (constant pb-lsl)) 634 (define-op lsr bin-op (constant pb-lsr)) 635 (define-op asr bin-op (constant pb-asr)) 636 (define-op lslo bin-op (constant pb-lslo)) 637 638 (define-op rev rev-op) 639 640 (define-op eq cmp-op (constant pb-eq)) 641 (define-op lt cmp-op (constant pb-lt)) 642 (define-op gt cmp-op (constant pb-gt)) 643 (define-op le cmp-op (constant pb-le)) 644 (define-op ge cmp-op (constant pb-ge)) 645 (define-op ab cmp-op (constant pb-ab)) ; above: unsigned compare 646 (define-op bl cmp-op (constant pb-bl)) ; below: unsigned compare 647 (define-op cs cmp-op (constant pb-cs)) ; bits in common 648 (define-op cc cmp-op (constant pb-cc)) ; no bits in common 649 650 (define-op ld load-op) 651 (define-op st store-op) 652 653 (define-op fadd fp-bin-op (constant pb-add)) 654 (define-op fsub fp-bin-op (constant pb-sub)) 655 (define-op fmul fp-bin-op (constant pb-mul)) 656 (define-op fdiv fp-bin-op (constant pb-div)) 657 658 (define-op fpeq fp-cmp-op (constant pb-eq)) 659 (define-op fplt fp-cmp-op (constant pb-lt)) 660 (define-op fple fp-cmp-op (constant pb-le)) 661 662 (define-op fsqrt fp-un-op (constant pb-sqrt)) 663 664 (define-op mov.s->d mov-op (constant pb-s->d)) 665 (define-op mov.d->s mov-op (constant pb-d->s)) 666 (define-op mov.i->d mov-op (constant pb-i->d)) 667 (define-op mov.d->i mov-op (constant pb-d->i)) 668 669 (define-op mov.d->s->d mov-op (constant pb-d->s->d)) 670 671 ;; 64-bit versions 672 (define-op mov.i*>d mov-op (constant pb-i-bits->d-bits)) 673 (define-op mov.d*>i mov-op (constant pb-d-bits->i-bits)) 674 675 ;; 32-bit versions 676 (define-op mov.ii*>d mov2-op (constant pb-i-i-bits->d-bits)) 677 (define-op mov.d*l>i mov-op (constant pb-d-lo-bits->i-bits)) 678 (define-op mov.d*h>i mov-op (constant pb-d-hi-bits->i-bits)) 679 680 (define-op btrue branch-op (constant pb-true)) 681 (define-op bfals branch-op (constant pb-fals)) 682 (define-op b branch-op (constant pb-always)) 683 (define-op b* branch-indirect-op) 684 685 (define-op lock lock-op) 686 (define-op cas cas-op) 687 (define-op inc inc-op) 688 689 (define-op call call-op) 690 (define-op interp interp-op) 691 (define-op ret ret-op) 692 (define-op adr adr-op) ; use only for an address after an rpheader (or compact) 693 694 (define movi-op 695 (lambda (op keep? dest imm shift code*) 696 (emit-code (op dest imm shift code*) 697 (fx+ (constant pb-mov16) 698 (if keep? 699 (constant pb-keep-bits) 700 (constant pb-zero-bits)) 701 shift) 702 (ax-ea-reg-code dest) 703 imm))) 704 705 (define mov-op 706 (lambda (op mode dest src code*) 707 (emit-code (op dest src code*) 708 (fx+ (constant pb-mov) 709 mode) 710 (ax-ea-reg-code dest) 711 (ax-ea-reg-code src)))) 712 713 (define mov2-op 714 (lambda (op mode dest src0 src1 code*) 715 (emit-code (op dest src0 src1 code*) 716 (fx+ (constant pb-mov) 717 mode) 718 (ax-ea-reg-code dest) 719 (ax-ea-reg-code src0) 720 (ax-ea-reg-code src1)))) 721 722 (define signal-bin-op 723 (lambda (op opcode set-cc? dest src0 src1 code*) 724 (cond 725 [(ax-reg? src1) 726 (emit-code (op set-cc? dest src0 src1 code*) 727 (fx+ (constant pb-bin-op) 728 (if set-cc? 729 (constant pb-signal) 730 (constant pb-no-signal)) 731 opcode 732 (constant pb-register)) 733 (ax-ea-reg-code dest) 734 (ax-ea-reg-code src0) 735 (ax-ea-reg-code src1))] 736 [else 737 (emit-code (op set-cc? dest src0 src1 code*) 738 (fx+ (constant pb-bin-op) 739 (if set-cc? 740 (constant pb-signal) 741 (constant pb-no-signal)) 742 opcode 743 (constant pb-immediate)) 744 (ax-ea-reg-code dest) 745 (ax-ea-reg-code src0) 746 (ax-imm-data src1))]))) 747 748 (define bin-op 749 (lambda (op opcode dest src0 src1 code*) 750 (cond 751 [(ax-reg? src1) 752 (emit-code (op dest src0 src1 code*) 753 (fx+ (constant pb-bin-op) 754 (constant pb-no-signal) 755 opcode 756 (constant pb-register)) 757 (ax-ea-reg-code dest) 758 (ax-ea-reg-code src0) 759 (ax-ea-reg-code src1))] 760 [else 761 (emit-code (op dest src0 src1 code*) 762 (fx+ (constant pb-bin-op) 763 (constant pb-no-signal) 764 opcode 765 (constant pb-immediate)) 766 (ax-ea-reg-code dest) 767 (ax-ea-reg-code src0) 768 (ax-imm-data src1))]))) 769 770 (define un-op 771 (lambda (op opcode dest src code*) 772 (cond 773 [(ax-reg? src) 774 (emit-code (op dest src code*) 775 (fx+ (constant pb-un-op) 776 opcode 777 (constant pb-register)) 778 (ax-ea-reg-code dest) 779 (ax-ea-reg-code src))] 780 [else 781 (emit-code (op dest src code*) 782 (fx+ (constant pb-un-op) 783 opcode 784 (constant pb-immediate)) 785 (ax-ea-reg-code dest) 786 (ax-imm-data src))]))) 787 788 (define rev-op 789 (lambda (op size dest src code*) 790 (emit-code (op dest src code*) 791 (fx+ (constant pb-rev-op) 792 size 793 (constant pb-register)) 794 (ax-ea-reg-code dest) 795 (ax-ea-reg-code src)))) 796 797 (define cmp-op 798 (lambda (op opcode src0 src1 code*) 799 (cond 800 [(ax-reg? src1) 801 (emit-code (op src0 src1 code*) 802 (fx+ (constant pb-cmp-op) 803 opcode 804 (constant pb-register)) 805 (ax-ea-reg-code src0) 806 (ax-ea-reg-code src1))] 807 [else 808 (emit-code (op src0 src1 code*) 809 (fx+ (constant pb-cmp-op) 810 opcode 811 (constant pb-immediate)) 812 (ax-ea-reg-code src0) 813 (ax-imm-data src1))]))) 814 815 (define load-op 816 (lambda (op size dest src0 src1 code*) 817 (cond 818 [(ax-reg? src1) 819 (emit-code (op size dest src0 src1 code*) 820 (fx+ (constant pb-ld-op) 821 size 822 (constant pb-register)) 823 (ax-ea-reg-code dest) 824 (ax-ea-reg-code src0) 825 (ax-ea-reg-code src1))] 826 [else 827 (emit-code (op size dest src0 src1 code*) 828 (fx+ (constant pb-ld-op) 829 size 830 (constant pb-immediate)) 831 (ax-ea-reg-code dest) 832 (ax-ea-reg-code src0) 833 (ax-imm-data src1))]))) 834 835 (define store-op 836 (lambda (op size dest0 dest1 src code*) 837 (cond 838 [(ax-reg? dest1) 839 (emit-code (op size dest0 dest1 src code*) 840 (fx+ (constant pb-st-op) 841 size 842 (constant pb-register)) 843 (ax-ea-reg-code src) 844 (ax-ea-reg-code dest0) 845 (ax-ea-reg-code dest1))] 846 [else 847 (emit-code (op size dest0 dest1 src code*) 848 (fx+ (constant pb-st-op) 849 size 850 (constant pb-immediate)) 851 (ax-ea-reg-code src) 852 (ax-ea-reg-code dest0) 853 (ax-imm-data dest1))]))) 854 855 (define fp-bin-op 856 (lambda (op opcode dest src0 src1 code*) 857 (emit-code (op dest src0 src1 code*) 858 (fx+ (constant pb-fp-bin-op) 859 opcode 860 (constant pb-register)) 861 (ax-ea-reg-code dest) 862 (ax-ea-reg-code src0) 863 (ax-ea-reg-code src1)))) 864 865 (define fp-un-op 866 (lambda (op opcode dest src code*) 867 (emit-code (op dest src code*) 868 (fx+ (constant pb-fp-un-op) 869 opcode 870 (constant pb-register)) 871 (ax-ea-reg-code dest) 872 (ax-ea-reg-code src)))) 873 874 (define fp-cmp-op 875 (lambda (op opcode src0 src1 code*) 876 (emit-code (op src0 src1 code*) 877 (fx+ (constant pb-fp-cmp-op) 878 opcode 879 (constant pb-register)) 880 (ax-ea-reg-code src0) 881 (ax-ea-reg-code src1)))) 882 883 (define-who branch-op 884 (lambda (op sel addr code*) 885 (record-case addr 886 [(reg) r 887 (emit-code (op sel addr code*) 888 (fx+ (constant pb-b-op) 889 sel 890 (constant pb-register)) 891 0 892 (reg-mdinfo r))] 893 [(imm) (n) 894 (emit-code (op sel addr code*) 895 (fx+ (constant pb-b-op) 896 sel 897 (constant pb-immediate)) 898 n)] 899 [(label) (offset l) 900 (emit-code (op sel addr code*) 901 (fx+ (constant pb-b-op) 902 sel 903 (constant pb-immediate)) 904 offset)] 905 [else 906 (sorry! who "unrecognized destination ~s" addr)]))) 907 908 (define branch-indirect-op 909 (lambda (op src0 src1 code*) 910 (cond 911 [(ax-reg? src1) 912 (emit-code (op src0 src1 code*) 913 (fx+ (constant pb-b*-op) 914 (constant pb-register)) 915 (ax-ea-reg-code src0) 916 (ax-ea-reg-code src1))] 917 [else 918 (emit-code (op src0 src1 code*) 919 (fx+ (constant pb-b*-op) 920 (constant pb-immediate)) 921 (ax-ea-reg-code src0) 922 (ax-imm-data src1))]))) 923 924 (define ret-op 925 (lambda (op code*) 926 (emit-code (op code*) 927 (constant pb-return) 928 0 929 0))) 930 931 (define call-op 932 (lambda (op dest proto code*) 933 (emit-code (op dest code*) 934 (constant pb-call) 935 (ax-ea-reg-code dest) 936 (ax-imm-data proto)))) 937 938 (define interp-op 939 (lambda (op dest code*) 940 (emit-code (op dest code*) 941 (constant pb-interp) 942 (ax-ea-reg-code dest) 943 0))) 944 945 (define adr-op 946 (lambda (op dest offset code*) 947 (emit-code (op dest offset code*) 948 (constant pb-adr) 949 (bitwise-ior (ax-ea-reg-code dest) 950 (bitwise-arithmetic-shift offset 4))))) 951 952 (define inc-op 953 (lambda (op dest src code*) 954 (cond 955 [(ax-reg? src) 956 (emit-code (op dest src code*) 957 (fx+ (constant pb-inc) 958 (constant pb-register)) 959 (ax-ea-reg-code dest) 960 (ax-ea-reg-code src))] 961 [else 962 (emit-code (op dest src code*) 963 (fx+ (constant pb-inc) 964 (constant pb-immediate)) 965 (ax-ea-reg-code dest) 966 (ax-imm-data src))]))) 967 968 (define lock-op 969 (lambda (op dest code*) 970 (emit-code (op dest code*) 971 (constant pb-lock) 972 (ax-ea-reg-code dest) 973 0))) 974 975 (define cas-op 976 (lambda (op dest src0 src1 code*) 977 (emit-code (op dest src0 src1 code*) 978 (constant pb-cas) 979 (ax-ea-reg-code dest) 980 (ax-ea-reg-code src0) 981 (ax-ea-reg-code src1)))) 982 983 (define-syntax emit-code 984 (lambda (x) 985 (syntax-case x () 986 [(_ (op opnd ... ?code*) chunk ...) 987 (let ([safe-check (lambda (e) 988 (if (fx= (debug-level) 0) 989 e 990 #`(let ([code #,e]) 991 (unless (<= 0 code (sub1 (expt 2 32))) 992 (sorry! 'emit-code "bad result ~s for ~s" 993 code 994 (list op opnd ...))) 995 code)))]) 996 #`(cons (build long #,(safe-check #`(byte-fields chunk ...))) 997 (aop-cons* `(asm ,op ,opnd ...) ?code*)))]))) 998 999 (define-syntax build 1000 (syntax-rules () 1001 [(_ x e) 1002 (and (memq (datum x) '(byte word long)) (integer? (datum e))) 1003 (begin 1004 (safe-assert (fixnum? (datum e))) 1005 (quote (x . e)))] 1006 [(_ x e) 1007 (memq (datum x) '(byte word long)) 1008 (cons 'x e)])) 1009 1010 (define-syntax byte-fields 1011 (syntax-rules () 1012 [(byte-fields op d r/i) 1013 (+ op 1014 (bitwise-arithmetic-shift-left d 8) 1015 (bitwise-arithmetic-shift-left (fxand r/i #xFFFF) 16))] 1016 [(byte-fields op d r r/i) 1017 (+ op 1018 (bitwise-arithmetic-shift-left d 8) 1019 (bitwise-arithmetic-shift-left r 12) 1020 (bitwise-arithmetic-shift-left (fxand r/i #xFFFF) 16))] 1021 [(byte-fields op i) 1022 (+ op 1023 (bitwise-arithmetic-shift-left (fxand i #xFFFFFF) 8))])) 1024 1025 (define signed16? 1026 (lambda (imm) 1027 (and (fixnum? imm) (fx<= (fx- (expt 2 15)) imm (fx- (expt 2 15) 1))))) 1028 1029 (define signed24? 1030 (lambda (imm) 1031 (and (fixnum? imm) (fx<= (fx- (expt 2 23)) imm (fx- (expt 2 23) 1))))) 1032 1033 (define asm-size 1034 (lambda (x) 1035 (case (car x) 1036 [(asm pb-abs pb-proc) 0] 1037 [(long) 4] 1038 [else (constant-case ptr-bits 1039 [(64) 8] 1040 [(32) 4])]))) 1041 1042 (define ax-mov64 1043 (lambda (dest n code*) 1044 (emit movzi dest (logand n #xffff) 0 1045 (emit movki dest (logand (bitwise-arithmetic-shift-right n 16) #xffff) 1 1046 (emit movki dest (logand (bitwise-arithmetic-shift-right n 32) #xffff) 2 1047 (emit movki dest (logand (bitwise-arithmetic-shift-right n 48) #xffff) 3 1048 code*)))))) 1049 1050 (define ax-movi 1051 (lambda (dest n code*) 1052 (let loop ([n n] [shift 0] [init? #t]) 1053 (cond 1054 [(or (eqv? n 0) (fx= shift 4)) 1055 (if init? 1056 ;; make sure 0 is installed 1057 (emit movzi dest 0 0 code*) 1058 code*)] 1059 [else 1060 (let ([m (logand n #xFFFF)]) 1061 (cond 1062 [(eqv? m 0) 1063 (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) init?)] 1064 [else 1065 (let ([code* (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) #f)]) 1066 (if init? 1067 (emit movzi dest m shift code*) 1068 (emit movki dest m shift code*)))]))])))) 1069 1070 (define-who asm-move 1071 (lambda (code* dest src) 1072 ;; move pseudo instruction used by set! case in select-instruction 1073 ;; guarantees dest is a reg and src is reg, mem, or imm OR dest is 1074 ;; mem and src is reg. 1075 (Trivit (dest src) 1076 (define (bad!) (sorry! who "unexpected combination of src ~s and dest ~s" src dest)) 1077 (cond 1078 [(ax-reg? dest) 1079 (record-case src 1080 [(reg) ignore (emit mov dest src code*)] 1081 [(imm) (n) 1082 (ax-movi dest n code*)] 1083 [(literal) stuff 1084 (ax-mov64 dest 0 1085 (asm-helper-relocation code* (cons 'pb-abs stuff)))] 1086 [(disp) (n breg) 1087 (safe-assert (signed16? n)) 1088 (emit ld (constant pb-int64) dest `(reg . ,breg) `(imm ,n) code*)] 1089 [(index) (n ireg breg) 1090 (safe-assert (eqv? n 0)) 1091 (emit ld (constant pb-int64) dest `(reg . ,breg) `(reg . ,ireg) code*)] 1092 [else (bad!)])] 1093 [(ax-reg? src) 1094 (record-case dest 1095 [(disp) (n breg) 1096 (safe-assert (signed16? n)) 1097 (emit st (constant pb-int64) `(reg . ,breg) `(imm ,n) src code*)] 1098 [(index) (n ireg breg) 1099 (safe-assert (eqv? n 0)) 1100 (emit st (constant pb-int64) `(reg . ,breg) `(reg . ,ireg) src code*)] 1101 [else (bad!)])] 1102 [else (bad!)])))) 1103 1104 (define asm-add 1105 (lambda (set-cc?) 1106 (lambda (code* dest src0 src1) 1107 (Trivit (dest src0 src1) 1108 (emit add set-cc? dest src0 src1 code*))))) 1109 1110 (define asm-sub 1111 (lambda (op) 1112 (lambda (code* dest src0 src1) 1113 (Trivit (dest src0 src1) 1114 (cond 1115 [(eq? op '-/eq) 1116 (emit subz #t dest src0 src1 code*)] 1117 [(eq? op '-/pos) 1118 (emit subp #t dest src0 src1 code*)] 1119 [else 1120 (emit sub (eq? op '-/ovfl) dest src0 src1 code*)]))))) 1121 1122 (define asm-mul 1123 (lambda (set-cc?) 1124 (lambda (code* dest src0 src1) 1125 (Trivit (dest src0 src1) 1126 (emit mul set-cc? dest src0 src1 code*))))) 1127 1128 (define asm-div 1129 (lambda (code* dest src0 src1) 1130 (Trivit (dest src0 src1) 1131 (emit div dest src0 src1 code*)))) 1132 1133 (define asm-logical 1134 (lambda (op) 1135 (lambda (code* dest src0 src1) 1136 (Trivit (dest src0 src1) 1137 (case op 1138 [(logand) (emit land dest src0 src1 code*)] 1139 [(logor) (emit lior dest src0 src1 code*)] 1140 [(logxor) (emit lxor dest src0 src1 code*)] 1141 [(sll) (emit lsl dest src0 src1 code*)] 1142 [(srl) (emit lsr dest src0 src1 code*)] 1143 [(sra) (emit asr dest src0 src1 code*)] 1144 [(slol) (emit lslo dest src0 src1 code*)] 1145 [else ($oops 'asm-logical "unexpected ~s" op)]))))) 1146 1147 (define asm-lognot 1148 (lambda (code* dest src) 1149 (Trivit (dest src) 1150 (emit lnot dest src code*)))) 1151 1152 (define-who asm-fl-cvt 1153 (lambda (op) 1154 (lambda (code* dest src) 1155 (Trivit (dest src) 1156 (case op 1157 [(single->double) 1158 (emit mov.s->d dest src code*)] 1159 [(double->single) 1160 (emit mov.d->s dest src code*)] 1161 [else (sorry! who "unrecognized op ~s" op)]))))) 1162 1163 (define-who asm-load 1164 (lambda (type) 1165 (lambda (code* dest base index/offset) 1166 (Trivit (dest base index/offset) 1167 (case type 1168 [(integer-64 unsigned-64) (emit ld (constant pb-int64) dest base index/offset code*)] 1169 [(integer-32) (emit ld (constant pb-int32) dest base index/offset code*)] 1170 [(unsigned-32) (emit ld (constant pb-uint32) dest base index/offset code*)] 1171 [(integer-16) (emit ld (constant pb-int16) dest base index/offset code*)] 1172 [(unsigned-16) (emit ld (constant pb-uint16) dest base index/offset code*)] 1173 [(integer-8) (emit ld (constant pb-int8) dest base index/offset code*)] 1174 [(unsigned-8) (emit ld (constant pb-uint8) dest base index/offset code*)] 1175 [(double) (emit ld (constant pb-double) dest base index/offset code*)] 1176 [(float) (emit ld (constant pb-single) dest base index/offset code*)] 1177 [else (sorry! who "unexpected mref type ~s" type)]))))) 1178 1179 (define-who asm-store 1180 (lambda (type) 1181 (lambda (code* base index/offset src) 1182 (Trivit (base index/offset src) 1183 (case type 1184 [(integer-64 unsigned-64) (emit st (constant pb-int64) base index/offset src code*)] 1185 [(integer-32 unsigned-32) (emit st (constant pb-int32) base index/offset src code*)] 1186 [(integer-16 unsigned-16) (emit st (constant pb-int16) base index/offset src code*)] 1187 [(integer-8 unsigned-8) (emit st (constant pb-int8) base index/offset src code*)] 1188 [(double) (emit st (constant pb-double) base index/offset src code*)] 1189 [(float) (emit st (constant pb-single) base index/offset src code*)] 1190 [else (sorry! who "unexpected mref type ~s" type)]))))) 1191 1192 (define-who asm-fpop-2 1193 (lambda (op) 1194 (lambda (code* dest src1 src2) 1195 (Trivit (dest src1 src2) 1196 (case op 1197 [(fp+) (emit fadd dest src1 src2 code*)] 1198 [(fp-) (emit fsub dest src1 src2 code*)] 1199 [(fp*) (emit fmul dest src1 src2 code*)] 1200 [(fp/) (emit fdiv dest src1 src2 code*)] 1201 [else (sorry! who "unrecognized op ~s" op)]))))) 1202 1203 (define asm-fpsqrt 1204 (lambda (code* dest src) 1205 (Trivit (dest src) 1206 (emit fsqrt dest src code*)))) 1207 1208 (define asm-fpsingle 1209 (lambda (code* dest src) 1210 (Trivit (dest src) 1211 (emit mov.d->s->d dest src code*)))) 1212 1213 (define asm-fptrunc 1214 (lambda (code* dest src) 1215 (Trivit (dest src) 1216 (emit mov.d->i dest src code*)))) 1217 1218 (define asm-fpt 1219 (lambda (code* dest src) 1220 (Trivit (dest src) 1221 (emit mov.i->d dest src code*)))) 1222 1223 (define-who asm-fpmove 1224 ;; fpmove pseudo instruction is used by set! case in 1225 ;; select-instructions! and generate-code; at most one of src or 1226 ;; dest can be an mref 1227 (lambda (code* dest src) 1228 (gen-fpmove who code* dest src #t))) 1229 1230 (define-who asm-fpmove-single 1231 (lambda (code* dest src) 1232 (gen-fpmove who code* dest src #f))) 1233 1234 (define gen-fpmove 1235 (lambda (who code* dest src double?) 1236 (Trivit (dest src) 1237 (record-case dest 1238 [(disp) (imm reg) 1239 (emit st (if double? (constant pb-double) (constant pb-single)) `(reg . ,reg) `(imm ,imm) src code*)] 1240 [(index) (n ireg breg) 1241 (emit st (if double? (constant pb-double) (constant pb-single)) `(reg . ,breg) `(reg . ,ireg) src code*)] 1242 [else 1243 (record-case src 1244 [(disp) (imm reg) 1245 (emit ld (if double? (constant pb-double) (constant pb-single)) dest `(reg . ,reg) `(imm ,imm) code*)] 1246 [(index) (n ireg breg) 1247 (emit ld (if double? (constant pb-double) (constant pb-single)) dest `(reg . ,breg) `(reg . ,ireg) code*)] 1248 [else (emit fpmov dest src code*)])])))) 1249 1250 (constant-case ptr-bits 1251 [(64) 1252 (define asm-fpcastto 1253 (lambda (code* dest src) 1254 (Trivit (dest src) 1255 (emit mov.d*>i dest src code*)))) 1256 1257 (define asm-fpcastfrom 1258 (lambda (code* dest src) 1259 (Trivit (dest src) 1260 (emit mov.i*>d dest src code*))))] 1261 [(32) 1262 (define asm-fpcastto 1263 (lambda (part) 1264 (lambda (code* dest src) 1265 (Trivit (dest src) 1266 (if (eq? part 'hi) 1267 (emit mov.d*h>i dest src code*) 1268 (emit mov.d*l>i dest src code*)))))) 1269 1270 (define asm-fpcastfrom 1271 (lambda (code* dest src-lo src-hi) 1272 (Trivit (dest src-lo src-hi) 1273 (emit mov.ii*>d dest src-lo src-hi code*))))]) 1274 1275 (define-who asm-swap 1276 (lambda (type) 1277 (lambda (code* dest src) 1278 (Trivit (dest src) 1279 (case type 1280 [(integer-64 unsigned-64) (emit rev (constant pb-int64) dest src code*)] 1281 [(integer-32) (emit rev (constant pb-int32) dest src code*)] 1282 [(unsigned-32) (emit rev (constant pb-uint32) dest src code*)] 1283 [(integer-16) (emit rev (constant pb-int16) dest src code*)] 1284 [(unsigned-16) (emit rev (constant pb-uint16) dest src code*)] 1285 [else (sorry! who "unexpected asm-swap type argument ~s" type)]))))) 1286 1287 (define asm-inc! 1288 (lambda (code* dest src) 1289 (Trivit (dest src) 1290 (emit inc dest src code*)))) 1291 1292 (define asm-lock! 1293 (lambda (info) 1294 (lambda (l1 l2 offset dest) 1295 (values 1296 (Trivit (dest) 1297 (emit lock dest '())) 1298 (asm-conditional-jump info l1 l2 offset))))) 1299 1300 (define asm-cas! 1301 (lambda (code* dest old new) 1302 (Trivit (dest old new) 1303 (emit cas dest old new code*)))) 1304 1305 (define-who asm-relop 1306 (lambda (info) 1307 (lambda (l1 l2 offset x y) 1308 (values 1309 (Trivit (x y) 1310 (define-syntax sel 1311 (lambda (stx) 1312 (syntax-case stx () 1313 [(_ pos neg) 1314 #`(if (info-condition-code-reversed? info) 1315 (emit neg x y '()) 1316 (emit pos x y '()))]))) 1317 (case (info-condition-code-type info) 1318 [(eq?) (emit eq x y '())] 1319 [(u<) (sel bl ab)] 1320 [(<) (sel lt gt)] 1321 [(>) (sel gt lt)] 1322 [(<=) (sel le ge)] 1323 [(>=) (sel ge le)] 1324 [(logtest) (emit cs x y '())] 1325 [(log!test) (emit cc x y '())] 1326 [else (sorry! who "unexpected ~s" (info-condition-code-type info))])) 1327 (asm-conditional-jump info l1 l2 offset))))) 1328 1329 (define-who asm-fp-relop 1330 (lambda (info) 1331 (lambda (l1 l2 offset x y) 1332 (Trivit (x y) 1333 (values 1334 (case (info-condition-code-type info) 1335 [(fp=) (emit fpeq x y '())] 1336 [(fp<) (emit fplt x y '())] 1337 [(fp<=) (emit fple x y '())] 1338 [else (sorry! who "unrecognized ~s" (info-condition-code-type info))]) 1339 (asm-conditional-jump info l1 l2 offset)))))) 1340 1341 (define asm-condition-code 1342 (lambda (info) 1343 (rec asm-check-flag-internal 1344 (lambda (l1 l2 offset) 1345 (values '() (asm-conditional-jump info l1 l2 offset)))))) 1346 1347 (define asm-library-jump 1348 (lambda (l) 1349 (asm-helper-jump '() 1350 `(pb-proc ,(constant code-data-disp) (library-code ,(libspec-label-libspec l)))))) 1351 1352 (define asm-library-call 1353 (lambda (libspec) 1354 (let ([target `(pb-proc ,(constant code-data-disp) (library-code ,libspec))]) 1355 (lambda (code* dest jmptmp . ignore) 1356 (asm-helper-call code* jmptmp #t target))))) 1357 1358 (define asm-library-call! 1359 (lambda (libspec) 1360 (let ([target `(pb-proc ,(constant code-data-disp) (library-code ,libspec))]) 1361 (lambda (code* jmptmp . ignore) 1362 (asm-helper-call code* jmptmp #t target))))) 1363 1364 (define asm-c-simple-call 1365 (lambda (entry) 1366 (let ([target `(pb-proc 0 (entry ,entry))]) 1367 (lambda (code* jmptmp . ignore) 1368 (asm-helper-call code* jmptmp #f target))))) 1369 1370 (define-who asm-indirect-call 1371 (lambda (code* dest proto . ignore) 1372 (Trivit (dest proto) 1373 (unless (ax-reg? dest) (sorry! who "unexpected dest ~s" dest)) 1374 (emit call dest proto code*)))) 1375 1376 (define asm-direct-jump 1377 (lambda (l offset) 1378 (let ([offset (adjust-return-point-offset offset l)]) 1379 (asm-helper-jump '() (make-funcrel 'pb-proc l offset))))) 1380 1381 (define asm-literal-jump 1382 (lambda (info) 1383 (asm-helper-jump '() 1384 `(pb-proc ,(info-literal-offset info) (,(info-literal-type info) ,(info-literal-addr info)))))) 1385 1386 (define-who asm-indirect-jump 1387 (lambda (src) 1388 (Trivit (src) 1389 (record-case src 1390 [(reg) ignore (emit b src '())] 1391 [(disp) (n breg) 1392 (assert (signed16? n)) 1393 (emit b* `(reg . ,breg) `(imm ,n) '())] 1394 [(index) (n ireg breg) 1395 (safe-assert (eqv? n 0)) 1396 (emit b* `(reg . ,breg) `(reg . ,ireg) '())] 1397 [else (sorry! who "unexpected src ~s" src)])))) 1398 1399 (define-who asm-return-address 1400 (lambda (dest l incr-offset next-addr) 1401 (make-rachunk dest l incr-offset next-addr 1402 (cond 1403 [(local-label-offset l) => 1404 (lambda (offset) 1405 (let ([incr-offset (adjust-return-point-offset incr-offset l)]) 1406 (let ([disp (fx- next-addr (fx- offset incr-offset))]) 1407 (unless (<= (- (expt 2 19)) disp (sub1 (expt 2 19))) 1408 (sorry! who "displacement to large for adr ~s" disp)) 1409 (emit adr `(reg . ,dest) disp '()))))] 1410 [else 1411 (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))])))) 1412 1413 (define-who asm-jump 1414 (lambda (l next-addr) 1415 (make-gchunk l next-addr 1416 (cond 1417 [(local-label-offset l) => 1418 (lambda (offset) 1419 (let ([disp (fx- next-addr offset)]) 1420 (cond 1421 [(eqv? disp 0) '()] 1422 [else 1423 (safe-assert (signed24? disp)) 1424 (emit b `(label ,disp ,l) '())])))] 1425 [else 1426 ;; label must be somewhere above. generate something so that a hard loop 1427 ;; doesn't get dropped. this also has some chance of being the right size 1428 ;; for the final branch instruction. 1429 (emit b `(label 0 ,l) '())])))) 1430 1431 (define-who asm-conditional-jump 1432 (lambda (info l1 l2 next-addr) 1433 (make-cgchunk info l1 l2 next-addr 1434 (let () 1435 (define get-disp-opnd 1436 (lambda (next-addr l) 1437 (if (local-label? l) 1438 (cond 1439 [(local-label-offset l) => 1440 (lambda (offset) 1441 (let ([disp (fx- next-addr offset)]) 1442 (safe-assert (signed24? disp)) 1443 (values disp `(label ,disp ,l))))] 1444 [else (values 0 `(label 0 ,l))]) 1445 (sorry! who "unexpected label ~s" l)))) 1446 1447 (let-values ([(disp1 opnd1) (get-disp-opnd next-addr l1)] 1448 [(disp2 opnd2) (get-disp-opnd next-addr l2)]) 1449 (cond 1450 [(fx= disp1 0) 1451 (emit bfals opnd2 '())] 1452 [(fx= disp2 0) 1453 (emit btrue opnd1 '())] 1454 [else 1455 (let-values ([(disp1 opnd1) (get-disp-opnd (fx+ next-addr 4) l1)]) 1456 (emit btrue opnd1 (emit b opnd2 '())))])))))) 1457 1458 (define asm-helper-jump 1459 (lambda (code* reloc) 1460 (let ([jmptmp (cons 'reg %ts)]) 1461 (ax-mov64 jmptmp 0 1462 (emit b jmptmp 1463 (asm-helper-relocation code* reloc)))))) 1464 1465 (define asm-helper-call 1466 (lambda (code* jmptmp interp? reloc) 1467 (ax-mov64 `(reg . ,jmptmp) 0 1468 (let ([code* (asm-helper-relocation code* reloc)]) 1469 (if interp? 1470 (emit interp `(reg . ,jmptmp) code*) 1471 (emit call `(reg . ,jmptmp) `(imm ,(constant pb-call-void)) code*)))))) 1472 1473 (define asm-helper-relocation 1474 (lambda (code* reloc) 1475 (cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*)))) 1476 1477 (define asm-return (lambda () (emit ret '()))) 1478 1479 (define asm-c-return (lambda (info) (emit ret '()))) 1480 1481 (define asm-enter values) 1482 1483 (define asm-kill 1484 (lambda (code* dest) 1485 code*)) 1486 1487 (module (asm-foreign-call asm-foreign-callable) 1488 (define int-argument-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6 %Carg7))) 1489 (define fp-argument-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6))) 1490 1491 (define prototypes (constant pb-prototype-table)) 1492 1493 (define-who asm-foreign-call 1494 (with-output-language (L13 Effect) 1495 (letrec ([load-double-reg 1496 (lambda (fpreg) 1497 (lambda (x) ; unboxed 1498 `(set! ,fpreg ,x)))] 1499 [load-int-reg 1500 (lambda (ireg) 1501 (lambda (x) 1502 `(set! ,ireg ,x)))] 1503 [load-two-int-regs 1504 (lambda (lo-ireg hi-ireg) 1505 (lambda (lo hi) 1506 `(seq 1507 (set! ,lo-ireg ,lo) 1508 (set! ,hi-ireg ,hi))))] 1509 [64-bit-type-on-32-bit? 1510 (lambda (type) 1511 (nanopass-case (Ltype Type) type 1512 [(fp-integer ,bits) 1513 (constant-case ptr-bits 1514 [(64) #f] 1515 [(32) (fx= bits 64)])] 1516 [(fp-integer ,bits) 1517 (constant-case ptr-bits 1518 [(64) #f] 1519 [(32) (fx= bits 64)])] 1520 [else #f]))] 1521 [do-args 1522 (lambda (in-types) 1523 (let loop ([types in-types] [locs '()] [live* '()] [int* (int-argument-regs)] [fp* (fp-argument-regs)]) 1524 (if (null? types) 1525 (values locs live*) 1526 (let ([type (car types)] 1527 [types (cdr types)]) 1528 (nanopass-case (Ltype Type) type 1529 [(fp-double-float) 1530 (when (null? fp*) (sorry! who "too many floating-point arguments")) 1531 (loop types 1532 (cons (load-double-reg (car fp*)) locs) 1533 (cons (car fp*) live*) 1534 int* (cdr fp*))] 1535 [(fp-single-float) 1536 (when (null? fp*) (sorry! who "too many floating-point arguments")) 1537 (loop types 1538 (cons (load-double-reg (car fp*)) locs) 1539 (cons (car fp*) live*) 1540 int* (cdr fp*))] 1541 [(fp-ftd& ,ftd) 1542 (sorry! who "indirect arguments no supported")] 1543 [else 1544 (when (null? int*) (sorry! who "too many integer/pointer arguments: ~s" (length in-types))) 1545 (cond 1546 [(64-bit-type-on-32-bit? type) 1547 (when (null? (cdr int*)) (sorry! who "too many integer/pointer arguments: ~s" (length in-types))) 1548 (loop types 1549 (cons (load-two-int-regs (car int*) (cadr int*)) locs) 1550 (cons* (cadr int*) (car int*) live*) 1551 (cddr int*) fp*)] 1552 [else 1553 (loop types 1554 (cons (load-int-reg (car int*)) locs) 1555 (cons (car int*) live*) 1556 (cdr int*) fp*)])])))))] 1557 [do-result 1558 (lambda (type) 1559 (nanopass-case (Ltype Type) type 1560 [(fp-double-float) 1561 (values (lambda (lvalue) ; unboxed 1562 `(set! ,lvalue ,%Cfpretval)) 1563 (list %Cfpretval))] 1564 [(fp-single-float) 1565 (values (lambda (lvalue) ; unboxed 1566 `(set! ,lvalue ,(%inline single->double ,%Cfpretval))) 1567 (list %Cfpretval))] 1568 [(fp-ftd& ,ftd) 1569 (sorry! who "unhandled result type ~s" type)] 1570 [else 1571 (when (64-bit-type-on-32-bit? type) 1572 (sorry! who "unhandled result type ~s" type)) 1573 (values (lambda (lvalue) `(set! ,lvalue ,%Cretval)) 1574 (list %Cretval))]))] 1575 [get-prototype 1576 (lambda (type*) 1577 (let* ([prototype 1578 (map (lambda (type) 1579 (nanopass-case (Ltype Type) type 1580 [(fp-double-float) 'double] 1581 [(fp-single-float) 'float] 1582 [(fp-integer ,bits) 1583 (constant-case ptr-bits 1584 [(64) (case bits 1585 [(8) 'int8] 1586 [(16) 'int16] 1587 [(32) 'int32] 1588 [else 'uptr])] 1589 [(32) (case bits 1590 [(8) 'int8] 1591 [(16) 'int16] 1592 [(32) 'uptr] 1593 [else 'int64])])] 1594 [(fp-unsigned ,bits) 1595 (constant-case ptr-bits 1596 [(64) (case bits 1597 [(8) 'uint8] 1598 [(16) 'uint16] 1599 [(32) 'uint32] 1600 [else 'uptr])] 1601 [(32) (case bits 1602 [(8) 'uint8] 1603 [(16) 'uint16] 1604 [(32) 'uptr] 1605 [else 'int64])])] 1606 [(fp-scheme-object) 'uptr] 1607 [(fp-fixnum) 'uptr] 1608 [(fp-u8*) 'void*] 1609 [(fp-void) 'void] 1610 [else (sorry! who "unhandled type in prototype ~s" type)])) 1611 type*)] 1612 [a (assoc prototype prototypes)]) 1613 (unless a 1614 (sorry! who "unsupported prototype ~a" prototype)) 1615 (cdr a)))]) 1616 (lambda (info) 1617 (let* ([arg-type* (info-foreign-arg-type* info)] 1618 [result-type (info-foreign-result-type info)]) 1619 (let-values ([(locs arg-live*) (do-args arg-type*)] 1620 [(get-result result-live*) (do-result result-type)]) 1621 (values 1622 (lambda () `(nop)) 1623 (reverse locs) 1624 (lambda (t0 not-varargs?) 1625 (let ([info (make-info-kill*-live* (add-caller-save-registers result-live*) arg-live*)]) 1626 `(inline ,info ,%c-call ,t0 (immediate ,(get-prototype (cons result-type arg-type*)))))) 1627 get-result 1628 (lambda () `(nop))))))))) 1629 1630 (define-who asm-foreign-callable 1631 (lambda (info) 1632 (sorry! who "callables are not supported") 1633 (values 'c-init 'c-args 'c-result 'c-return)))) 1634) 1635