ppc64.l (49113B)
1 # 05jan13abu 2 # (c) Software Lab. Alexander Burger 3 4 # Byte order 5 (off *LittleEndian) 6 (on *AlignedCode) 7 8 # Register assignments 9 (de *Registers 10 (A . 3) (C . 14) (E . 15) 11 (B . -3) (D 3 . 14) 12 (X . 16) (Y . 17) (Z . 18) 13 (L . 19) (S . 1) 14 (F . T) ) 15 16 (de *TempRegs 17 27 28 29 30 ) 18 19 # TOC: 2 20 # C arguments: 3 - 10 21 # NULL: 20 22 # ONE: 21 23 # Data: 22 24 # Code: 23 25 # DllToc: 24 26 # Nil: 25 27 # Reserved: 26 28 # Carry flag: 31 29 30 # Temporary register 31 (de tmpReg @ 32 (let R (pop '(`(apply circ *TempRegs))) 33 (if (find lt0 (rest)) 34 (- R) 35 R ) ) ) 36 37 # Machine specific 38 (zero *DataPos *CodePos) 39 (off *DataLabels *CodeLabels *DataIndex *CodeIndex) 40 41 (redef label (Lbl Flg) 42 (ifn *FPic 43 (cond 44 ((== *Section 'data) 45 (push '*DataLabels (cons Lbl *DataPos)) ) 46 ((== *Section 'text) 47 (unless (pre? "." Lbl) 48 (push '*CodeLabels (cons Lbl *CodePos)) ) ) ) 49 (when (and Flg (== *Section 'text) (n0 *CodePos) (upp? Lbl)) 50 (prinst ".quad" ".TOC.@tocbase") ) ) 51 (label Lbl Flg) 52 (when (and *FPic Flg (== *Section 'text) (n0 *CodePos) (upp? Lbl)) 53 (prinst "mfctr" 11) 54 (prinst "subi" 11 11 2) 55 (prinst "ld" 24 "-8(11)") ) ) 56 57 (de asciiLen (Str) 58 (- (size (pack (replace (chop Str) "\\"))) 2) ) # Don't count double quotes 59 60 (redef prinst (Name . @) 61 (pass prinst Name) 62 (cond 63 ((== *Section 'data) 64 (inc '*DataPos 65 (case Name 66 (".balign" 67 (if (gt0 (% *DataPos (next))) 68 (- (arg) @) 69 0 ) ) 70 (".quad" 8) 71 (".byte" 72 (if (num? (next)) 73 1 74 (length (split (chop (arg)) ",")) ) ) 75 (".short" 76 (if (num? (next)) 77 2 78 (* 2 (length (split (chop (arg)) ","))) ) ) 79 (".space" (next)) 80 (".ascii" (asciiLen (next))) 81 (".asciz" (inc (asciiLen (next)))) 82 (T (quit "Unknown data directive")) ) ) ) 83 ((== *Section 'text) 84 (inc '*CodePos 85 (case Name 86 (".quad" 24) # Function headers 87 (".balign" 88 (if (gt0 (% *CodePos (next))) 89 (- (arg) @) 90 0 ) ) 91 (T 4) ) ) ) ) ) 92 93 (de dataOffset (Sym) 94 (if (lup *DataIndex Sym) 95 (cdr @) 96 (pack Sym "-Data") ) ) 97 98 (de dataGot (Reg Sym) 99 (cond 100 ((lup *DataIndex Sym) 101 (prinst "la" Reg (pack (cdr @) "(22)")) ) 102 (*FPic (prinst "ld" Reg (pack Sym "@got(24)"))) 103 (T (prinst "ld" Reg (pack Sym "@got(2)"))) ) ) 104 105 (de codeCall (Sym) 106 (if (lup *CodeIndex Sym) 107 (prog 108 (prinst "mtctr" 23) 109 (prinst "bctrl") 110 (prinst ".int" (cdr @)) ) 111 (prinst "bl" "callRel") 112 (prinst ".int" (pack Sym "-.")) ) ) 113 114 # Addressing modes 115 (de checkOp (Fun) 116 (unless (Fun Op) 117 (quit "Illegal operation" *Statement) ) ) 118 119 (de opReg (Op Reg Ofs R) 120 (let Adr (pack Ofs "(" R ")") 121 (cond 122 ((lt0 Reg) 123 (checkOp bool) 124 (cond 125 ((=0 Op) 126 (if (= -3 Reg) 127 (let Byte (tmpReg) 128 (prinst "lbz" Byte Adr) 129 (prinst "insrdi" 3 Byte 8 56) ) 130 (prinst "lbz" (abs Reg) Adr) ) ) 131 ((=T Op) (prinst "stb" (abs Reg) Adr)) 132 (T (prinst Op (abs Reg) Adr)) ) ) 133 ((not Op) 134 (unless (and (=0 Ofs) (= Reg R)) 135 (prinst "la" Reg Adr) ) ) 136 ((=0 Op) (prinst "ld" Reg Adr)) 137 ((=T Op) (prinst "std" Reg Adr)) 138 (T (prinst Op Reg Adr)) ) 139 (cons Adr) ) ) 140 141 (de opxReg (Op Reg R R2) 142 (let Adr (pack R ", " R2) 143 (cond 144 ((lt0 Reg) 145 (checkOp bool) 146 (cond 147 ((=0 Op) 148 (if (= -3 Reg) 149 (let Byte (tmpReg) 150 (prinst "lbzx" Byte Adr) 151 (prinst "insrdi" 3 Byte 8 56) ) 152 (prinst "lbzx" (abs Reg) Adr) ) ) 153 ((=T Op) (prinst "stbx" (abs Reg) Adr)) 154 (T (prinst (pack Op "x") (abs Reg) Adr)) ) ) 155 ((not Op) (prinst "add" Reg Adr)) 156 ((=0 Op) (prinst "ldx" Reg R R2)) 157 ((=T Op) (prinst "stdx" Reg Adr)) 158 (T (prinst (pack Op "x") Reg Adr)) ) 159 (cons Adr "x") ) ) 160 161 (de mvReg (Dst Src) 162 (if (or (lt0 Dst) (lt0 Src)) 163 (prinst "insrdi" (abs Dst) (abs Src) 8 56) 164 (prinst "mr" Dst Src) ) ) 165 166 # Operation 'Op': 167 # NIL Lea 168 # 0 Fetch 169 # T Store 170 (de memory (Mem M Reg Op Tmp) #> ([adr [. "x"]]) 171 (cond 172 ((=0 M) # Immediate 173 (checkOp =0) 174 (if (= "0" Mem) 175 (if (lt0 Reg) 176 (prinst "insrdi" (abs Reg) 20 8 56) 177 (prinst "li" Reg 0) ) 178 (setq Mem 179 (if (pre? "~" Mem) 180 (x| `(hex "FFFFFFFFFFFFFFFF") (format (cdr (chop Mem)))) 181 (format Mem) ) ) 182 (cond 183 ((lt0 Reg) 184 (prinst "insrdi" (abs Reg) 20 8 56) 185 (prinst "ori" (abs Reg) (abs Reg) (& 255 Mem)) ) 186 ((>= 32767 Mem -32768) 187 (prinst "li" Reg Mem) ) 188 ((>= 2147483647 Mem -2147483648) 189 (prinst "lis" Reg (>> 16 Mem)) 190 (unless (=0 (setq Mem (& 65535 Mem))) 191 (prinst "ori" Reg Reg Mem) ) ) 192 (T 193 (let 194 (A (>> 48 Mem) 195 B (& 65535 (>> 32 Mem)) 196 C (& 65535 (>> 16 Mem)) 197 D (& 65535 Mem) ) 198 (prinst "lis" Reg A) 199 (unless (=0 B) 200 (prinst "ori" Reg Reg B) ) 201 (if (=0 C) 202 (prinst "sldi" Reg Reg 32) 203 (prinst "sldi" Reg Reg 16) 204 (prinst "ori" Reg Reg C) 205 (prinst "sldi" Reg Reg 16) ) 206 (unless (=0 D) 207 (prinst "ori" Reg Reg D) ) ) ) ) ) 208 NIL ) 209 ((not M) # Register 210 (cond 211 ((not Reg) (setq Reg Mem)) 212 ((= Mem Reg)) 213 ((not Op) (prinst "mr" Reg Mem)) 214 ((=0 Op) (mvReg Reg Mem)) 215 ((=T Op) (mvReg Mem Reg)) 216 (T (prinst Op Reg Mem)) ) 217 NIL ) 218 ((=T M) # Direct 219 (cond 220 ((sub? "-" Mem) # Label difference 221 (checkOp =0) 222 (prinst "li" Reg Mem) 223 NIL ) 224 ((== 'Nil Mem) (prinst "mr" Reg 25)) 225 ((or *FPic (low? Mem)) # -fpic or code label 226 (dataGot Reg Mem) ) 227 (T (opReg NIL Reg (dataOffset Mem) 22)) ) ) 228 ((not (car M)) # Indexed 229 (cond 230 ((not (cdr M)) (opReg Op Reg 0 (car Mem))) 231 ((=0 (cdr M)) 232 (if (>= 32767 (cdr Mem) -32768) 233 (opReg Op Reg (cdr Mem) (car Mem)) 234 (let R (or Tmp (tmpReg)) 235 (prinst "lis" R (>> 16 (cdr Mem))) 236 (unless (=0 (& 65535 (cdr Mem))) 237 (prinst "ori" R R (& 65535 (cdr Mem))) ) 238 (opxReg Op Reg R (car Mem)) ) ) ) 239 ((=T (cdr M)) 240 (cond 241 ((sub? "-" (cdr Mem)) # Label difference 242 (opReg Op Reg (cdr Mem) (car Mem)) ) 243 ((or *FPic (low? (cdr Mem))) # -fpic or code label 244 (let R (tmpReg) 245 (dataGot R (cdr Mem)) 246 (opxReg Op Reg R (car Mem)) ) ) 247 (T 248 (let R (tmpReg) 249 (prinst "la" R (pack (dataOffset (cdr Mem)) "(22)")) 250 (opxReg Op Reg R (car Mem)) ) ) ) ) ) ) 251 ((=T (car M)) # Indirect 252 (if (or *FPic (low? (car Mem))) # -fpic or code label 253 (let R (tmpReg) 254 (dataGot R (car Mem)) 255 (opReg Op Reg 0 R) ) 256 (opReg Op Reg 257 (pack 258 (and (cdr M) (pack (cdr Mem) "+")) 259 (dataOffset (car Mem)) ) 260 22 ) ) ) 261 (T # Combined 262 (let R (or Tmp (tmpReg)) 263 (memory (car Mem) (car M) R 0 R) 264 (opReg Op Reg (or (cdr Mem) 0) R) ) ) ) ) 265 266 (de memory2 (Cmd Reg Ref Ofs) 267 (prinst 268 (pack (if (lt0 Reg) "stb" Cmd) (cdr Ref)) 269 (abs Reg) 270 (if Ofs 271 (pack @ "+" (car Ref)) 272 (car Ref) ) ) ) 273 274 (de srcReg (Src S Tmp) #> reg 275 (cond 276 ((not S) 277 (ifn Tmp 278 Src 279 (prinst "mr" Tmp Src) 280 Tmp ) ) 281 ((= "0" Src) 282 (ifn Tmp 283 20 284 (prinst "li" Tmp 0) 285 Tmp ) ) 286 ((= "1" Src) 287 (ifn Tmp 288 21 289 (prinst "li" Tmp 1) 290 Tmp ) ) 291 ((== 'Nil Src) 292 (ifn Tmp 293 25 294 (prinst "mr" Tmp 25) 295 Tmp ) ) 296 (T 297 (prog1 (or Tmp (tmpReg)) 298 (memory Src S @ 0) ) ) ) ) 299 300 (de srcByteReg (Src S) #> reg 301 (cond 302 ((not S) 303 (prog1 (tmpReg) 304 (prinst "extrdi" @ (abs Src) 8 56) ) ) 305 ((n0 S) 306 (prog1 (tmpReg) 307 (memory Src S @ "lbz") ) ) 308 ((= "0" Src) 20) 309 ((= "1" Src) 21) 310 (T 311 (prog1 (tmpReg) 312 (prinst "li" @ 313 (if (pre? "~" Src) 314 (x| `(hex "FF") (format (cdr (chop Src)))) 315 (format Src) ) ) ) ) ) ) 316 317 (de dstReg (Dst D) #> (NIL dst adr [. "x"]) 318 (cond 319 (D 320 (let R (tmpReg) 321 (cons NIL R (memory Dst D R 0)) ) ) 322 ((= -3 Dst) 323 (let R (tmpReg) 324 (prinst "extrdi" R 3 8 56) 325 (cons NIL R -3) ) ) 326 (T (list NIL Dst)) ) ) 327 328 (de dstByteReg (Dst D) #> (T dst adr [. "x"]) 329 (cond 330 (D 331 (let R (tmpReg) 332 (cons T R (memory Dst D R "lbz")) ) ) 333 ((= -3 Dst) 334 (let R (tmpReg) 335 (prinst "extrdi" R 3 8 56) 336 (cons T R -3) ) ) 337 (T (list T Dst)) ) ) 338 339 (de dstSrcReg (Dst D Src S) #> (src flg dst adr [. "x"]) 340 (if (or (= -3 Dst) (= -3 Src)) 341 (cons 342 (srcByteReg Src S) 343 (dstByteReg Dst D) ) 344 (cons 345 (srcReg Src S) 346 (dstReg Dst D) ) ) ) 347 348 (de regDst (RegRef) 349 (cond 350 ((= -3 (cddr RegRef)) 351 (prinst "insrdi" 3 (cadr RegRef) 8 56) ) 352 ((car RegRef) # byte-flg 353 (when (cddr RegRef) 354 (memory2 "stb" (cadr RegRef) (cddr RegRef)) ) ) 355 ((cddr RegRef) 356 (memory2 "std" (cadr RegRef) (cddr RegRef)) ) ) ) 357 358 ### Instruction set ### 359 (de alignSection (Align) 360 (if (== *Section 'text) 361 (prinst ".balign" 8) 362 (prinst ".balign" 16) 363 (or (=0 Align) (prinst ".space" Align)) ) ) 364 365 (asm nop () 366 (prinst "nop") ) 367 368 (asm align (N) 369 (prinst ".balign" N) ) 370 371 (asm skip (N) 372 (if (== 'data *Section) 373 (or (=0 N) (prinst ".space" N)) 374 (do (/ N 2) (prinst "nop")) ) ) 375 376 (asm ld (Dst D Src S) 377 (cond 378 ((not D) 379 (ifn (= (3 . 14) Dst) 380 (memory Src S Dst 0) 381 (let A (memory Src S 3 0) # D 382 (prinst "ld" 14 (pack "8+" (car A))) ) ) ) 383 ((not S) 384 (ifn (= (3 . 14) Src) 385 (memory Dst D Src T) 386 (let A (memory Dst D 3 T) # D 387 (prinst "std" 14 (pack "8+" (car A))) ) ) ) 388 ((= "0" Src) (memory Dst D 20 T)) 389 ((= "1" Src) (memory Dst D 21 T)) 390 ((== 'Nil Src) (memory Dst D 25 T)) 391 (T 392 (let R (tmpReg) 393 (memory Src S R 0) 394 (memory Dst D R T) ) ) ) ) 395 396 (asm ld2 (Src S) 397 (memory Src S 3 "lhz") ) 398 399 (asm ld4 (Src S) 400 (memory Src S 3 "lwz") ) 401 402 (asm ldc (Dst D Src S) 403 (prinst "cmpdi" "cr1" 31 -2) 404 (prinst "beq-" "cr1" "1f") 405 (memory Src S Dst 0) 406 (prinl "1:") ) 407 408 (asm ldnc (Dst D Src S) 409 (prinst "cmpdi" "cr1" 31 -2) 410 (prinst "bne-" "cr1" "1f") 411 (memory Src S Dst 0) 412 (prinl "1:") ) 413 414 (asm ldz (Dst D Src S) 415 (prinst "bne-" "1f") 416 (memory Src S Dst 0) 417 (prinl "1:") ) 418 419 (asm ldnz (Dst D Src S) 420 (prinst "beq-" "1f") 421 (memory Src S Dst 0) 422 (prinl "1:") ) 423 424 (asm lea (Dst D Src S) 425 (ifn D 426 (memory Src S Dst) 427 (let R (tmpReg) 428 (memory Src S R) 429 (memory Dst D R T) ) ) ) 430 431 (asm st2 (Dst D) 432 (memory Dst D 3 "sth") ) 433 434 (asm st4 (Dst D) 435 (memory Dst D 3 "stw") ) 436 437 (asm xchg (Dst D Dst2 D2) 438 (let (Tmp (tmpReg Dst Dst2) A (memory Dst D Tmp 0)) # Tmp = Dst 439 (nond 440 (D 441 (if (memory Dst2 D2 Dst 0) # Dst = Dst2 442 (memory2 "std" Tmp @) # Dst2 = Tmp 443 (mvReg Dst2 Tmp) ) ) 444 (D2 445 (memory2 "std" Dst2 A) 446 (mvReg Dst2 Tmp) ) 447 (NIL 448 (let (R (tmpReg) B (memory Dst2 D2 R 0)) 449 (memory2 "std" R A) 450 (memory2 "std" Tmp B) ) ) ) ) ) 451 452 (asm movn (Dst D Src S Cnt C) 453 (memory Dst D 4) 454 (memory Src S 5) 455 (memory Cnt C 6 0) 456 (codeCall "movn") ) 457 458 (asm mset (Dst D Cnt C) 459 (memory Dst D 4) 460 (memory Cnt C 5 0) 461 (codeCall "mset") ) 462 463 (asm movm (Dst D Src S End E) 464 (memory Dst D 6) 465 (memory Src S 4) 466 (memory End E 5) 467 (codeCall "save") ) 468 469 (asm save (Src S End E Dst D) 470 (memory Src S 4) 471 (memory End E 5) 472 (memory Dst D 6) 473 (codeCall "save") ) 474 475 (asm load (Dst D End E Src S) 476 (memory Dst D 4) 477 (memory End E 5) 478 (memory Src S 6) 479 (codeCall "load") ) 480 481 # Arithmetics 482 (asm add (Dst D Src S) 483 (ifn (= (3 . 14) Dst) 484 (if (and (=0 S) (>= 32767 (format Src) -32768)) 485 (let A (dstReg Dst D) 486 (prinst "addic." (cadr A) (cadr A) Src) 487 (regDst A) ) 488 (let A (dstSrcReg Dst D Src S) 489 (prinst "addc." (caddr A) (caddr A) (car A)) 490 (regDst (cdr A)) ) ) 491 (if (and (=0 S) (>= 32767 (format Src) -32768)) 492 (prinst "addic" 3 3 Src) 493 (prinst "addc" 3 3 (srcReg Src S)) ) 494 (prinst "addze." 14 14) ) 495 (prinst "subfze" 31 21) ) # Set carry 496 497 (asmNoCC add (Dst D Src S) 498 (ifn (= (3 . 14) Dst) 499 (if (and (=0 S) (>= 32767 (format Src) -32768)) 500 (let A (dstReg Dst D) 501 (prinst "addi" (cadr A) (cadr A) Src) 502 (regDst A) ) 503 (let A (dstSrcReg Dst D Src S) 504 (prinst "add" (caddr A) (caddr A) (car A)) 505 (regDst (cdr A)) ) ) 506 (if (and (=0 S) (>= 32767 (format Src) -32768)) 507 (prinst "addic" 3 3 Src) 508 (prinst "addc" 3 3 (srcReg Src S)) ) 509 (prinst "addze" 14 14) ) ) 510 511 (asm addc (Dst D Src S) 512 (prinst "sradi" 0 31 1) # Get carry 513 (ifn (= (3 . 14) Dst) 514 (let A (dstSrcReg Dst D Src S) 515 (prinst "adde." (caddr A) (caddr A) (car A)) 516 (regDst (cdr A)) ) 517 (prinst "adde" 3 3 (srcReg Src S)) 518 (prinst "addze." 14 14) ) 519 (prinst "subfze" 31 21) ) # Set carry 520 521 (asmNoCC addc (Dst D Src S) 522 (prinst "sradi" 0 31 1) # Get carry 523 (ifn (= (3 . 14) Dst) 524 (let A (dstSrcReg Dst D Src S) 525 (prinst "adde" (caddr A) (caddr A) (car A)) 526 (regDst (cdr A)) ) 527 (prinst "adde" 3 3 (srcReg Src S)) 528 (prinst "adde" 14 14 20) ) ) 529 530 (asm sub (Dst D Src S) 531 (ifn (= (3 . 14) Dst) 532 (if (and (=0 S) (>= 32767 (format Src) -32768)) 533 (let A (dstReg Dst D) 534 (prinst "subic." (cadr A) (cadr A) Src) 535 (regDst A) ) 536 (let A (dstSrcReg Dst D Src S) 537 (prinst "subc." (caddr A) (caddr A) (car A)) 538 (regDst (cdr A)) ) ) 539 (if (and (=0 S) (>= 32767 (format Src) -32768)) 540 (prinst "subic" 3 3 Src) 541 (prinst "subc" 3 3 (srcReg Src S)) ) 542 (prinst "subfze." 14 14) ) 543 (prinst "subfme" 31 21) ) # Set inverted carry 544 545 (asmNoCC sub (Dst D Src S) 546 (ifn (= (3 . 14) Dst) 547 (if (and (=0 S) (>= 32767 (format Src) -32768)) 548 (let A (dstReg Dst D) 549 (prinst "subi" (cadr A) (cadr A) Src) 550 (regDst A) ) 551 (let A (dstSrcReg Dst D Src S) 552 (prinst "sub" (caddr A) (caddr A) (car A)) 553 (regDst (cdr A)) ) ) 554 (if (and (=0 S) (>= 32767 (format Src) -32768)) 555 (prinst "subic" 3 3 Src) 556 (prinst "subc" 3 3 (srcReg Src S)) ) 557 (prinst "subfze" 14 14) ) ) 558 559 (asm subc (Dst D Src S) 560 (prinst "xori" 0 31 1) # Get inverted carry 561 (prinst "sradi" 0 0 1) 562 (ifn (= (3 . 14) Dst) 563 (let A (dstSrcReg Dst D Src S) 564 (prinst "subfe." (caddr A) (car A) (caddr A)) 565 (regDst (cdr A)) ) 566 (prinst "sube" 3 3 (srcReg Src S)) 567 (prinst "subfze." 14 14) ) 568 (prinst "subfme" 31 21) ) # Set inverted carry 569 570 (asmNoCC subc (Dst D Src S) 571 (prinst "xori" 0 31 1) # Get inverted carry 572 (prinst "sradi" 0 0 1) 573 (ifn (= (3 . 14) Dst) 574 (let A (dstSrcReg Dst D Src S) 575 (prinst "subfe" (caddr A) (car A) (caddr A)) 576 (regDst (cdr A)) ) 577 (prinst "sube" 3 3 (srcReg Src S)) 578 (prinst "sube" 14 14 20) ) ) 579 580 (asm inc (Dst D) 581 (let A (dstReg Dst D) 582 (prinst "addic." (cadr A) (cadr A) 1) 583 (regDst A) ) ) 584 585 (asmNoCC inc (Dst D) 586 (let A (dstReg Dst D) 587 (prinst "addi" (cadr A) (cadr A) 1) 588 (regDst A) ) ) 589 590 (asm dec (Dst D) 591 (let A (dstReg Dst D) 592 (prinst "subic." (cadr A) (cadr A) 1) 593 (regDst A) ) ) 594 595 (asmNoCC dec (Dst D) 596 (let A (dstReg Dst D) 597 (prinst "subi" (cadr A) (cadr A) 1) 598 (regDst A) ) ) 599 600 (asm not (Dst D) 601 (let A (dstReg Dst D) 602 (prinst "not." (cadr A) (cadr A)) 603 (regDst A) ) ) 604 605 (asmNoCC not (Dst D) 606 (let A (dstReg Dst D) 607 (prinst "not" (cadr A) (cadr A)) 608 (regDst A) ) ) 609 610 (asm neg (Dst D) 611 (let A (dstReg Dst D) 612 (prinst "neg." (cadr A) (cadr A)) 613 (regDst A) ) ) 614 615 (asmNoCC neg (Dst D) 616 (let A (dstReg Dst D) 617 (prinst "neg" (cadr A) (cadr A)) 618 (regDst A) ) ) 619 620 (asm and (Dst D Src S) 621 (if (and (=0 S) (>= 65535 (format Src) 0)) 622 (let A (dstReg Dst D) 623 (prinst "andi." (cadr A) (cadr A) (format Src)) 624 (regDst A) ) 625 (let A (dstSrcReg Dst D Src S) 626 (prinst "and." (caddr A) (caddr A) (car A)) 627 (regDst (cdr A)) ) ) ) 628 629 (asmNoCC and (Dst D Src S) 630 (if (and (=0 S) (>= 65535 (format Src) 0)) 631 (let A (dstReg Dst D) 632 (prinst "andi." (cadr A) (cadr A) (format Src)) # 'and' doesn't exist 633 (regDst A) ) 634 (let A (dstSrcReg Dst D Src S) 635 (prinst "and" (caddr A) (caddr A) (car A)) 636 (regDst (cdr A)) ) ) ) 637 638 (asm or (Dst D Src S) 639 (let A (dstSrcReg Dst D Src S) 640 (prinst "or." (caddr A) (caddr A) (car A)) # 'ori.' doesn't exist 641 (regDst (cdr A)) ) ) 642 643 (asmNoCC or (Dst D Src S) 644 (if (and (=0 S) (>= 65535 (format Src) 0)) 645 (let A (dstReg Dst D) 646 (prinst "ori" (cadr A) (cadr A) (format Src)) 647 (regDst A) ) 648 (let A (dstSrcReg Dst D Src S) 649 (prinst "or" (caddr A) (caddr A) (car A)) 650 (regDst (cdr A)) ) ) ) 651 652 (asm xor (Dst D Src S) 653 (let A (dstSrcReg Dst D Src S) 654 (prinst "xor." (caddr A) (caddr A) (car A)) # 'xori.' doesn't exist 655 (regDst (cdr A)) ) ) 656 657 (asmNoCC xor (Dst D Src S) 658 (if (and (=0 S) (>= 65535 (format Src) 0)) 659 (let A (dstReg Dst D) 660 (prinst "xori" (cadr A) (cadr A) (format Src)) 661 (regDst A) ) 662 (let A (dstSrcReg Dst D Src S) 663 (prinst "xor" (caddr A) (caddr A) (car A)) 664 (regDst (cdr A)) ) ) ) 665 666 (asm off (Dst D Src S) 667 (let (A (dstReg Dst D) R (tmpReg)) 668 (prinst "li" R Src) 669 (prinst "and." (cadr A) (cadr A) R) 670 (regDst A) ) ) 671 672 (asm test (Dst D Src S) 673 (prinst "li" 31 -2) # Clear carry 674 (if (and (=0 S) (>= 65535 (format Src) 0)) 675 (let A (dstReg Dst D) 676 (prinst "andi." 0 (cadr A) (format Src)) ) 677 (let A (dstSrcReg Dst D Src S) 678 (prinst "and." 0 (caddr A) (car A)) ) ) ) 679 680 (asm shl (Dst D Src S) 681 (if (=0 S) 682 (let A (dstReg Dst D) 683 (when (gt0 (dec (format Src))) 684 (prinst "sldi" (cadr A) (cadr A) @) ) 685 (prinst "addc." (cadr A) (cadr A) (cadr A)) 686 (regDst A) 687 (prinst "subfze" 31 21) ) # Set carry from MSB 688 (let A (dstSrcReg Dst D Src S) 689 (prinst "sld." (caddr A) (caddr A) (car A)) # Ignore carry 690 (regDst (cdr A)) ) ) ) 691 692 (asmNoCC shl (Dst D Src S) 693 (if (=0 S) 694 (let A (dstReg Dst D) 695 (prinst "sldi" (cadr A) (cadr A) (format Src)) 696 (regDst A) ) 697 (let A (dstSrcReg Dst D Src S) 698 (prinst "sld" (caddr A) (caddr A) (car A)) 699 (regDst (cdr A)) ) ) ) 700 701 (asm shr (Dst D Src S) 702 (if (=0 S) 703 (let A (dstReg Dst D) 704 (when (gt0 (dec (format Src))) 705 (prinst "srdi" (cadr A) (cadr A) @) ) 706 (prinst "li" 31 -2) # Set carry from LSB 707 (prinst "insrdi" 31 (cadr A) 1 63) 708 (prinst "srdi." (cadr A) (cadr A) 1) 709 (regDst A) ) 710 (let A (dstSrcReg Dst D Src S) 711 (prinst "srd." (caddr A) (caddr A) (car A)) # Ignore carry 712 (regDst (cdr A)) ) ) ) 713 714 (asmNoCC shr (Dst D Src S) 715 (if (=0 S) 716 (let A (dstReg Dst D) 717 (prinst "srdi" (cadr A) (cadr A) (format Src)) 718 (regDst A) ) 719 (let A (dstSrcReg Dst D Src S) 720 (prinst "srd" (caddr A) (caddr A) (car A)) 721 (regDst (cdr A)) ) ) ) 722 723 (asm rol (Dst D Src S) 724 (if (=0 S) 725 (let A (dstReg Dst D) 726 (prinst "rotldi" (cadr A) (cadr A) (format Src)) 727 (regDst A) ) 728 (let A (dstSrcReg Dst D Src S) 729 (prinst "rotld" (caddr A) (caddr A) (car A)) 730 (regDst (cdr A)) ) ) ) 731 732 (asm ror (Dst D Src S) 733 (if (=0 S) 734 (let A (dstReg Dst D) 735 (prinst "rotrdi" (cadr A) (cadr A) (format Src)) 736 (regDst A) ) 737 (quit "Non-immediate 'ror' not available") ) ) 738 739 (asm rcl (Dst D Src S) 740 (if (=0 S) 741 (let A (dstReg Dst D) 742 (prinst "sradi" 0 31 1) # Get carry 743 (do (format Src) 744 (prinst "adde." (cadr A) (cadr A) (cadr A)) ) 745 (regDst A) 746 (prinst "subfze" 31 21) ) # Set carry 747 (quit "Non-immediate 'rcl' not available") ) ) 748 749 (asmNoCC rcl (Dst D Src S) 750 (if (=0 S) 751 (let A (dstReg Dst D) 752 (prinst "sradi" 0 31 1) # Get carry 753 (do (format Src) 754 (prinst "adde" (cadr A) (cadr A) (cadr A)) ) 755 (regDst A) ) 756 (quit "Non-immediate 'rcl' not available") ) ) 757 758 (asm rcr (Dst D Src S) 759 (if (=0 S) 760 (let A (dstReg Dst D) 761 (do (setq Src (format Src)) 762 (prinst "mr" 0 (cadr A)) 763 (prinst "rotrdi" (cadr A) (cadr A) 1) 764 (prinst "insrdi" (cadr A) 31 1 0) 765 (prinst "insrdi" 31 0 1 63) ) 766 (regDst A) ) 767 (quit "Non-immediate 'rcr' not available") ) ) 768 769 (asm mul (Src S) 770 (let R (srcReg Src S) 771 (prinst "mulhdu" 14 3 R) 772 (prinst "mulld" 3 3 R) ) ) 773 774 (asm div (Src S) 775 (srcReg Src S 4) 776 (codeCall "div") ) 777 778 (asm zxt () # 8 bit -> 64 bit 779 (prinst "andi." 3 3 255) ) # 'and' doesn't exist 780 781 (asm setz () 782 (prinst "addic." 0 20 0) ) # Add zero to null 783 784 (asm clrz () 785 (prinst "cmpdi" 1 0) ) # Compare stack pointer to zero 786 787 (asm setc () 788 (prinst "li" 31 -1) ) 789 790 (asm clrc () 791 (prinst "li" 31 -2) ) 792 793 # Comparisons 794 (asm cmp (Dst D Src S) 795 (if (and (=0 S) (>= 32767 (format Src) -32768)) 796 (let A (dstReg Dst D) 797 (prinst "subic." 0 (cadr A) Src) ) 798 (let A (dstSrcReg Dst D Src S) 799 (prinst "subc." 0 (caddr A) (car A)) ) ) 800 (prinst "subfme" 31 21) ) # Set inverted carry 801 802 (asm cmpn (Dst D Src S Cnt C) 803 (memory Dst D 4) 804 (memory Src S 5) 805 (memory Cnt C 6 0) 806 (codeCall "cmpn") ) 807 808 (asm slen (Dst D Src S) 809 (memory Src S 5) 810 (codeCall "slen") 811 (memory Dst D 4 T) ) 812 813 (asm memb (Src S Cnt C) 814 (memory Src S 4) 815 (memory Cnt C 5 0) 816 (codeCall "memb") 817 (unless S (prinst "mr" Src 4)) 818 (unless C (prinst "mr" Cnt 5)) ) 819 820 (asm null (Src S) 821 ##? (prinst "li" 31 -2) # Clear carry 822 (prinst "cmpdi" (srcReg Src S) 0) ) 823 824 (asm nulp (Src S) 825 (prinst "cmpdi" (srcReg Src S) 0) ) 826 827 (asm nul4 () 828 ##? (prinst "li" 31 -2) # Clear carry 829 (prinst "sldi" 3 3 32) 830 (prinst "sradi." 3 3 32) ) 831 832 # Byte addressing 833 (asm set (Dst D Src S) 834 (memory Dst D (srcByteReg Src S) "stb") ) 835 836 (asm nul (Src S) 837 ##? (prinst "li" 31 -2) # Clear carry 838 (prinst "cmpdi" (srcByteReg Src S) 0) ) 839 840 # Types 841 (asm cnt (Src S) 842 (prinst "andi." 0 (srcReg Src S) "0x02") ) 843 844 (asm big (Src S) 845 (prinst "andi." 0 (srcReg Src S) "0x04") ) 846 847 (asm num (Src S) 848 (prinst "andi." 0 (srcReg Src S) "0x06") ) 849 850 (asm sym (Src S) 851 (prinst "andi." 0 (srcReg Src S) "0x08") ) 852 853 (asm atom (Src S) 854 (prinst "andi." 0 (srcReg Src S) "0x0E") ) 855 856 # Flow Control 857 (asm call (Adr A) 858 (nond 859 (A # Absolute 860 (codeCall Adr) ) 861 ((=T A) # Indexed: Ignore SUBR 862 (prinst "mtctr" Adr) 863 (prinst "bl" "callCtr") ) 864 (NIL # Indirect 865 (prinst "ld" 11 (pack (dataOffset Adr) "(22)")) 866 (prinst "mtctr" 11) 867 (prinst "bl" "callCtr") ) ) ) 868 869 (de _jmp Args 870 (nond 871 (A 872 (let @Lbl Adr 873 (cond 874 ((lup *CodeIndex Adr) 875 (let Ofs (cdr @) 876 (if (>= 32767 Ofs) 877 (prinst "addi" 11 23 Ofs) 878 (prinst "lis" 11 (>> 16 Ofs)) 879 (unless (=0 (setq Ofs (& 65535 Ofs))) 880 (prinst "ori" 11 11 Ofs) ) 881 (prinst "add" 11 11 23) ) 882 (prinst "mtctr" 11) 883 (for E (caddr Args) 884 (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) ) 885 ((not (cadr Args)) 886 (for E (fill (car Args)) # b 887 (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) 888 (T 889 (let Back 890 (for (P *Program (n== *Statement (car P)) (cdr P)) 891 (T (and (== ': (caar P)) (= Adr (cdar P))) T) ) 892 (for E 893 (fill 894 ((if 895 (or 896 (= `(char ".") (char Adr)) # Local label 897 (and 898 (cdr (split (chop Adr) "_")) 899 (format (last @)) ) ) 900 car 901 cadr ) 902 Args ) ) 903 (apply prinst 904 (cons 905 (pack 906 (pop 'E) 907 (case (pop 'E) 908 ("+" (if Back "-" "+")) 909 ("-" (if Back "+" "-")) ) ) 910 E ) ) ) ) ) ) ) ) 911 ((=T A) # Ignore SUBR 912 (prinst "mtctr" Adr) 913 (for E (fill (caddr Args)) 914 (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) 915 (NIL # Indirect 916 (prinst "ld" 11 (pack (dataOffset Adr) "(22)")) 917 (prinst "mtctr" 11) 918 (for E (caddr Args) 919 (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) ) ) 920 921 (asm jmp (Adr A) 922 (_jmp 923 (("b" NIL @Lbl)) 924 NIL 925 (("bctr" NIL)) ) ) 926 927 (asm jz (Adr A) 928 (_jmp 929 (("beq" - @Lbl)) 930 (("bne" + ".+8") ("b" NIL @Lbl)) 931 (("beqctr" -)) ) ) 932 933 (asm jeq (Adr A) 934 (_jmp 935 (("beq" - @Lbl)) 936 (("bne" + ".+8") ("b" NIL @Lbl)) 937 (("beqctr" -)) ) ) 938 939 (asm jnz (Adr A) 940 (_jmp 941 (("bne" - @Lbl)) 942 (("beq" + ".+8") ("b" NIL @Lbl)) 943 (("bnectr" -)) ) ) 944 945 (asm jne (Adr A) 946 (_jmp 947 (("bne" - @Lbl)) 948 (("beq" + ".+8") ("b" NIL @Lbl)) 949 (("bnectr" -)) ) ) 950 951 (asm js (Adr A) 952 (_jmp 953 (("blt" - @Lbl)) 954 (("bge" + ".+8") ("b" NIL @Lbl)) 955 (("bltctr" -)) ) ) 956 957 (asm jns (Adr A) 958 (_jmp 959 (("bge" - @Lbl)) 960 (("blt" + ".+8") ("b" NIL @Lbl)) 961 (("bgectr" -)) ) ) 962 963 (asm jsz (Adr A) 964 (_jmp 965 (("ble" - @Lbl)) 966 (("bgt" + ".+8") ("b" NIL @Lbl)) 967 (("blectr" -)) ) ) 968 969 (asm jnsz (Adr A) 970 (_jmp 971 (("bgt" - @Lbl)) 972 (("ble" + ".+8") ("b" NIL @Lbl)) 973 (("bgtctr" -)) ) ) 974 975 (asm jc (Adr A) 976 (prinst "cmpdi" "cr1" 31 -2) 977 (_jmp 978 (("bne" - "cr1" @Lbl)) 979 (("beq" + "cr1" ".+8") ("b" NIL @Lbl)) 980 (("bnectr" - "cr1")) ) ) 981 982 (asm jlt (Adr A) 983 (prinst "cmpdi" "cr1" 31 -2) 984 (_jmp 985 (("bne" - "cr1" @Lbl)) 986 (("beq" + "cr1" ".+8") ("b" NIL @Lbl)) 987 (("bnectr" - "cr1")) ) ) 988 989 (asm jnc (Adr A) 990 (prinst "cmpdi" "cr1" 31 -2) 991 (_jmp 992 (("beq" - "cr1" @Lbl)) 993 (("bne" + "cr1" ".+8") ("b" NIL @Lbl)) 994 (("beqctr" - "cr1")) ) ) 995 996 (asm jge (Adr A) 997 (prinst "cmpdi" "cr1" 31 -2) 998 (_jmp 999 (("beq" - "cr1" @Lbl)) 1000 (("bne" + "cr1" ".+8") ("b" NIL @Lbl)) 1001 (("beqctr" - "cr1")) ) ) 1002 1003 (asm jcz (Adr A) 1004 (prinst "cmpdi" "cr1" 31 -2) 1005 (_jmp 1006 (("bne" - "cr1" @Lbl) ("beq" - @Lbl)) 1007 (("beq" - "cr1" ".+12") ("bne" + ".+8") ("b" NIL @Lbl)) 1008 (("bnectr" - "cr1") ("beqctr" -) ) ) ) 1009 1010 (asm jle (Adr A) 1011 (prinst "cmpdi" "cr1" 31 -2) 1012 (_jmp 1013 (("bne" - "cr1" @Lbl) ("beq" - @Lbl)) 1014 (("beq" - "cr1" ".+12") ("bne" + ".+8") ("b" NIL @Lbl)) 1015 (("bnectr" - "cr1") ("beqctr" -) ) ) ) 1016 1017 (asm jncz (Adr A) 1018 (prinst "cmpdi" "cr1" 31 -2) 1019 (_jmp 1020 (("bne" + "cr1" ".+8") ("bne" - @Lbl)) 1021 (("bne" + "cr1" ".+12") ("beq" + ".+8") ("b" NIL @Lbl)) 1022 (("bne" + "cr1" ".+8") ("bnectr" -)) ) ) 1023 1024 (asm jgt (Adr A) 1025 (prinst "cmpdi" "cr1" 31 -2) 1026 (_jmp 1027 (("bne" + "cr1" ".+8") ("bne" - @Lbl)) 1028 (("bne" + "cr1" ".+12") ("beq" + ".+8") ("b" NIL @Lbl)) 1029 (("bne" + "cr1" ".+8") ("bnectr" NIL)) ) ) 1030 1031 (asm ret () 1032 (prinst "blr") ) 1033 1034 # Floating point 1035 (asm ldd () 1036 (prinst "lfd" 1 "0(14)") ) 1037 1038 (asm ldf () 1039 (prinst "lfs" 1 "0(14)") ) 1040 1041 (asm fixnum () 1042 (prinst "srdi" 0 15 4) # Normalize scale (ignore sign) 1043 (prinst "std" 0 "-8(1)") 1044 (prinst "lfd" 0 "-8(1)") # Get scale in f13 1045 (prinst "fcfid" 13 0) 1046 (prinst "fmul" 1 1 13) # Multiply with value 1047 (prinst "fctid" 0 1) # Convert to integer 1048 (prinst "stfd" 0 "-8(1)") 1049 (prinst "ld" 15 "-8(1)") # In E 1050 (prinst "or." 15 15 15) # Sign? 1051 (prinst "blt-" "1f") # Yes 1052 (prinst "extrdi." 0 15 4 0) # Overflow? 1053 (prinst "beq+" "3f") # No 1054 (prinst "la" 15 "TSym-Data(22)") 1055 (prinst "b" "4f") 1056 (prinl "1:") 1057 (prinst "extrdi" 0 15 4 0) # Underflow? 1058 (prinst "neg" 15 15) # Negate 1059 (prinst "cmpdi" 0 0 15) 1060 (prinst "beq+" "2f") # No 1061 (prinst "mr" 15 25) # Nil 1062 (prinst "b" "4f") 1063 (prinl "2:") 1064 (prinst "sldi" 15 15 4) # Make negative short number 1065 (prinst "ori" 15 15 10) 1066 (prinst "b" "4f") 1067 (prinl "3:") 1068 (prinst "sldi" 15 15 4) # Make short number 1069 (prinst "ori" 15 15 2) 1070 (prinl "4:") ) 1071 1072 (asm float () 1073 #{!}# ) 1074 1075 (asm std () 1076 (prinst "stfd" 1 "0(14)") ) 1077 1078 (asm stf () 1079 (prinst "stfs" 1 "0(14)") ) 1080 1081 # C-Calls 1082 (asm cc (Adr A Arg M) 1083 (let Reg (3 4 5 6 7 8 9 10) # Support only max. 8 parameters 1084 (if (lst? Arg) 1085 (let (Lea NIL Tmp NIL) 1086 (when (fish '((X) (= 3 X)) (cdr Arg)) 1087 (prinst "mr" (setq Tmp 11) 3) ) 1088 (mapc 1089 '((Src S) 1090 (if (== '& Src) 1091 (on Lea) 1092 (setq Src 1093 (recur (Src) 1094 (cond 1095 ((= 3 Src) (or Tmp 3)) 1096 ((atom Src) Src) 1097 (T (cons (recurse (car Src)) (recurse (cdr Src)))) ) ) ) 1098 (cond 1099 ((not Reg) # 'Src' not stack-relative here! 1100 #{MADA}# ) 1101 ((and (=T S) (== 'pop Src)) 1102 (prinst "ld" (pop 'Reg) "0(1)") 1103 (prinst "addi" 1 1 8) ) 1104 (Lea (memory Src S (pop 'Reg))) 1105 ((= 3 Src) (pop 'Reg)) 1106 (T (srcReg Src S (pop 'Reg))) ) 1107 (off Lea) ) ) 1108 Arg 1109 M ) ) 1110 (prinst "mr" 27 1) # 27 on arguments 1111 (prinst "ld" 11 "flt1@got(2)") 1112 (for R Reg 1113 (prinst "cmpd" Arg 27) 1114 (prinst "beq-" "2f") 1115 (prinst "ld" 0 "0(27)") 1116 (prinst "cmpdi" 0 0) # Float? 1117 (prinst "beq-" "1f") # No 1118 (prinst "mtctr" 11) # Else call float conversion 1119 (prinst "bctrl") 1120 (prinl "1:") 1121 (prinst "ld" R "8(27)") # Get value 1122 (prinst "addi" 27 27 16) ) 1123 (prinl "2:") ) ) 1124 (nond 1125 (A # Absolute 1126 (unless (= Adr "exit") 1127 (prinst "mflr" 27) 1128 (prinst "stdu" 1 "-112(1)") ) 1129 (prinst "bl" Adr) 1130 (prinst "nop") 1131 (unless (= Adr "exit") 1132 (prinst "addi" 1 1 112) 1133 (prinst "mtlr" 27) ) ) 1134 ((=T A) # Indexed 1135 (prinst "mflr" 0) 1136 (prinst "stdu" 1 "-120(1)") 1137 (prinst "std" 0 "112(1)") 1138 (prinst "std" 2 "40(1)") 1139 (prinst "ld" 0 (pack "0(" Adr ")")) 1140 (prinst "ld" 11 (pack "16(" Adr ")")) 1141 (prinst "ld" 2 (pack "8(" Adr ")")) 1142 (prinst "mtctr" 0) 1143 (prinst "bctrl") 1144 (prinst "ld" 2 "40(1)") 1145 (prinst "ld" 0 "112(1)") 1146 (prinst "addi" 1 1 120) 1147 (prinst "mtlr" 0) ) ) 1148 (and 1149 (lst? Arg) 1150 (gt0 (- (length Arg) 8)) 1151 (prinst "addi" 1 1 (* @ 8)) ) ) 1152 1153 (asm func ()) 1154 1155 (asm begin () 1156 (prinst ".quad" ".+24" ".TOC.@tocbase" 0) 1157 (prinst "mflr" 0) 1158 (prinst "bl" "begin") ) 1159 1160 (asm return () 1161 (prinst "b" "return") ) 1162 1163 # Stack Manipulations 1164 (asm push (Src S) 1165 (ifn (=T Src) 1166 (prinst "stdu" (srcReg Src S) "-8(1)") 1167 (let R (tmpReg) 1168 (prinst "mfocrf" R 128) # Get CR[0] 1169 (prinst "insrdi" R 31 1 63) # Carry into LSB 1170 (prinst "stdu" R "-8(1)") ) ) ) 1171 1172 (asm pop (Dst D) 1173 (cond 1174 (D 1175 (let R (tmpReg) 1176 (prinst "ld" R "0(1)") 1177 (memory Dst D R T) ) ) 1178 ((=T Dst) 1179 (let R (tmpReg) 1180 (prinst "ld" R "0(1)") 1181 (prinst "insrdi" 31 R 1 63) # Set carry from LSB 1182 (prinst "mtocrf" 128 R) ) ) # Set CR[0] (LT, GT, EQ, SO) 1183 (T (prinst "ld" Dst "0(1)")) ) 1184 (prinst "addi" 1 1 8) ) 1185 1186 (asm link () 1187 (prinst "stdu" 19 "-8(1)") # Push L 1188 (prinst "mr" 19 1) ) 1189 1190 (asm tuck (Src S) 1191 (prinst "ld" 19 "0(1)") # Get L 1192 (prinst "std" (srcReg Src S) "0(1)") ) 1193 1194 (asm drop () 1195 (prinst "ld" 1 "0(19)") # Restore S 1196 (prinst "ld" 19 "0(1)") # and L 1197 (prinst "addi" 1 1 8) ) 1198 1199 # Evaluation 1200 (asm eval () 1201 (prinst "andi." 0 15 "0x06") # Number? 1202 (prinst "bne-" "2f") # Yes: Skip 1203 (prinst "andi." 0 15 "0x08") # Symbol? 1204 (prinst "beq-" "1f") # Yes: Get value 1205 (prinst "ld" 15 "0(15)") 1206 (prinst "b" "2f") # and skip 1207 (prinl "1:") 1208 (codeCall "evListE_E") # Else evaluate list 1209 (prinl "2:") ) 1210 1211 (asm eval+ () 1212 (prinst "andi." 0 15 "0x06") # Number? 1213 (prinst "bne-" "2f") # Yes: Skip 1214 (prinst "andi." 0 15 "0x08") # Symbol? 1215 (prinst "beq-" "1f") # Yes: Get value 1216 (prinst "ld" 15 "0(15)") 1217 (prinst "b" "2f") # and skip 1218 (prinl "1:") 1219 (prinst "stdu" 19 "-8(1)") # Else 'link' 1220 (prinst "mr" 19 1) 1221 (codeCall "evListE_E") # Evaluate list 1222 (prinst "ld" 19 "0(1)") # Pop L 1223 (prinst "addi" 1 1 8) 1224 (prinl "2:") ) 1225 1226 (asm eval/ret () 1227 (prinst "andi." 0 15 "0x06") # Number? 1228 (prinst "bnelr-") # Yes: Return 1229 (prinst "andi." 0 15 "0x08") # Symbol? 1230 (prinst "beq-" "1f") # No: Evaluate list 1231 (prinst "ld" 15 "0(15)") # Get value 1232 (prinst "blr") 1233 (prinl "1:") 1234 (prinst "b" "evListE_E") ) 1235 1236 (asm exec (Reg) 1237 (prinl "1:") # do 1238 (prinst "ld" 15 (pack "0(" Reg ")")) # ld E (R) 1239 (prinst "andi." 0 15 "0x0E") # atom E 1240 (prinst "bne+" "2f") 1241 (codeCall "evListE_E") # Evaluate list 1242 (prinl "2:") 1243 (prinst "ld" Reg (pack "8(" Reg ")")) # ld R (R CDR) 1244 (prinst "andi." 0 Reg "0x0E") # atom R 1245 (prinst "beq+" "1b") ) # until nz 1246 1247 (asm prog (Reg) 1248 (prinl "1:") # do 1249 (prinst "ld" 15 (pack "0(" Reg ")")) # ld E (R) 1250 (prinst "andi." 0 15 "0x06") # eval 1251 (prinst "bne-" "2f") 1252 (prinst "andi." 0 15 "0x08") 1253 (prinst "beq-" ".+12") 1254 (prinst "ld" 15 "0(15)") 1255 (prinst "b" "2f") 1256 (codeCall "evListE_E") # Evaluate list 1257 (prinl "2:") 1258 (prinst "ld" Reg (pack "8(" Reg ")")) # ld R (R CDR) 1259 (prinst "andi." 0 Reg "0x0E") # atom R 1260 (prinst "beq+" "1b") ) # until nz 1261 1262 1263 # System 1264 (asm initData ()) 1265 1266 (asm initCode () 1267 (unless *FPic 1268 (prinst "mflr" 11) # Get return address 1269 (prinst "lwa" 0 "0(11)") # Target offset 1270 (prinst "add" 0 0 23) # Code-relative 1271 (prinst "mtlr" 0) # Set target address 1272 (prinst "addi" 0 11 4) # Update return address 1273 (prinst "stdu" 0 "-8(1)") # Save it 1274 (prinst "blrl") # Call target 1275 (prinst "ld" 0 "0(1)") # Pop return address 1276 (prinst "addi" 1 1 8) 1277 (prinst "mtctr" 0) # Return 1278 (prinst "bctr") 1279 (prinl) ) 1280 (label "callRel") 1281 (prinst "mflr" 11) # Get return address 1282 (prinst "lwa" 0 "0(11)") # Target offset 1283 (prinst "add" 0 0 11) # PC-relative 1284 (prinst "mtlr" 0) # Set target address 1285 (prinst "addi" 0 11 4) # Update return address 1286 (prinst "stdu" 0 "-8(1)") # Save it 1287 (prinst "blrl") # Call target 1288 (prinst "ld" 0 "0(1)") # Pop return address 1289 (prinst "addi" 1 1 8) 1290 (prinst "mtctr" 0) # Return 1291 (prinst "bctr") 1292 (prinl) 1293 (label "callCtr") 1294 (prinst "mflr" 11) # Get return address 1295 (prinst "stdu" 11 "-8(1)") # Save it 1296 (prinst "bctrl") # Call target 1297 (prinst "ld" 0 "0(1)") # Pop return address 1298 (prinst "addi" 1 1 8) 1299 (prinst "mtctr" 0) # Return 1300 (prinst "bctr") 1301 (prinl) 1302 (unless *FPic 1303 (prinl "# movn dst src cnt") 1304 (label "movn") 1305 (prinst "subi" 4 4 1) # Adjust 'dst' 1306 (prinst "subi" 5 5 1) # and 'src' 1307 (prinl "1:") 1308 (prinst "subic." 6 6 1) # Decrement 'cnt' 1309 (prinst "bltlr") # Return if done 1310 (prinst "lbzu" 7 "1(5)") # Next byte from 'src' 1311 (prinst "stbu" 7 "1(4)") # Write to 'dst' 1312 (prinst "b" "1b") 1313 (prinl) 1314 (prinl "# mset dst src cnt") 1315 (label "mset") 1316 (prinst "subi" 4 4 1) # Adjust 'dst' 1317 (prinl "1:") 1318 (prinst "subic." 5 5 1) # Decrement 'cnt' 1319 (prinst "bltlr") # Return if done 1320 (prinst "stbu" 3 "1(4)") # Write B to 'dst' 1321 (prinst "b" "1b") 1322 (prinl) 1323 (prinl "# save src end dst") 1324 (label "save") 1325 (prinst "ld" 7 "0(4)") # First word from 'src' 1326 (prinst "std" 7 "0(6)") # Write to 'dst' 1327 (prinl "1:") 1328 (prinst "ldu" 7 "8(4)") # Next word from 'src' 1329 (prinst "cmpd" 4 5) # Done? 1330 (prinst "beqlr-") # Yes: Return 1331 (prinst "stdu" 7 "8(6)") # Write to 'dst' 1332 (prinst "b" "1b") 1333 (prinl) 1334 (prinl "# load dst end src") 1335 (label "load") 1336 (prinst "ld" 7 "0(6)") # First word from 'src' 1337 (prinst "std" 7 "0(4)") # Write to 'dst' 1338 (prinst "subi" 5 5 8) # Adjust 'end' 1339 (prinl "1:") 1340 (prinst "ldu" 7 "8(6)") # Next word from 'src' 1341 (prinst "stdu" 7 "8(4)") # Write to 'dst' 1342 (prinst "cmpd" 4 5) # Done? 1343 (prinst "bne+" "1b") # No 1344 (prinst "blr") 1345 (prinl) 1346 (prinl "# cmpn dst src cnt") 1347 (label "cmpn") 1348 (prinst "lbz" 7 "0(4)") # First byte from 'dst' 1349 (prinst "lbz" 8 "0(5)") # First byte from 'src' 1350 (prinl "1:") 1351 (prinst "subc." 0 7 8) # Same bytes? 1352 (prinst "bnelr-") # No: Return 'ne' 1353 (prinst "subic." 6 6 1) # Decrement 'cnt' 1354 (prinst "beqlr-") # Return 'eq' if done 1355 (prinst "lbzu" 7 "1(4)") # Next bytes 1356 (prinst "lbzu" 8 "1(5)") 1357 (prinst "b" "1b") 1358 (prinl) 1359 (prinl "# slen dst src") 1360 (label "slen") 1361 (prinst "li" 4 0) # Init 'dst' counter 1362 (prinst "lbz" 7 "0(5)") # First byte from 'src' 1363 (prinl "1:") 1364 (prinst "cmpdi" 7 0) # Done? 1365 (prinst "beqlr-") # Yes: Return 1366 (prinst "addi" 4 4 1) # Increment 'cnt' 1367 (prinst "lbzu" 7 "1(5)") # Next byte 1368 (prinst "b" "1b") 1369 (prinl) 1370 (prinl "# memb src cnt") 1371 (label "memb") 1372 (prinst "mr" 6 4) # Get 'src' 1373 (prinst "extrdi" 7 3 8 56) # and B 1374 (prinl "1:") 1375 (prinst "subic." 5 5 1) # Decrement 'cnt' 1376 (prinst "bltlr-") # Return 'ne' if done 1377 (prinst "lbz" 8 "0(6)") # Next byte from 'src' 1378 (prinst "addi" 6 6 1) # Increment 'src' 1379 (prinst "cmpd" 8 7) # Found? 1380 (prinst "bne+" "1b") # No 1381 (prinst "mr" 4 6) # Else return 'eq' 1382 (prinst "blr") 1383 (prinl) 1384 (prinl "# div src") # From: http://hackers-delight.org.ua 1385 (label "div") # 14:3 / 4 1386 (let 1387 (@u1 14 @u0 3 @v 4 @s 5 # un21 = un32 = u1 1388 @un1 6 @un0 7 @vn1 8 @vn0 9 1389 @q1 27 @q0 28 @rhat 29 @tmp 30 ) 1390 (macro 1391 (prinst "cmpld" @u1 @v) # u1 >= v? 1392 (prinst "bge-" "divOvfl") # Yes: Overflow 1393 (prinst "li" @s 0) # Init 's' 1394 (prinst "cmpdi" @v 0) # Normalize 1395 (prinst "blt" "div2") 1396 (prinl "div1:") 1397 (prinst "addi" @s @s 1) # Increment 's' 1398 (prinst "addc" @u0 @u0 @u0) # Shift dividend left 1399 (prinst "adde" @u1 @u1 @u1) 1400 (prinst "add." @v @v @v) # and divisor 1401 (prinst "bge" "div1") 1402 (prinl "div2:") 1403 (prinst "extrdi" @vn1 @v 32 0) # Split divisor into high 32 bits 1404 (prinst "extrdi" @vn0 @v 32 32) # and low 32 bits 1405 (prinst "extrdi" @un1 @u0 32 0) # Split 'u0' into high 32 bits 1406 (prinst "extrdi" @un0 @u0 32 32) # and low 32 bits 1407 (prinst "divdu" @q1 @u1 @vn1) # First quotient digit 1408 (prinst "mulld" 0 @q1 @vn1) 1409 (prinst "sub" @rhat @u1 0) 1410 (prinl "div3:") 1411 (prinst "extrdi." 0 @q1 32 0) # q1 >= b? 1412 (prinst "bne-" "div4") # Yes 1413 (prinst "sldi" @tmp @rhat 32) # b*rhat + un1 1414 (prinst "add" @tmp @tmp @un1) 1415 (prinst "mulld" 0 @q1 @vn0) 1416 (prinst "cmpld" 0 @tmp) # q1 * vn0 > b*rhat + un1? 1417 (prinst "ble+" "div5") # No 1418 (prinl "div4:") 1419 (prinst "subi" @q1 @q1 1) # Else decrement 'q1' 1420 (prinst "add" @rhat @rhat @vn1) # Increment 'rhat' 1421 (prinst "extrdi." 0 @rhat 32 0) # Less than 'b'? 1422 (prinst "beq-" "div3") # Yes 1423 (prinl "div5:") 1424 (prinst "sldi" @u1 @u1 32) # (un32*b) 1425 (prinst "add" @u1 @u1 @un1) # (un1 + un32*b) 1426 (prinst "mulld" 0 @q1 @v) 1427 (prinst "sub" @u1 @u1 0) # un21 = un1 + un32*b - q1*v 1428 (prinst "divdu" @q0 @u1 @vn1) # Second quotient digit 1429 (prinst "mulld" 0 @q0 @vn1) 1430 (prinst "sub" @rhat @u1 0) 1431 (prinl "div6:") 1432 (prinst "extrdi." 0 @q0 32 0) # q0 >= b? 1433 (prinst "bne-" "div7") # Yes 1434 (prinst "sldi" @tmp @rhat 32) # b*rhat + un0 1435 (prinst "add" @tmp @tmp @un0) 1436 (prinst "mulld" 0 @q0 @vn0) 1437 (prinst "cmpld" 0 @tmp) # q0 * vn0 > b*rhat + un0? 1438 (prinst "ble+" "div8") # No 1439 (prinl "div7:") 1440 (prinst "subi" @q0 @q0 1) # Else decrement 'q0' 1441 (prinst "add" @rhat @rhat @vn1) # Increment 'rhat' 1442 (prinst "extrdi." 0 @rhat 32 0) # Less than 'b'? 1443 (prinst "beq-" "div6") # Yes 1444 (prinl "div8:") 1445 (prinst "sldi" @u0 @q1 32) # Quotient 1446 (prinst "add" @u0 @u0 @q0) 1447 (prinst "sldi" @u1 @u1 32) # Remainder: u1 = (un0 + un21*b - q0*v) >> s 1448 (prinst "add" @u1 @u1 @un0) 1449 (prinst "mulld" 0 @q0 @v) 1450 (prinst "sub" @u1 @u1 0) 1451 (prinst "srd" @u1 @u1 @s) 1452 (prinst "blr") 1453 (prinl "divOvfl:") 1454 (prinst "li" @u0 -1) # Overflow 1455 (prinst "li" @u1 -1) 1456 (prinst "blr") ) ) 1457 (prinl) 1458 (let R 28 # 'cc' uses 27 as argument pointer 1459 (for F 8 1460 (label (pack "flt" F)) 1461 (unless (= 8 F) 1462 (prinst "addi" 11 11 (pack "flt" (inc F) "-flt" F)) ) 1463 (prinst "srdi" 0 0 4) # Scale (ignore sign) 1464 (prinst "std" 0 "0(27)") 1465 (prinst "ld" R "8(27)") # Value 1466 (prinst "andi." 0 R "0x02") # Short? 1467 (prinst "beq-" "2f") # No 1468 (prinst "lfd" 0 "0(27)") # Get scale in f13 1469 (prinst "fcfid" 13 0) 1470 (prinst "andi." 0 R "0x08") # Value negative? 1471 (prinst "srdi" R R 4) # Scale value 1472 (prinst "beq-" "1f") 1473 (prinst "neg" R R) # Negate 1474 (prinl "1:") 1475 (prinst "std" R "8(27)") # Get value 1476 (prinst "lfd" 0 "8(27)") 1477 (prinst "fcfid" F 0) 1478 (prinst "fdiv" F F 13) # Divide by scale 1479 (prinst "stfd" F "8(27)") 1480 (prinst "blr") 1481 (prinl "2:") # T or NIL 1482 (prinst "cmpd" 25 R) # Nil? 1483 (prinst "li" R (hex "7FF")) # inf 1484 (prinst "bne-" ".+8") 1485 (prinst "li" R (hex "FFF")) # -inf 1486 (prinst "rotrdi" R R 12) 1487 (prinst "std" R "8(27)") # Get value 1488 (prinst "lfd" 0 "8(27)") 1489 (prinst "blr") ) ) 1490 (prinl) 1491 (label "begin") 1492 (prinst "std" 14 "-144(1)") 1493 (prinst "std" 15 "-136(1)") 1494 (prinst "std" 16 "-128(1)") 1495 (prinst "std" 17 "-120(1)") 1496 (prinst "std" 18 "-112(1)") 1497 (prinst "std" 19 "-104(1)") 1498 (prinst "std" 20 "-96(1)") 1499 (prinst "std" 21 "-88(1)") 1500 (prinst "std" 22 "-80(1)") 1501 (prinst "std" 23 "-72(1)") 1502 (prinst "std" 24 "-64(1)") 1503 (prinst "std" 25 "-56(1)") 1504 (prinst "std" 26 "-48(1)") 1505 (prinst "std" 27 "-40(1)") 1506 (prinst "std" 28 "-32(1)") 1507 (prinst "std" 29 "-24(1)") 1508 (prinst "std" 30 "-16(1)") 1509 (prinst "std" 31 "-8(1)") 1510 (prinst "std" 0 "16(1)") 1511 (prinst "stdu" 1 "-256(1)") 1512 (prinst "li" 20 0) # Init NULL register 1513 (prinst "li" 21 1) # Init ONE register 1514 (prinst "ld" 22 "Data@got(2)") # Globals bases 1515 (prinst "ld" 23 "Code@got(2)") 1516 (prinst "la" 25 "Nil-Data(22)") # Nil 1517 (prinst "mr" 18 8) # Z 1518 (prinst "mr" 17 7) # Y 1519 (prinst "mr" 16 6) # X 1520 (prinst "mr" 15 5) # E 1521 (prinst "mr" 14 4) # C 1522 (prinst "blr") 1523 (prinl) 1524 (label "return") 1525 (prinst "addi" 1 1 256) 1526 (prinst "ld" 14 "-144(1)") 1527 (prinst "ld" 15 "-136(1)") 1528 (prinst "ld" 16 "-128(1)") 1529 (prinst "ld" 17 "-120(1)") 1530 (prinst "ld" 18 "-112(1)") 1531 (prinst "ld" 19 "-104(1)") 1532 (prinst "ld" 20 "-96(1)") 1533 (prinst "ld" 21 "-88(1)") 1534 (prinst "ld" 22 "-80(1)") 1535 (prinst "ld" 23 "-72(1)") 1536 (prinst "ld" 24 "-64(1)") 1537 (prinst "ld" 25 "-56(1)") 1538 (prinst "ld" 26 "-48(1)") 1539 (prinst "ld" 27 "-40(1)") 1540 (prinst "ld" 28 "-32(1)") 1541 (prinst "ld" 29 "-24(1)") 1542 (prinst "ld" 30 "-16(1)") 1543 (prinst "ld" 31 "-8(1)") 1544 (prinst "ld" 0 "16(1)") 1545 (prinst "mtlr" 0) 1546 (prinst "blr") ) ) 1547 1548 (asm initMain () 1549 (prinst ".quad" ".+24" ".TOC.@tocbase" 0) 1550 (prinst "li" 20 0) # Init NULL register 1551 (prinst "li" 21 1) # Init ONE register 1552 (prinst "ld" 22 "Data@got(2)") # Globals bases 1553 (prinst "ld" 23 "Code@got(2)") 1554 (prinst "la" 25 "Nil-Data(22)") # Nil 1555 (prinst "ld" 16 "0(4)") # Get command in X 1556 (prinst "la" 17 "8(4)") # argument vector in Y 1557 (prinst "subi" 3 3 1) # and pointer to last argument in Z 1558 (prinst "sldi" 3 3 3) 1559 (prinst "add" 18 4 3) ) 1560 1561 (asm initLib ()) 1562 1563 ### Optimizer ### 1564 # Replace the the next 'cnt' elements with 'lst' 1565 (de optimize (Lst) #> (cnt . lst) 1566 (when (noCC L) 1567 (cons 1 (cons (cons @ (cdar L)))) ) ) 1568 1569 ### Decoration ### 1570 (de prolog (File) 1571 (when *FPic 1572 (in "ppc64.symtab" 1573 (balance '*DataIndex (read)) 1574 (balance '*CodeIndex (read)) ) ) ) 1575 1576 (de epilog (File) 1577 (unless *FPic 1578 (out "ppc64.symtab" 1579 (println (sort *DataLabels)) 1580 (println (sort *CodeLabels)) ) ) ) 1581 1582 1583 # vi:et:ts=3:sw=3