x86-64.l (29163B)
1 # 05jan13abu 2 # (c) Software Lab. Alexander Burger 3 4 # Byte order 5 (on *LittleEndian) 6 (off *AlignedCode) 7 8 # Register assignments 9 (de *Registers 10 (A . "%rax") (C . "%rdx") (E . "%rbx") 11 (B . "%al") (D "%rax" . "%rdx") 12 (X . "%r13") (Y . "%r14") (Z . "%r15") 13 (L . "%rbp") (S . "%rsp") 14 (F . T) ) 15 # NULL: %r12 16 # Temporary: %r10 %r11 17 # Block operations: %rcx %rsi %rdi 18 # C arguments: %rdi %rsi %rdx %rcx %r8 %r9 19 20 # Addressing modes 21 (de byteReg (Reg) 22 (cdr 23 (assoc Reg 24 (quote 25 ("%rax" . "%al") 26 ("%al" . "%al") 27 ("%rdx" . "%dl") 28 ("%rbx" . "%bl") 29 ("%r12" . "%r12b") 30 ("%r13" . "%r13b") 31 ("%r14" . "%r14b") 32 ("%r15" . "%r15b") 33 ("%rbp" . "%bpl") 34 ("%rsp" . "%spl") ) ) ) ) 35 36 (de byteVal (Adr) 37 (if (= "%r12" Adr) 38 "$0" # %r12b needs 3 bytes 39 (or 40 (byteReg Adr) # Register 41 Adr ) ) ) # Byte address 42 43 (de lowByte (Adr) 44 (or 45 (byteReg Adr) # Register 46 Adr ) ) # Word address 47 48 (de highWord (S) 49 (cond 50 ((= `(char "(") (char S)) 51 (pack "8" S) ) 52 ((>= `(char "9") (char S) `(char "0")) 53 (pack "8+" S) ) 54 (T (pack S "+8")) ) ) 55 56 (de immediate (Src) 57 (setq Src (chop Src)) 58 (when (= "$" (pop 'Src)) 59 (and (= "~" (car Src)) (pop 'Src)) 60 (format Src) ) ) 61 62 (de target (Adr F) 63 (if 64 (or 65 (not *FPic) 66 (= `(char ".") (char Adr)) # Local label ".1" 67 (let A (split (chop Adr) "_") # Local jump "foo_22" 68 (and 69 (cdr A) 70 (= *Label (pack (glue "_" (head -1 A)))) 71 (format (last A)) ) ) ) 72 Adr 73 (ifn F 74 (pack Adr "@plt") 75 (prinst "mov" (pack Adr "@GOTPCREL(%rip)") "%r10") 76 "(%r10)") ) ) 77 78 (de src (Src S) 79 (cond 80 ((=0 S) (if (= "0" Src) "%r12" (pack "$" Src))) # Immediate 81 ((not S) Src) # Register 82 ((=T S) # Direct 83 (if (and *FPic (not (pre? "(" Src))) 84 (pack Src "@GOTPCREL(%rip)") 85 (pack "$" Src) ) ) 86 ((not (car S)) 87 (ifn (and *FPic (=T (cdr S))) 88 (pack (cdr Src) "(" (car Src) ")") 89 (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") (car Src)) 90 (pack "(" (car Src) ")") ) ) 91 ((=T (car S)) 92 (ifn *FPic 93 (if (cdr S) 94 (pack (car Src) "+" (cdr Src)) 95 (car Src) ) 96 (prinst "mov" (pack (car Src) "@GOTPCREL(%rip)") "%r10") 97 (pack (cdr Src) "(%r10)") ) ) 98 (T 99 (prinst "mov" (src (car Src) (car S)) "%r10") 100 (ifn (and *FPic (=T (cdr S))) 101 (pack (cdr Src) "(%r10)") 102 (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") "%r10") 103 "(%r10)" ) ) ) ) 104 105 (de lea (Src S Reg) 106 (cond 107 ((not S) (prinst "mov" Src Reg)) # Register 108 ((=T S) (prinst "mov" (src Src T) Reg)) # Direct 109 ((not (car S)) 110 (cond 111 ((and *FPic (=T (cdr S))) 112 (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") (car Src)) 113 (prinst "mov" (pack "(" (car Src) ")") Reg) ) 114 ((cdr Src) 115 (prinst "lea" (pack (cdr Src) "(" (car Src) ")") Reg) ) 116 (T (prinst "mov" (car Src) Reg)) ) ) 117 ((=T (car S)) 118 (ifn *FPic 119 (prinst "lea" 120 (if (cdr S) 121 (pack (car Src) "+" (cdr Src)) 122 (car Src) ) 123 Reg ) 124 (prinst "mov" (pack (car Src) "@GOTPCREL(%rip)") Reg) 125 (prinst "lea" (pack (cdr Src) "(%r10)") Reg) ) ) 126 (T 127 (if (cdr S) 128 (prinst "lea" (src Src S) Reg) 129 (prinst "mov" (src (car Src) (car S)) Reg) ) ) ) ) 130 131 (de dst (Dst D) 132 (cond 133 ((not D) Dst) # Register 134 ((not (car D)) 135 (ifn (and *FPic (=T (cdr D))) 136 (pack (cdr Dst) "(" (car Dst) ")") 137 (prinst "add" (pack (cdr Dst) "@GOTPCREL(%rip)") (car Dst)) 138 (pack "(" (car Dst) ")") ) ) 139 ((=T (car D)) 140 (ifn *FPic 141 (if (cdr D) 142 (pack (car Dst) "+" (cdr Dst)) 143 (car Dst) ) 144 (prinst "mov" (pack (car Dst) "@GOTPCREL(%rip)") "%r11") 145 (pack (cdr Dst) "(%r11)") ) ) 146 (T 147 (prinst "mov" (dst (car Dst) (car D)) "%r11") 148 (ifn (and *FPic (=T (cdr D))) 149 (pack (cdr Dst) "(%r11)") 150 (prinst "add" (pack (cdr Dst) "@GOTPCREL(%rip)") "%r11") 151 "(%r11)" ) ) ) ) 152 153 (de dstSrc (Cmd Dst Src) 154 (cond 155 ((= "%al" Dst) 156 (prinst Cmd (byteVal Src) "%al") ) 157 ((= "%al" Src) 158 (prinst Cmd "%al" (byteVal Dst)) ) 159 ((and (immediate Src) (not (>= 2147483647 @ -2147483648))) 160 (prinst "mov" Src "%r10") 161 (prinst Cmd "%r10" Dst) ) 162 ((or (pre? "%" Src) (pre? "%" Dst)) 163 (prinst Cmd Src Dst) ) 164 ((pre? "$" Src) 165 (prinst (pack Cmd "q") Src Dst) ) 166 (T 167 (prinst "mov" Src "%r10") 168 (prinst Cmd "%r10" Dst) ) ) ) 169 170 (de dstSrcByte (Cmd Dst Src) 171 (if (>= 255 (immediate Src) 0) 172 (prinst (pack Cmd "b") Src (lowByte Dst)) 173 (dstSrc Cmd Dst Src) ) ) 174 175 (de dstDst (Cmd Dst Dst2) 176 (cond 177 ((= "%al" Dst) 178 (prinst Cmd (byteVal Dst2) "%al") ) 179 ((= "%al" Dst2) 180 (prinst Cmd "%al" (byteVal Dst)) ) 181 ((or (pre? "%" Dst) (pre? "%" Dst2)) 182 (prinst Cmd Dst2 Dst) ) 183 ((sub? "%r10" Dst2) 184 (prinst "mov" Dst "%r11") 185 (prinst Cmd "%r11" Dst2) 186 (prinst "mov" "%r11" Dst) ) 187 (T 188 (prinst "mov" Dst "%r10") 189 (prinst Cmd "%r10" Dst2) 190 (prinst "mov" "%r10" Dst) ) ) ) 191 192 (de dstShift (Cmd Dst Src) 193 (if (pre? "$" Src) 194 (prinst (pack Cmd (unless (pre? "%" Dst) "q")) Src Dst) 195 (prinst "mov" (byteVal Src) "%cl") 196 (prinst (pack Cmd (unless (pre? "%" Dst) "q")) "%cl" Dst) ) ) 197 198 ### Instruction set ### 199 (de alignSection (Align) 200 (prinst ".balign" 16) 201 ((; 'skip asm) Align) ) 202 203 (asm nop () 204 (prinst "nop") ) 205 206 (asm align (N) 207 (prinst ".balign" N) ) 208 209 (asm skip (N) 210 (if (== 'data *Section) 211 (or (=0 N) (prinst ".space" N)) 212 (do N (prinst "nop")) ) ) 213 214 # Move data 215 (asm ld (Dst D Src S) 216 (setq Dst (dst Dst D) Src (src Src S)) 217 (cond 218 ((= "%al" Dst) 219 (prinst "mov" (byteVal Src) "%al") ) 220 ((= "%al" Src) 221 (prinst "mov" "%al" (byteVal Dst)) ) 222 ((pair Dst) 223 (prinst "mov" Src (car Dst)) 224 (prinst "mov" (if (=0 S) "%r12" (highWord Src)) (cdr Dst)) ) 225 ((pair Src) 226 (prinst "mov" (car Src) Dst) 227 (prinst "mov" (cdr Src) (highWord Dst)) ) 228 ((or (pre? "%" Src) (pre? "%" Dst)) 229 (prinst "mov" Src Dst) ) 230 ((pre? "$" Src) 231 (prinst "movq" Src Dst) ) 232 (T 233 (prinst "mov" Src "%r10") 234 (prinst "mov" "%r10" Dst) ) ) ) 235 236 (asm ld2 (Src S) 237 (prinst "movzwq" (src Src S) "%rax") ) 238 239 (asm ld4 (Src S) 240 (prinst "mov" (src Src S) "%eax") ) # Clears upper word of %rax 241 242 (de _cmov (Cmd Jmp) 243 (setq Dst (dst Dst D) Src (src Src S)) 244 (when (pre? "$" Src) 245 (prinst "mov" Src "%r10") 246 (setq Src "%r10") ) 247 (if (pre? "%" Dst) 248 (prinst Cmd Src Dst) 249 (warn "Using suboptimal emulation code") 250 (prinst Jmp "1f") 251 (if (pre? "%" Src) 252 (prinst "mov" Src Dst) 253 (prinst "mov" Src "%r10") 254 (prinst "mov" "%r10" Dst) ) 255 (prinl "1:") ) ) 256 257 (asm ldc (Dst D Src S) 258 (_cmov "cmovcq" "jnc") ) 259 260 (asm ldnc (Dst D Src S) 261 (_cmov "cmovncq" "jc") ) 262 263 (asm ldz (Dst D Src S) 264 (_cmov "cmovzq" "jnz") ) 265 266 (asm ldnz (Dst D Src S) 267 (_cmov "cmovnzq" "jz") ) 268 269 (asm lea (Dst D Src S) 270 (setq Dst (dst Dst D) Src (src Src S)) 271 (if (pre? "%" Dst) 272 (prinst "lea" Src Dst) 273 (prinst "lea" Src "%r10") 274 (prinst "mov" "%r10" Dst) ) ) 275 276 (asm st2 (Dst D) 277 (prinst "mov" "%ax" (dst Dst D)) ) 278 279 (asm st4 (Dst D) 280 (prinst "mov" "%eax" (dst Dst D)) ) 281 282 (asm xchg (Dst D Dst2 D2) 283 (dstDst "xchg" (dst Dst D) (src Dst2 D2)) ) 284 285 (asm movn (Dst D Src S Cnt C) 286 (lea Dst D "%rdi") 287 (lea Src S "%rsi") 288 (prinst "mov" (src Cnt C) "%rcx") 289 (prinst "cld") 290 (prinst "rep movsb") ) 291 292 (asm mset (Dst D Cnt C) 293 (setq Dst (dst Dst D)) 294 (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rdi") 295 (prinst "mov" (src Cnt C) "%rcx") 296 (prinst "cld") 297 (prinst "rep stosb") ) 298 299 (asm movm (Dst D Src S End E) 300 (lea Dst D "%rdi") 301 (lea Src S "%rsi") 302 (lea End E "%rcx") 303 (prinst "sub" "%rsi" "%rcx") 304 (prinst "shr" "$3" "%rcx") 305 (prinst "cld") 306 (prinst "rep movsq") ) 307 308 (asm save (Src S End E Dst D) 309 (lea Src S "%rsi") 310 (lea End E "%rcx") 311 (lea Dst D "%rdi") 312 (prinst "sub" "%rsi" "%rcx") 313 (prinst "shr" "$3" "%rcx") 314 (prinst "cld") 315 (prinst "rep movsq") ) 316 317 (asm load (Dst D End E Src S) 318 (lea Dst D "%rdi") 319 (lea End E "%rcx") 320 (lea Src S "%rsi") 321 (prinst "sub" "%rdi" "%rcx") 322 (prinst "shr" "$3" "%rcx") 323 (prinst "cld") 324 (prinst "rep movsq") ) 325 326 # Arithmetics 327 (asm add (Dst D Src S) 328 (setq Dst (dst Dst D) Src (src Src S)) 329 (ifn (pair Dst) 330 (dstSrc "add" Dst Src) 331 (prinst "add" Src (car Dst)) 332 (prinst "adc" "%r12" (cdr Dst)) ) ) 333 334 (asm addc (Dst D Src S) 335 (setq Dst (dst Dst D) Src (src Src S)) 336 (ifn (pair Dst) 337 (dstSrc "adc" Dst Src) 338 (prinst "adc" Src (car Dst)) 339 (prinst "adc" "%r12" (cdr Dst)) ) ) 340 341 (asm sub (Dst D Src S) 342 (setq Dst (dst Dst D) Src (src Src S)) 343 (ifn (pair Dst) 344 (dstSrc "sub" Dst Src) 345 (prinst "sub" Src (car Dst)) 346 (prinst "sbb" "%r12" (cdr Dst)) ) ) 347 348 (asm subc (Dst D Src S) 349 (setq Dst (dst Dst D) Src (src Src S)) 350 (ifn (pair Dst) 351 (dstSrc "sbb" Dst Src) 352 (prinst "sbb" Src (car Dst)) 353 (prinst "sbb" "%r12" (cdr Dst)) ) ) 354 355 (asm inc (Dst D) 356 (if (pre? "%" (setq Dst (dst Dst D))) 357 (prinst "inc" Dst) 358 (prinst "incq" Dst) ) ) 359 360 (asm dec (Dst D) 361 (if (pre? "%" (setq Dst (dst Dst D))) 362 (prinst "dec" Dst) 363 (prinst "decq" Dst) ) ) 364 365 (asm not (Dst D) 366 (if (pre? "%" (setq Dst (dst Dst D))) 367 (prinst "not" Dst) 368 (prinst "notq" Dst) ) ) 369 370 (asm neg (Dst D) 371 (if (pre? "%" (setq Dst (dst Dst D))) 372 (prinst "neg" Dst) 373 (prinst "negq" Dst) ) ) 374 375 (asm and (Dst D Src S) 376 (dstSrc "and" (dst Dst D) (src Src S)) ) 377 378 (asm or (Dst D Src S) 379 (dstSrcByte "or" (dst Dst D) (src Src S)) ) 380 381 (asm xor (Dst D Src S) 382 (dstSrcByte "xor" (dst Dst D) (src Src S)) ) 383 384 (asm off (Dst D Src S) 385 (dstSrcByte "and" (dst Dst D) (src Src S)) ) 386 387 (asm test (Dst D Src S) 388 (dstSrcByte "test" (dst Dst D) (src Src S)) ) 389 390 (asm shl (Dst D Src S) 391 (dstShift "shl" (dst Dst D) (src Src S)) ) 392 393 (asm shr (Dst D Src S) 394 (dstShift "shr" (dst Dst D) (src Src S)) ) 395 396 (asm rol (Dst D Src S) 397 (dstShift "rol" (dst Dst D) (src Src S)) ) 398 399 (asm ror (Dst D Src S) 400 (dstShift "ror" (dst Dst D) (src Src S)) ) 401 402 (asm rcl (Dst D Src S) 403 (dstShift "rcl" (dst Dst D) (src Src S)) ) 404 405 (asm rcr (Dst D Src S) 406 (dstShift "rcr" (dst Dst D) (src Src S)) ) 407 408 (asm mul (Src S) 409 (ifn (pre? "$" (setq Src (src Src S))) 410 (prinst "mulq" Src) 411 (prinst "mov" Src "%r10") 412 (prinst "mul" "%r10") ) ) 413 414 (asm div (Src S) 415 (ifn (pre? "$" (setq Src (src Src S))) 416 (prinst "divq" Src) 417 (prinst "mov" Src "%r10") 418 (prinst "div" "%r10") ) ) 419 420 (asm zxt () # 8 bit -> 64 bit 421 (prinst "movzx" "%al" "%rax") ) 422 423 (asm setz () 424 (prinst "or" "%r12" "%r12") ) 425 426 (asm clrz () 427 (prinst "cmp" "%rsp" "%r12") ) 428 429 (asm setc () 430 (prinst "stc") ) 431 432 (asm clrc () 433 (prinst "clc") ) 434 435 # Comparisons 436 (asm cmp (Dst D Src S) 437 (dstSrc "cmp" (dst Dst D) (src Src S)) ) 438 439 (asm cmpn (Dst D Src S Cnt C) 440 (setq Dst (dst Dst D)) 441 (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rsi") 442 (lea Src S "%rdi") 443 (prinst "mov" (src Cnt C) "%rcx") 444 (prinst "cld") 445 (prinst "repnz cmpsb") ) 446 447 (asm slen (Dst D Src S) 448 (setq Dst (dst Dst D)) 449 (prinst "cld") 450 (prinst "xor" "%rcx" "%rcx") 451 (prinst "not" "%rcx") 452 (lea Src S "%rdi") 453 (prinst "xchg" "%al" "%r12b") 454 (prinst "repnz scasb") 455 (prinst "xchg" "%al" "%r12b") 456 (prinst "not" "%rcx") 457 (prinst "dec" "%rcx") 458 (prinst "mov" "%rcx" Dst) ) 459 460 (asm memb (Src S Cnt C) 461 (prinst "cld") 462 (lea Src S "%rdi") 463 (setq Cnt (src Cnt C)) 464 (prinst "mov" Cnt "%rcx") 465 (prinst "repnz scasb") 466 (unless S (prinst "cmovzq" "%rdi" Src)) 467 (unless C (prinst "cmovzq" "%rcx" Cnt)) ) 468 469 (asm null (Src S) 470 (prinst "cmp" "%r12" (src Src S)) ) 471 472 (asm nulp (Src S) 473 (prinst "cmp" "%r12" (src Src S)) ) 474 475 (asm nul4 () 476 (prinst "cmp" "%r12d" "%eax") ) 477 478 # Byte addressing 479 (asm set (Dst D Src S) 480 (setq Dst (dst Dst D) Src (src Src S)) 481 (cond 482 ((= "%r12" Src) 483 (prinst "mov" "%r12b" (lowByte Dst)) ) 484 ((or (pre? "$" Src) (pre? "%" Src) (pre? "%" Dst)) 485 (prinst "movb" Src Dst) ) 486 (T 487 (prinst "mov" Src "%r10b") 488 (prinst "mov" "%r10b" Dst) ) ) ) 489 490 (asm nul (Src S) 491 (prinst "cmp" "%r12b" (src Src S)) ) 492 493 # Types 494 (asm cnt (Src S) 495 (prinst "testb" "$0x02" (lowByte (src Src S))) ) 496 497 (asm big (Src S) 498 (prinst "testb" "$0x04" (lowByte (src Src S))) ) 499 500 (asm num (Src S) 501 (prinst "testb" "$0x06" (lowByte (src Src S))) ) 502 503 (asm sym (Src S) 504 (prinst "testb" "$0x08" (lowByte (src Src S))) ) 505 506 (asm atom (Src S) 507 (prinst "testb" "$0x0E" (lowByte (src Src S))) ) 508 509 # Flow Control 510 (asm call (Adr A) 511 (nond 512 (A # Absolute 513 (prinst "call" (target Adr)) ) 514 ((=T A) # Ignore SUBR 515 (prinst "call" (pack "*" Adr)) ) 516 (NIL # Indirect 517 (prinst "mov" (target Adr T) "%r10") 518 (prinst "call" "*%r10") ) ) ) 519 520 (asm jmp (Adr A) 521 (nond 522 (A (prinst "jmp" (target Adr))) 523 ((=T A) # Ignore SUBR 524 (prinst "jmp" (pack "*" Adr)) ) 525 (NIL 526 (prinst "mov" (target Adr T) "%r10") 527 (prinst "jmp" "*%r10") ) ) ) 528 529 (de _jmp (Opc Opc2) 530 (ifn A 531 (prinst Opc (target Adr)) 532 (prinst Opc2 "1f") 533 (ifn (=T A) # Ignore SUBR 534 (prinst "jmp" (pack "*" Adr)) 535 (prinst "mov" (target Adr T) "%r10") 536 (prinst "jmp" "*%r10") ) 537 (prinl "1:") ) ) 538 539 (asm jz (Adr A) 540 (_jmp "jz" "jnz") ) 541 542 (asm jeq (Adr A) 543 (_jmp "jz" "jnz") ) 544 545 (asm jnz (Adr A) 546 (_jmp "jnz" "jz") ) 547 548 (asm jne (Adr A) 549 (_jmp "jnz" "jz") ) 550 551 (asm js (Adr A) 552 (_jmp "js" "jns") ) 553 554 (asm jns (Adr A) 555 (_jmp "jns" "js") ) 556 557 (asm jsz (Adr A) 558 (_jmp "jle" "jg") ) 559 560 (asm jnsz (Adr A) 561 (_jmp "jg" "jle") ) 562 563 (asm jc (Adr A) 564 (_jmp "jc" "jnc") ) 565 566 (asm jlt (Adr A) 567 (_jmp "jc" "jnc") ) 568 569 (asm jnc (Adr A) 570 (_jmp "jnc" "jc") ) 571 572 (asm jge (Adr A) 573 (_jmp "jnc" "jc") ) 574 575 (asm jcz (Adr A) 576 (_jmp "jbe" "ja") ) 577 578 (asm jle (Adr A) 579 (_jmp "jbe" "ja") ) 580 581 (asm jncz (Adr A) 582 (_jmp "ja" "jbe") ) 583 584 (asm jgt (Adr A) 585 (_jmp "ja" "jbe") ) 586 587 (asm ret () 588 (unless 589 (and 590 (seek '((L) (== (cadr L) *Statement)) *Program) 591 (not (memq (caar @) '`(cons ': (cdr *Transfers)))) ) 592 (prinst "rep") ) 593 (prinst "ret") ) 594 595 # Floating point 596 (asm ldd () 597 (prinst "movsd" "(%rdx)" "%xmm0") ) 598 599 (asm ldf () 600 (prinst "movss" "(%rdx)" "%xmm0") ) 601 602 (asm fixnum () 603 (prinst "shr" "$4" "%rbx") # Normalize scale 604 (prinst "jc" "1f") # Jump if negative 605 (prinst "cvtsi2sd" "%rbx" "%xmm7") # Mulitply double with scale 606 (prinst "mulsd" "%xmm7" "%xmm0") 607 (prinst "cvtsd2si" "%xmm0" "%rbx") # Convert to integer 608 (prinst "jmp" "2f") 609 (prinl "1:") 610 (prinst "cvtsi2ss" "%rbx" "%xmm7") # Mulitply float with scale 611 (prinst "mulss" "%xmm7" "%xmm0") 612 (prinst "cvtss2si" "%xmm0" "%rbx") # Convert to integer 613 (prinl "2:") 614 (prinst "or" "%rbx" "%rbx") # Negative? 615 (prinst "js" "3f") # Yes: Skip 616 (prinst "shl" "$4" "%rbx") # Make positive short 617 (prinst "orb" "$2" "%bl") 618 (prinst "jmp" "5f") 619 (prinl "3:") 620 (prinst "neg" "%rbx") # Negate 621 (prinst "js" "4f") # Still negative: Overflow 622 (prinst "shl" "$4" "%rbx") # Make negative short 623 (prinst "orb" "$10" "%bl") 624 (prinst "jmp" "5f") 625 (prinl "4:") # Infinite/NaN 626 (prinst "mov" "$Nil" "%rbx") # Preload NIL 627 (prinst "xorpd" "%xmm7" "%xmm7") # Float value negative? 628 (prinst "ucomisd" "%xmm7" "%xmm0") 629 (prinst "jc" "5f") # Yes: Skip 630 (prinst "mov" "$TSym" "%rbx") # Load T 631 (prinl "5:") ) 632 633 (asm float () 634 (prinst "mov" "%rax" "%r10") # Normalize scale 635 (prinst "shr" "$4" "%r10") # Negative? 636 (prinst "jc" "3f") # Yes: Skip 637 (prinst "testb" "$0x02" "(%r13)") # Short fixnum? 638 (prinst "jz" "2f") # No: Skip 639 (prinst "cvtsi2sd" "%r10" "%xmm7") # Convert scale 640 (prinst "mov" "(%r13)" "%r10") # Normalize fixnum 641 (prinst "shr" "$4" "%r10") # Negative? 642 (prinst "jnc" "1f") # No: Skip 643 (prinst "neg" "%r10") # Else negate 644 (prinl "1:") 645 (prinst "cvtsi2sd" "%r10" "%xmm0") # Convert fixnum to double 646 (prinst "divsd" "%xmm7" "%xmm0") # Divide by scale 647 (prinst "jmp" "4f") # Done 648 (prinl "2:") 649 (prinst "cmpq" "$Nil" "(%r13)") # Minus infinite? 650 (prinst "mov" "$0x7FF0000000000000" "%r10") 651 (prinst "jnz" "1f") # No: Skip 652 (prinst "mov" "$0xFFF0000000000000" "%r10") 653 (prinl "1:") 654 (prinst "push" "%r10") 655 (prinst "movsd" "(%rsp)" "%xmm0") 656 (prinst "add" "$8" "%rsp") 657 (prinst "jmp" "4f") # Done 658 (prinl "3:") 659 (prinst "testb" "$0x02" "(%r13)") # Short fixnum? 660 (prinst "jz" "2f") # No: Skip 661 (prinst "cvtsi2ss" "%r10" "%xmm7") # Convert scale 662 (prinst "mov" "(%r13)" "%r10") # Normalize fixnum 663 (prinst "shr" "$4" "%r10") # Negative? 664 (prinst "jnc" "1f") # No: Skip 665 (prinst "neg" "%r10") # Else negate 666 (prinl "1:") 667 (prinst "cvtsi2ss" "%r10" "%xmm0") # Convert fixnum to float 668 (prinst "divss" "%xmm7" "%xmm0") # Divide by scale 669 (prinst "jmp" "4f") # Done 670 (prinl "2:") 671 (prinst "cmpq" "$Nil" "(%r13)") # Minus infinite? 672 (prinst "mov" "$0x7F800000" "%r10") 673 (prinst "jnz" "1f") 674 (prinst "mov" "$0xFF800000" "%r10") 675 (prinl "1:") 676 (prinst "push" "%r10") 677 (prinst "movss" "(%rsp)" "%xmm0") 678 (prinst "add" "$8" "%rsp") 679 (prinl "4:") ) 680 681 (asm std () 682 (prinst "movsd" "%xmm0" "(%r15)") ) 683 684 (asm stf () 685 (prinst "movss" "%xmm0" "(%r15)") ) 686 687 # C-Calls 688 (asm cc (Adr A Arg M) 689 (unless (== 'cc (caar (seek '((L) (== (cadr L) *Statement)) *Program))) 690 (prinst "mov" "%rdx" "%r12") ) 691 (let Reg '("%rdi" "%rsi" "%rdx" "%rcx" "%r8" "%r9") 692 (if (lst? Arg) 693 (let Lea NIL 694 (mapc 695 '((Src S) 696 (if (== '& Src) 697 (on Lea) 698 (unless (and (=0 S) (= "0" Src)) # Keep for 'xor' later 699 (setq Src 700 (src 701 (recur (Src) 702 (cond 703 ((= "%rdx" Src) "%r12") 704 ((atom Src) Src) 705 (T (cons (recurse (car Src)) (recurse (cdr Src)))) ) ) 706 S ) ) ) 707 (cond 708 ((and (=0 S) (= "0" Src)) 709 (prinst "xor" (car Reg) (pop 'Reg)) ) 710 ((= "$pop" Src) 711 (prinst "pop" (pop 'Reg)) ) 712 (T (prinst (if Lea "lea" "mov") Src (pop 'Reg))) ) 713 (off Lea) ) ) 714 (head 6 Arg) 715 (head 6 M) ) 716 (prinst "push" "%rbp") 717 (prinst "mov" "%rsp" "%rbp") 718 (when (nth Arg 7) # Maximally 6 args in registers 719 (prinst "sub" (pack "$" (* 8 (length @))) "%rsp") ) 720 (prinst "andb" "$~15" "%spl") # Align stack 721 (let Ofs 0 722 (mapc # 'Src' not lea or stack-relative here! 723 '((Src S) 724 (unless (and (=0 S) (= "0" Src)) # Keep for 'xor' later 725 (setq Src 726 (src 727 (recur (Src) 728 (cond 729 ((= "%rdx" Src) "%r12") 730 ((atom Src) Src) 731 (T (cons (recurse (car Src)) (recurse (cdr Src)))) ) ) 732 S ) ) ) 733 (ifn (and (=0 S) (= "0" Src)) 734 (prinst "movq" Src (pack Ofs "(%rsp)")) 735 (prinst "xor" "%rax" "%rax") 736 (prinst "movq" "%rax" (pack Ofs "(%rsp)")) ) 737 (inc 'Ofs 8) ) 738 (nth Arg 7) 739 (nth M 7) ) ) 740 # Don't use SSE registers in varargs for static calls 741 (when (member Adr '("printf" "fprintf" "snprintf" "open" "fcntl")) 742 (prinst "xor" "%al" "%al") ) ) 743 (prinst "mov" "%rsp" "%rax") # A on arguments 744 (prinst "push" "%rbp") # Link 745 (prinst "mov" "%rsp" "%rbp") 746 (prinst "mov" Arg "%rbx") 747 (prinst "sub" "%rax" "%rbx") # Size of arguments 748 (prinst "sub" "%rbx" "%rsp") # Allocate space 749 (prinst "andb" "$~15" "%spl") # Align stack 750 (prinst "mov" "%rsp" "%rbx") # E on stack space 751 (prinst "lea" "5f(%rip)" "%r11") 752 (mapc 753 '((R X) 754 (prinl "1:") 755 (prinst "cmp" "%rax" Arg) 756 (prinst "jz" "9f") 757 (prinst "mov" "(%rax)" "%r10") 758 (prinst "add" "$16" "%rax") 759 (prinst "or" "%r10" "%r10") 760 (prinst "jz" "7f") 761 (prinst "call" "*%r11") 762 (prinst "jmp" "1b") 763 (prinl "5:") 764 (unless (= R "%r9") 765 (prinst "lea" "(5f-5b)(%r11)" "%r11") ) 766 (prinst "shr" "$4" "%r10") 767 (prinst "jc" "3f") 768 (prinst "testb" "$0x02" "-8(%rax)") 769 (prinst "jz" "2f") 770 (prinst "cvtsi2sd" "%r10" "%xmm7") 771 (prinst "mov" "-8(%rax)" "%r10") 772 (prinst "shr" "$4" "%r10") 773 (prinst "jnc" "1f") 774 (prinst "neg" "%r10") 775 (prinl "1:") 776 (prinst "cvtsi2sd" "%r10" X) 777 (prinst "divsd" "%xmm7" X) 778 (prinst "ret") 779 (prinl "2:") 780 (prinst "cmpq" "$Nil" "-8(%rax)") 781 (prinst "mov" "$0x7FF0000000000000" "%r10") 782 (prinst "jnz" "1f") 783 (prinst "mov" "$0xFFF0000000000000" "%r10") 784 (prinl "1:") 785 (prinst "mov" "%r10" "-8(%rax)") 786 (prinst "movsd" "-8(%rax)" X) 787 (prinst "ret") 788 (prinl "3:") 789 (prinst "testb" "$0x02" "-8(%rax)") 790 (prinst "jz" "2f") 791 (prinst "cvtsi2ss" "%r10" "%xmm7") 792 (prinst "mov" "-8(%rax)" "%r10") 793 (prinst "shr" "$4" "%r10") 794 (prinst "jnc" "1f") 795 (prinst "neg" "%r10") 796 (prinl "1:") 797 (prinst "cvtsi2ss" "%r10" X) 798 (prinst "divss" "%xmm7" X) 799 (prinst "ret") 800 (prinl "2:") 801 (prinst "cmpq" "$Nil" "-8(%rax)") 802 (prinst "mov" "$0x7F800000" "%r10") 803 (prinst "jnz" "1f") 804 (prinst "mov" "$0xFF800000" "%r10") 805 (prinl "1:") 806 (prinst "mov" "%r10" "-8(%rax)") 807 (prinst "movss" "-8(%rax)" X) 808 (prinst "ret") 809 (prinl "7:") 810 (prinst "mov" "-8(%rax)" R) ) 811 Reg 812 '("%xmm0" "%xmm1" "%xmm2" "%xmm3" "%xmm4" "%xmm5") ) 813 (prinl "1:") 814 (prinst "cmp" "%rax" Arg) 815 (prinst "jz" "9f") 816 (prinst "mov" "8(%rax)" "%r10") 817 (prinst "add" "$16" "%rax") 818 (prinst "mov" "%r10" "(%rbx)") 819 (prinst "add" "$8" "%rbx") 820 (prinst "jmp 1b") 821 (prinl "9:") 822 # Maximally 6 SSE registers in varargs for dynamic calls 823 (prinst "mov" "$6" "%al") ) ) 824 ((get 'call 'asm) Adr A) 825 (prinst "mov" "%rbp" "%rsp") 826 (prinst "pop" "%rbp") 827 (unless (== 'cc (caadr (memq *Statement *Program))) 828 (prinst "mov" "%r12" "%rdx") 829 (prinst "xor" "%r12" "%r12") ) ) 830 831 (asm func ()) 832 833 (asm begin () 834 (prinst "call" "begin") ) 835 836 (asm return () 837 (prinst "jmp" "return") ) 838 839 # Stack Manipulations 840 (asm push (Src S) 841 (setq Src (src Src S)) 842 (cond 843 ((=T Src) (prinst "pushf")) 844 ((pre? "%" Src) (prinst "push" Src)) 845 (T (prinst "pushq" Src)) ) ) 846 847 (asm pop (Dst D) 848 (setq Dst (dst Dst D)) 849 (cond 850 ((=T Dst) (prinst "popf")) 851 ((pre? "%" Dst) (prinst "pop" Dst)) 852 (T (prinst "popq" Dst)) ) ) 853 854 (asm link () 855 (prinst "push" "%rbp") 856 (prinst "mov" "%rsp" "%rbp") ) 857 858 (asm tuck (Src S) 859 (setq Src (src Src S)) 860 (prinst "mov" "(%rsp)" "%rbp") 861 (if (or (pre? "$" Src) (pre? "%" Src)) 862 (prinst "movq" Src "(%rsp)") 863 (prinst "mov" Src "%r10") 864 (prinst "mov" "%r10" "(%rsp)") ) ) 865 866 (asm drop () 867 (prinst "mov" "(%rbp)" "%rsp") 868 (prinst "pop" "%rbp") ) 869 870 # Evaluation 871 (asm eval () 872 (prinst "test" "$0x06" "%bl") # Number? 873 (prinst "jnz" "1f") # Yes: Skip 874 (prinst "test" "$0x08" "%bl") # Symbol? 875 (prinst "cmovnzq" "(%rbx)" "%rbx") # Yes: Get value 876 (prinst "jnz" "1f") # and skip 877 (prinst "call" (target 'evListE_E)) # Else evaluate list 878 (prinl "1:") ) 879 880 (asm eval+ () 881 (prinst "test" "$0x06" "%bl") # Number? 882 (prinst "jnz" "1f") # Yes: Skip 883 (prinst "test" "$0x08" "%bl") # Symbol? 884 (prinst "cmovnzq" "(%rbx)" "%rbx") # Yes: Get value 885 (prinst "jnz" "1f") # and skip 886 (prinst "push" "%rbp") # Else 'link' 887 (prinst "mov" "%rsp" "%rbp") 888 (prinst "call" (target 'evListE_E)) # Evaluate list 889 (prinst "pop" "%rbp") 890 (prinl "1:") ) 891 892 (asm eval/ret () 893 (prinst "test" "$0x06" "%bl") # Number? 894 (prinst "jnz" "ret") # Yes: Return 895 (prinst "test" "$0x08" "%bl") # Symbol? 896 (prinst "jz" 'evListE_E) # No: Evaluate list 897 (prinst "mov" "(%rbx)" "%rbx") # Get value 898 (prinst "ret") ) 899 900 (asm exec (Reg) 901 (prinl "1:") # do 902 (prinst "mov" # ld E (R) 903 (pack "(" Reg ")") 904 "%rbx" ) 905 (prinst "test" "$0x0E" "%bl") # atom E 906 (prinst "jnz" "2f") 907 (prinst "call" (target 'evListE_E)) # evList 908 (prinl "2:") 909 (prinst "mov" # ld R (R CDR) 910 (pack "8(" Reg ")") 911 Reg ) 912 (prinst "testb" # atom R 913 "$0x0E" 914 (byteReg Reg) ) 915 (prinst "jz" "1b") ) # until nz 916 917 (asm prog (Reg) 918 (prinl "1:") # do 919 (prinst "mov" # ld E (R) 920 (pack "(" Reg ")") 921 "%rbx" ) 922 (prinst "test" "$0x06" "%bl") # eval 923 (prinst "jnz" "2f") 924 (prinst "test" "$0x08" "%bl") 925 (prinst "cmovnzq" "(%rbx)" "%rbx") 926 (prinst "jnz" "2f") 927 (prinst "call" (target 'evListE_E)) 928 (prinl "2:") 929 (prinst "mov" # ld R (R CDR) 930 (pack "8(" Reg ")") 931 Reg ) 932 (prinst "testb" # atom R 933 "$0x0E" 934 (byteReg Reg) ) 935 (prinst "jz" "1b") ) # until nz 936 937 # System 938 (asm initData ()) 939 940 (asm initCode () 941 (unless *FPic 942 (label "begin") 943 (prinst "pop" "%r10") # Get return address 944 (prinst "push" "%r15") # Z 945 (prinst "mov" "%r9" "%r15") 946 (prinst "push" "%r14") # Y 947 (prinst "mov" "%r8" "%r14") 948 (prinst "push" "%r13") # X 949 (prinst "mov" "%rcx" "%r13") 950 (prinst "push" "%r12") 951 (prinst "xor" "%r12" "%r12") # NULL register 952 (prinst "push" "%rbx") 953 (prinst "mov" "%rdx" "%rbx") # E 954 (prinst "mov" "%rsi" "%rdx") # C 955 (prinst "mov" "%rdi" "%rax") # A 956 (prinst "jmp" "*%r10") # Return 957 (prinl) 958 (label "return") 959 (prinst "pop" "%rbx") 960 (prinst "pop" "%r12") 961 (prinst "pop" "%r13") 962 (prinst "pop" "%r14") 963 (prinst "pop" "%r15") 964 (prinst "ret") ) ) 965 966 (asm initMain () 967 (prinst "xor" "%r12" "%r12") # Init NULL register 968 (prinst "mov" "(%rsi)" "%r13") # Get command in X 969 (prinst "lea" "8(%rsi)" "%r14") # argument vector in Y 970 (prinst "lea" "-8(%rsi,%rdi,8)" "%r15") ) # pointer to last argument in Z 971 972 (asm initLib ()) 973 974 ### Optimizer ### 975 # Replace the the next 'cnt' elements with 'lst' 976 (de optimize (Lst)) #> (cnt . lst) 977 978 ### Decoration ### 979 (de prolog (File)) 980 981 (de epilog (File)) 982 983 # vi:et:ts=3:sw=3