1;;;; the VM definition arithmetic VOPs for HPPA 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5;;;; 6;;;; This software is derived from the CMU CL system, which was 7;;;; written at Carnegie Mellon University and released into the 8;;;; public domain. The software is in the public domain and is 9;;;; provided with absolutely no warranty. See the COPYING and CREDITS 10;;;; files for more information. 11 12(in-package "SB!VM") 13 14;;;; Unary operations. 15 16(define-vop (fast-safe-arith-op) 17 (:policy :fast-safe) 18 (:effects) 19 (:affected)) 20 21(define-vop (fixnum-unop fast-safe-arith-op) 22 (:args (x :scs (any-reg))) 23 (:results (res :scs (any-reg))) 24 (:note "inline fixnum arithmetic") 25 (:arg-types tagged-num) 26 (:result-types tagged-num)) 27 28(define-vop (signed-unop fast-safe-arith-op) 29 (:args (x :scs (signed-reg))) 30 (:results (res :scs (signed-reg))) 31 (:note "inline (signed-byte 32) arithmetic") 32 (:arg-types signed-num) 33 (:result-types signed-num)) 34 35(define-vop (fast-negate/fixnum fixnum-unop) 36 (:translate %negate) 37 (:generator 1 38 (inst sub zero-tn x res))) 39 40(define-vop (fast-negate/signed signed-unop) 41 (:translate %negate) 42 (:generator 2 43 (inst sub zero-tn x res))) 44 45(define-vop (fast-lognot/fixnum fixnum-unop) 46 (:translate lognot) 47 (:temporary (:scs (any-reg) :type fixnum :to (:result 0)) 48 temp) 49 (:generator 1 50 (inst li (fixnumize -1) temp) 51 (inst xor x temp res))) 52 53(define-vop (fast-lognot/signed signed-unop) 54 (:translate lognot) 55 (:generator 2 56 (inst uaddcm zero-tn x res))) 57 58;;;; Binary fixnum operations. 59 60;;; Assume that any constant operand is the second arg... 61 62(define-vop (fast-fixnum-binop fast-safe-arith-op) 63 (:args (x :target r :scs (any-reg zero)) 64 (y :target r :scs (any-reg zero))) 65 (:arg-types tagged-num tagged-num) 66 (:results (r :scs (any-reg))) 67 (:result-types tagged-num) 68 (:note "inline fixnum arithmetic")) 69 70(define-vop (fast-unsigned-binop fast-safe-arith-op) 71 (:args (x :target r :scs (unsigned-reg zero)) 72 (y :target r :scs (unsigned-reg zero))) 73 (:arg-types unsigned-num unsigned-num) 74 (:results (r :scs (unsigned-reg))) 75 (:result-types unsigned-num) 76 (:note "inline (unsigned-byte 32) arithmetic")) 77 78(define-vop (fast-signed-binop fast-safe-arith-op) 79 (:args (x :target r :scs (signed-reg zero)) 80 (y :target r :scs (signed-reg zero))) 81 (:arg-types signed-num signed-num) 82 (:results (r :scs (signed-reg))) 83 (:result-types signed-num) 84 (:note "inline (signed-byte 32) arithmetic")) 85 86(define-vop (fast-fixnum-c-binop fast-fixnum-binop) 87 (:args (x :target r :scs (any-reg))) 88 (:info y) 89 (:arg-types tagged-num (:constant integer))) 90 91(define-vop (fast-signed-c-binop fast-signed-binop) 92 (:args (x :target r :scs (signed-reg))) 93 (:info y) 94 (:arg-types tagged-num (:constant integer))) 95 96(define-vop (fast-unsigned-c-binop fast-unsigned-binop) 97 (:args (x :target r :scs (unsigned-reg))) 98 (:info y) 99 (:arg-types tagged-num (:constant integer))) 100 101(macrolet 102 ((define-binop (translate cost untagged-cost op arg-swap) 103 `(progn 104 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM") 105 fast-fixnum-binop) 106 (:args (x :target r :scs (any-reg)) 107 (y :target r :scs (any-reg))) 108 (:translate ,translate) 109 (:generator ,(1+ cost) 110 ,(if arg-swap 111 `(inst ,op y x r) 112 `(inst ,op x y r)))) 113 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED") 114 fast-signed-binop) 115 (:args (x :target r :scs (signed-reg)) 116 (y :target r :scs (signed-reg))) 117 (:translate ,translate) 118 (:generator ,(1+ untagged-cost) 119 ,(if arg-swap 120 `(inst ,op y x r) 121 `(inst ,op x y r)))) 122 (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED") 123 fast-unsigned-binop) 124 (:args (x :target r :scs (unsigned-reg)) 125 (y :target r :scs (unsigned-reg))) 126 (:translate ,translate) 127 (:generator ,(1+ untagged-cost) 128 ,(if arg-swap 129 `(inst ,op y x r) 130 `(inst ,op x y r))))))) 131 (define-binop + 1 5 add nil) 132 (define-binop - 1 5 sub nil) 133 (define-binop logior 1 2 or nil) 134 (define-binop logand 1 2 and nil) 135 (define-binop logandc1 1 2 andcm t) 136 (define-binop logandc2 1 2 andcm nil) 137 (define-binop logxor 1 2 xor nil)) 138 139(macrolet 140 ((define-c-binop (translate cost untagged-cost tagged-type untagged-type inst) 141 `(progn 142 (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM") 143 fast-fixnum-c-binop) 144 (:arg-types tagged-num (:constant ,tagged-type)) 145 (:translate ,translate) 146 (:generator ,cost 147 (let ((y (fixnumize y))) 148 ,inst))) 149 (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED") 150 fast-signed-c-binop) 151 (:arg-types signed-num (:constant ,untagged-type)) 152 (:translate ,translate) 153 (:generator ,untagged-cost 154 ,inst)) 155 (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED") 156 fast-unsigned-c-binop) 157 (:arg-types unsigned-num (:constant ,untagged-type)) 158 (:translate ,translate) 159 (:generator ,untagged-cost 160 ,inst))))) 161 162 (define-c-binop + 1 3 (signed-byte 9) (signed-byte 11) 163 (inst addi y x r)) 164 (define-c-binop - 1 3 165 (integer #.(- 1 (ash 1 8)) #.(ash 1 8)) 166 (integer #.(- 1 (ash 1 10)) #.(ash 1 10)) 167 (inst addi (- y) x r))) 168 169(define-vop (fast-lognor/fixnum=>fixnum fast-fixnum-binop) 170 (:translate lognor) 171 (:args (x :target r :scs (any-reg)) 172 (y :target r :scs (any-reg))) 173 (:temporary (:sc non-descriptor-reg) temp) 174 (:generator 4 175 (inst or x y temp) 176 (inst uaddcm zero-tn temp temp) 177 (inst addi (- fixnum-tag-mask) temp r))) 178 179(define-vop (fast-lognor/signed=>signed fast-signed-binop) 180 (:translate lognor) 181 (:args (x :target r :scs (signed-reg)) 182 (y :target r :scs (signed-reg))) 183 (:generator 4 184 (inst or x y r) 185 (inst uaddcm zero-tn r r))) 186 187(define-vop (fast-lognor/unsigned=>unsigned fast-unsigned-binop) 188 (:translate lognor) 189 (:args (x :target r :scs (unsigned-reg)) 190 (y :target r :scs (unsigned-reg))) 191 (:generator 4 192 (inst or x y r) 193 (inst uaddcm zero-tn r r))) 194 195;;; Shifting 196(macrolet 197 ((fast-ash (name reg num tag save) 198 `(define-vop (,name) 199 (:translate ash) 200 (:note "inline ASH") 201 (:policy :fast-safe) 202 (:args (number :scs (,reg) :to :save) 203 (count :scs (signed-reg))) 204 (:arg-types ,num ,tag) 205 (:results (result :scs (,reg))) 206 (:result-types ,num) 207 (:temporary (:scs (unsigned-reg) 208 ,@(unless save 209 '(:to (:result 0)))) temp) 210 (:generator 8 211 (inst comb :>= count zero-tn positive :nullify t) 212 (inst sub zero-tn count temp) 213 ,@(if save 214 '(;; Unsigned case 215 (inst comiclr 31 temp result :>=) 216 (inst b done :nullify t) 217 (inst mtctl temp :sar) 218 (inst b done) 219 (inst shd zero-tn number :variable result)) 220 '(;; Signed case 221 (inst comiclr 31 temp zero-tn :>=) 222 (inst li 31 temp) 223 (inst mtctl temp :sar) 224 (inst extrs number 0 1 temp) 225 (inst b done) 226 (inst shd temp number :variable result))) 227 POSITIVE 228 (inst subi 31 count temp) 229 (inst mtctl temp :sar) 230 (inst zdep number :variable 32 result) 231 DONE)))) 232 (fast-ash fast-ash/unsigned=>unsigned unsigned-reg unsigned-num 233 tagged-num t) 234 (fast-ash fast-ash/signed=>signed signed-reg signed-num signed-num nil)) 235 236(define-vop (fast-ash-c/unsigned=>unsigned) 237 (:translate ash) 238 (:note "inline ASH") 239 (:policy :fast-safe) 240 (:args (number :scs (unsigned-reg))) 241 (:info count) 242 (:arg-types unsigned-num (:constant integer)) 243 (:results (result :scs (unsigned-reg))) 244 (:result-types unsigned-num) 245 (:generator 1 246 (cond 247 ((< count -31) (move zero-tn result)) 248 ((< count 0) (inst srl number (min (- count) 31) result)) 249 ((> count 0) (inst sll number (min count 31) result)) 250 (t (bug "identity ASH not transformed away"))))) 251 252(define-vop (fast-ash-c/signed=>signed) 253 (:translate ash) 254 (:note "inline ASH") 255 (:policy :fast-safe) 256 (:args (number :scs (signed-reg))) 257 (:info count) 258 (:arg-types signed-num (:constant integer)) 259 (:results (result :scs (signed-reg))) 260 (:result-types signed-num) 261 (:generator 1 262 (cond 263 ((< count 0) (inst sra number (min (- count) 31) result)) 264 ((> count 0) (inst sll number (min count 31) result)) 265 (t (bug "identity ASH not transformed away"))))) 266 267(macrolet ((def (name sc-type type result-type cost) 268 `(define-vop (,name) 269 (:translate ash) 270 (:note "inline ASH") 271 (:policy :fast-safe) 272 (:args (number :scs (,sc-type)) 273 (amount :scs (signed-reg unsigned-reg immediate))) 274 (:arg-types ,type positive-fixnum) 275 (:results (result :scs (,result-type))) 276 (:result-types ,type) 277 (:temporary (:scs (,sc-type) :to (:result 0)) temp) 278 (:generator ,cost 279 (sc-case amount 280 ((signed-reg unsigned-reg) 281 (inst subi 31 amount temp) 282 (inst mtctl temp :sar) 283 (inst zdep number :variable 32 result)) 284 (immediate 285 (let ((amount (tn-value amount))) 286 (aver (> amount 0)) 287 (inst sll number amount result)))))))) 288 (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2) 289 (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3) 290 (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3)) 291 292(define-vop (signed-byte-32-len) 293 (:translate integer-length) 294 (:note "inline (signed-byte 32) integer-length") 295 (:policy :fast-safe) 296 (:args (arg :scs (signed-reg) :target shift)) 297 (:arg-types signed-num) 298 (:results (res :scs (any-reg))) 299 (:result-types positive-fixnum) 300 (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift) 301 (:generator 30 302 (inst move arg shift :>=) 303 (inst uaddcm zero-tn shift shift) 304 (inst comb := shift zero-tn done) 305 (inst li 0 res) 306 LOOP 307 (inst srl shift 1 shift) 308 (inst comb :<> shift zero-tn loop) 309 (inst addi (fixnumize 1) res res) 310 DONE)) 311 312(define-vop (unsigned-byte-32-count) 313 (:translate logcount) 314 (:note "inline (unsigned-byte 32) logcount") 315 (:policy :fast-safe) 316 (:args (arg :scs (unsigned-reg) :target num)) 317 (:arg-types unsigned-num) 318 (:results (res :scs (unsigned-reg))) 319 (:result-types positive-fixnum) 320 (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0) 321 :target res) num) 322 (:temporary (:scs (non-descriptor-reg)) mask temp) 323 (:generator 30 324 (inst li #x55555555 mask) 325 (inst srl arg 1 temp) 326 (inst and arg mask num) 327 (inst and temp mask temp) 328 (inst add num temp num) 329 (inst li #x33333333 mask) 330 (inst srl num 2 temp) 331 (inst and num mask num) 332 (inst and temp mask temp) 333 (inst add num temp num) 334 (inst li #x0f0f0f0f mask) 335 (inst srl num 4 temp) 336 (inst and num mask num) 337 (inst and temp mask temp) 338 (inst add num temp num) 339 (inst li #x00ff00ff mask) 340 (inst srl num 8 temp) 341 (inst and num mask num) 342 (inst and temp mask temp) 343 (inst add num temp num) 344 (inst li #x0000ffff mask) 345 (inst srl num 16 temp) 346 (inst and num mask num) 347 (inst and temp mask temp) 348 (inst add num temp res))) 349 350;;; Multiply and Divide. 351 352(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop) 353 (:translate *) 354 (:args (x :scs (any-reg zero) :target x-pass) 355 (y :scs (any-reg zero) :target y-pass)) 356 (:temporary (:sc signed-reg :offset nl0-offset 357 :from (:argument 0) :to (:result 0)) x-pass) 358 (:temporary (:sc signed-reg :offset nl1-offset 359 :from (:argument 1) :to (:result 0)) y-pass) 360 (:temporary (:sc signed-reg :offset nl2-offset :target r 361 :from (:argument 1) :to (:result 0)) res-pass) 362 (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) 363 (:temporary (:sc signed-reg :offset nl4-offset 364 :from (:argument 1) :to (:result 0)) sign) 365 (:temporary (:sc interior-reg :offset lip-offset) lip) 366 (:ignore lip sign) ; fix-lav: why dont we ignore tmp ? 367 (:generator 30 368 ;; looking at the register setup above, not sure if both can clash 369 ;; maybe it is ok that x and x-pass share register ? like it was 370 (unless (location= y y-pass) 371 (inst sra x 2 x-pass)) 372 (let ((fixup (make-fixup 'multiply :assembly-routine))) 373 (inst ldil fixup tmp) 374 (inst ble fixup lisp-heap-space tmp)) 375 (if (location= y y-pass) 376 (inst sra x 2 x-pass) 377 (inst move y y-pass)) 378 (move res-pass r))) 379 380(define-vop (fast-*/signed=>signed fast-signed-binop) 381 (:translate *) 382 (:args (x :scs (signed-reg) :target x-pass) 383 (y :scs (signed-reg) :target y-pass)) 384 (:temporary (:sc signed-reg :offset nl0-offset 385 :from (:argument 0) :to (:result 0)) x-pass) 386 (:temporary (:sc signed-reg :offset nl1-offset 387 :from (:argument 1) :to (:result 0)) y-pass) 388 (:temporary (:sc signed-reg :offset nl2-offset :target r 389 :from (:argument 1) :to (:result 0)) res-pass) 390 (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp) 391 (:temporary (:sc signed-reg :offset nl4-offset 392 :from (:argument 1) :to (:result 0)) sign) 393 (:temporary (:sc interior-reg :offset lip-offset) lip) 394 (:ignore lip sign) 395 (:generator 31 396 (let ((fixup (make-fixup 'multiply :assembly-routine))) 397 (move x x-pass) 398 (move y y-pass) 399 (inst ldil fixup tmp) 400 (inst ble fixup lisp-heap-space tmp) 401 (inst nop) 402 (move res-pass r)))) 403 404(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop) 405 (:translate *) 406 (:args (x :scs (unsigned-reg) :target x-pass) 407 (y :scs (unsigned-reg) :target y-pass)) 408 (:temporary (:sc unsigned-reg :offset nl0-offset 409 :from (:argument 0) :to (:result 0)) x-pass) 410 (:temporary (:sc unsigned-reg :offset nl1-offset 411 :from (:argument 1) :to (:result 0)) y-pass) 412 (:temporary (:sc unsigned-reg :offset nl2-offset :target r 413 :from (:argument 1) :to (:result 0)) res-pass) 414 (:temporary (:sc unsigned-reg :offset nl3-offset :to (:result 0)) tmp) 415 (:temporary (:sc unsigned-reg :offset nl4-offset 416 :from (:argument 1) :to (:result 0)) sign) 417 (:temporary (:sc interior-reg :offset lip-offset) lip) 418 (:ignore lip sign) 419 (:generator 31 420 (let ((fixup (make-fixup 'multiply :assembly-routine))) 421 (move x x-pass) 422 (move y y-pass) 423 (inst ldil fixup tmp) 424 (inst ble fixup lisp-heap-space tmp) 425 (inst nop) 426 (move res-pass r)))) 427 428(define-vop (fast-truncate/fixnum fast-fixnum-binop) 429 (:translate truncate) 430 (:args (x :scs (any-reg) :target x-pass) 431 (y :scs (any-reg) :target y-pass)) 432 (:temporary (:sc signed-reg :offset nl0-offset 433 :from (:argument 0) :to (:result 0)) x-pass) 434 (:temporary (:sc signed-reg :offset nl1-offset 435 :from (:argument 1) :to (:result 0)) y-pass) 436 (:temporary (:sc signed-reg :offset nl2-offset :target q 437 :from (:argument 1) :to (:result 0)) q-pass) 438 (:temporary (:sc signed-reg :offset nl3-offset :target r 439 :from (:argument 1) :to (:result 1)) r-pass) 440 (:results (q :scs (any-reg)) 441 (r :scs (any-reg))) 442 (:result-types tagged-num tagged-num) 443 (:vop-var vop) 444 (:save-p :compute-only) 445 (:generator 30 446 (let ((zero (generate-error-code vop 'division-by-zero-error x y))) 447 (inst bc := nil y zero-tn zero)) 448 (move x x-pass) 449 (move y y-pass) 450 (let ((fixup (make-fixup 'truncate :assembly-routine))) 451 (inst ldil fixup q-pass) 452 (inst ble fixup lisp-heap-space q-pass :nullify t)) 453 (inst nop) 454 (inst sll q-pass n-fixnum-tag-bits q) 455 ;(move q-pass q) 456 (move r-pass r))) 457 458#+(or) ;; This contains two largely-inexplicable hacks, and there's no 459 ;; equivalent VOP for either Alpha or ARM. Why is this even 460 ;; here? -- AB, 2015-11-19 461(define-vop (fast-truncate/unsigned fast-unsigned-binop) 462 (:translate truncate) 463 (:args (x :scs (unsigned-reg) :target x-pass) 464 (y :scs (unsigned-reg) :target y-pass)) 465 (:temporary (:sc unsigned-reg :offset nl0-offset 466 :from (:argument 0) :to (:result 0)) x-pass) 467 (:temporary (:sc unsigned-reg :offset nl1-offset 468 :from (:argument 1) :to (:result 0)) y-pass) 469 (:temporary (:sc unsigned-reg :offset nl2-offset :target q 470 :from (:argument 1) :to (:result 0)) q-pass) 471 (:temporary (:sc unsigned-reg :offset nl3-offset :target r 472 :from (:argument 1) :to (:result 1)) r-pass) 473 (:results (q :scs (unsigned-reg)) 474 (r :scs (unsigned-reg))) 475 (:result-types unsigned-num unsigned-num) 476 (:vop-var vop) 477 (:save-p :compute-only) 478 (:generator 35 479 (let ((zero (generate-error-code vop 'division-by-zero-error x y))) 480 (inst bc := nil y zero-tn zero)) 481 (move x x-pass) 482 (move y y-pass) 483 ;; really dirty trick to avoid the bug truncate/unsigned vop 484 ;; followed by move-from/word->fixnum where the result from 485 ;; the truncate is 0xe39516a7 and move-from-word will treat 486 ;; the unsigned high number as an negative number. 487 ;; instead we clear the high bit in the input to truncate. 488 (inst li #x1fffffff q) 489 (inst comb :<> q y skip :nullify t) 490 (inst addi -1 zero-tn q) 491 (inst srl q 1 q) ; this should result in #7fffffff 492 (inst and x-pass q x-pass) 493 (inst and y-pass q y-pass) 494 SKIP 495 ;; fix bug#2 (truncate #xe39516a7 #x3) => #0xf687078d,#x0 496 (inst li #x7fffffff q) 497 (inst and x-pass q x-pass) 498 (let ((fixup (make-fixup 'truncate :assembly-routine))) 499 (inst ldil fixup q-pass) 500 (inst ble fixup lisp-heap-space q-pass :nullify t)) 501 (inst nop) 502 (move q-pass q) 503 (move r-pass r))) 504 505(define-vop (fast-truncate/signed fast-signed-binop) 506 (:translate truncate) 507 (:args (x :scs (signed-reg) :target x-pass) 508 (y :scs (signed-reg) :target y-pass)) 509 (:temporary (:sc signed-reg :offset nl0-offset 510 :from (:argument 0) :to (:result 0)) x-pass) 511 (:temporary (:sc signed-reg :offset nl1-offset 512 :from (:argument 1) :to (:result 0)) y-pass) 513 (:temporary (:sc signed-reg :offset nl2-offset :target q 514 :from (:argument 1) :to (:result 0)) q-pass) 515 (:temporary (:sc signed-reg :offset nl3-offset :target r 516 :from (:argument 1) :to (:result 1)) r-pass) 517 (:results (q :scs (signed-reg)) 518 (r :scs (signed-reg))) 519 (:result-types signed-num signed-num) 520 (:vop-var vop) 521 (:save-p :compute-only) 522 (:generator 35 523 (let ((zero (generate-error-code vop 'division-by-zero-error x y))) 524 (inst bc := nil y zero-tn zero)) 525 (move x x-pass) 526 (move y y-pass) 527 (let ((fixup (make-fixup 'truncate :assembly-routine))) 528 (inst ldil fixup q-pass) 529 (inst ble fixup lisp-heap-space q-pass :nullify t)) 530 (inst nop) 531 (move q-pass q) 532 (move r-pass r))) 533 534 535;;;; Binary conditional VOPs: 536 537(define-vop (fast-conditional) 538 (:conditional) 539 (:info target not-p) 540 (:effects) 541 (:affected) 542 (:policy :fast-safe)) 543 544(define-vop (fast-conditional/fixnum fast-conditional) 545 (:args (x :scs (any-reg)) 546 (y :scs (any-reg))) 547 (:arg-types tagged-num tagged-num) 548 (:note "inline fixnum comparison")) 549 550(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum) 551 (:args (x :scs (any-reg))) 552 (:arg-types tagged-num (:constant (signed-byte 9))) 553 (:info target not-p y)) 554 555(define-vop (fast-conditional/signed fast-conditional) 556 (:args (x :scs (signed-reg)) 557 (y :scs (signed-reg))) 558 (:arg-types signed-num signed-num) 559 (:note "inline (signed-byte 32) comparison")) 560 561(define-vop (fast-conditional-c/signed fast-conditional/signed) 562 (:args (x :scs (signed-reg))) 563 (:arg-types signed-num (:constant (signed-byte 11))) 564 (:info target not-p y)) 565 566(define-vop (fast-conditional/unsigned fast-conditional) 567 (:args (x :scs (unsigned-reg)) 568 (y :scs (unsigned-reg))) 569 (:arg-types unsigned-num unsigned-num) 570 (:note "inline (unsigned-byte 32) comparison")) 571 572(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned) 573 (:args (x :scs (unsigned-reg))) 574 (:arg-types unsigned-num (:constant (signed-byte 11))) 575 (:info target not-p y)) 576 577 578(defmacro define-conditional-vop (translate signed-cond unsigned-cond) 579 `(progn 580 ,@(mapcar #'(lambda (suffix cost signed imm) 581 (unless (and (member suffix '(/fixnum -c/fixnum)) 582 (eq translate 'eql)) 583 `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)" 584 translate suffix)) 585 ,(intern 586 (format nil "~:@(FAST-CONDITIONAL~A~)" 587 suffix))) 588 (:translate ,translate) 589 (:generator ,cost 590 (inst ,(if imm 'bci 'bc) 591 ,(if signed signed-cond unsigned-cond) 592 not-p 593 ,(if (eq suffix '-c/fixnum) 594 '(fixnumize y) 595 'y) 596 x 597 target))))) 598 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) 599 '(3 2 5 4 5 4) 600 '(t t t t nil nil) 601 '(nil t nil t nil t)))) 602 603;; We switch < and > because the immediate has to come first. 604 605(define-conditional-vop < :> :>>) 606(define-conditional-vop > :< :<<) 607 608;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a 609;;; known fixnum. 610;;; 611(define-conditional-vop eql := :=) 612 613;;; These versions specify a fixnum restriction on their first arg. We have 614;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on 615;;; the first arg and a higher cost. The reason for doing this is to prevent 616;;; fixnum specific operations from being used on word integers, spuriously 617;;; consing the argument. 618;;; 619(define-vop (fast-eql/fixnum fast-conditional) 620 (:args (x :scs (any-reg)) 621 (y :scs (any-reg))) 622 (:arg-types tagged-num tagged-num) 623 (:note "inline fixnum comparison") 624 (:translate eql) 625 (:generator 3 626 (inst bc := not-p x y target))) 627;;; 628(define-vop (generic-eql/fixnum fast-eql/fixnum) 629 (:args (x :scs (any-reg descriptor-reg)) 630 (y :scs (any-reg))) 631 (:arg-types * tagged-num) 632 (:variant-cost 7)) 633 634(define-vop (fast-eql-c/fixnum fast-conditional/fixnum) 635 (:args (x :scs (any-reg))) 636 (:arg-types tagged-num (:constant (signed-byte 9))) 637 (:info target not-p y) 638 (:translate eql) 639 (:generator 2 640 (inst bci := not-p (fixnumize y) x target))) 641;;; 642(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum) 643 (:args (x :scs (any-reg descriptor-reg))) 644 (:arg-types * (:constant (signed-byte 9))) 645 (:variant-cost 6)) 646 647 648;;;; modular functions 649(define-modular-fun +-mod32 (x y) + :untagged nil 32) 650(define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned) 651 (:translate +-mod32)) 652(define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned) 653 (:translate +-mod32)) 654(define-modular-fun --mod32 (x y) - :untagged nil 32) 655(define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned) 656 (:translate --mod32)) 657(define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned) 658 (:translate --mod32)) 659 660(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned 661 fast-ash-c/unsigned=>unsigned) 662 (:translate ash-left-mod32)) 663 664(define-vop (fast-ash-left-mod32/unsigned=>unsigned 665 fast-ash-left/unsigned=>unsigned)) 666(deftransform ash-left-mod32 ((integer count) 667 ((unsigned-byte 32) (unsigned-byte 5))) 668 (when (sb!c::constant-lvar-p count) 669 (sb!c::give-up-ir1-transform)) 670 '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count)) 671 672;;; logical operations 673(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32) 674(define-vop (lognot-mod32/unsigned=>unsigned) 675 (:translate lognot-mod32) 676 (:args (x :scs (unsigned-reg))) 677 (:arg-types unsigned-num) 678 (:results (res :scs (unsigned-reg))) 679 (:result-types unsigned-num) 680 (:policy :fast-safe) 681 (:generator 1 682 (inst uaddcm zero-tn x res))) 683 684(define-modular-fun lognor-mod32 (x y) lognor :untagged nil 32) 685(define-vop (fast-lognor-mod32/unsigned=>unsigned 686 fast-lognor/unsigned=>unsigned) 687 (:translate lognor-mod32)) 688 689(define-source-transform logeqv (&rest args) 690 (if (oddp (length args)) 691 `(logxor ,@args) 692 `(lognot (logxor ,@args)))) 693(define-source-transform logorc1 (x y) 694 `(logior (lognot ,x) ,y)) 695(define-source-transform logorc2 (x y) 696 `(logior ,x (lognot ,y))) 697(define-source-transform lognand (x y) 698 `(lognot (logand ,x ,y))) 699(define-source-transform lognor (x y) 700 `(lognot (logior ,x ,y))) 701 702(define-vop (shift-towards-someplace) 703 (:policy :fast-safe) 704 (:args (num :scs (unsigned-reg)) 705 (amount :scs (signed-reg))) 706 (:arg-types unsigned-num tagged-num) 707 (:results (r :scs (unsigned-reg))) 708 (:result-types unsigned-num)) 709 710(define-vop (shift-towards-start shift-towards-someplace) 711 (:translate shift-towards-start) 712 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) 713 (:note "SHIFT-TOWARDS-START") 714 (:generator 1 715 (inst subi 31 amount temp) 716 (inst mtctl temp :sar) 717 (inst zdep num :variable 32 r))) 718 719(define-vop (shift-towards-end shift-towards-someplace) 720 (:translate shift-towards-end) 721 (:note "SHIFT-TOWARDS-END") 722 (:generator 1 723 (inst mtctl amount :sar) 724 (inst shd zero-tn num :variable r))) 725 726 727 728;;;; Bignum stuff. 729 730(define-vop (bignum-length get-header-data) 731 (:translate sb!bignum:%bignum-length) 732 (:policy :fast-safe)) 733 734(define-vop (bignum-set-length set-header-data) 735 (:translate sb!bignum:%bignum-set-length) 736 (:policy :fast-safe)) 737 738(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag 739 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref) 740 741(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag 742 (unsigned-reg) unsigned-num sb!bignum:%bignum-set) 743 744(define-vop (digit-0-or-plus) 745 (:translate sb!bignum:%digit-0-or-plusp) 746 (:policy :fast-safe) 747 (:args (digit :scs (unsigned-reg))) 748 (:arg-types unsigned-num) 749 (:conditional) 750 (:info target not-p) 751 (:generator 2 752 (inst bc :>= not-p digit zero-tn target))) 753 754(define-vop (add-w/carry) 755 (:translate sb!bignum:%add-with-carry) 756 (:policy :fast-safe) 757 (:args (a :scs (unsigned-reg)) 758 (b :scs (unsigned-reg)) 759 (c :scs (any-reg))) 760 (:arg-types unsigned-num unsigned-num positive-fixnum) 761 (:results (result :scs (unsigned-reg)) 762 (carry :scs (unsigned-reg))) 763 (:result-types unsigned-num positive-fixnum) 764 (:generator 3 765 (inst addi -1 c zero-tn) 766 (inst addc a b result) 767 (inst addc zero-tn zero-tn carry))) 768 769(define-vop (sub-w/borrow) 770 (:translate sb!bignum:%subtract-with-borrow) 771 (:policy :fast-safe) 772 (:args (a :scs (unsigned-reg)) 773 (b :scs (unsigned-reg)) 774 (c :scs (unsigned-reg))) 775 (:arg-types unsigned-num unsigned-num positive-fixnum) 776 (:results (result :scs (unsigned-reg)) 777 (borrow :scs (unsigned-reg))) 778 (:result-types unsigned-num positive-fixnum) 779 (:generator 4 780 (inst addi -1 c zero-tn) 781 (inst subb a b result) 782 (inst addc zero-tn zero-tn borrow))) 783 784(define-vop (bignum-mult) 785 (:translate sb!bignum:%multiply) 786 (:policy :fast-safe) 787 (:args (x-arg :scs (unsigned-reg) :target x) 788 (y-arg :scs (unsigned-reg) :target y)) 789 (:arg-types unsigned-num unsigned-num) 790 (:temporary (:scs (signed-reg) :from (:argument 0)) x) 791 (:temporary (:scs (signed-reg) :from (:argument 1)) y) 792 (:temporary (:scs (signed-reg)) tmp) 793 (:results (hi :scs (unsigned-reg)) 794 (lo :scs (unsigned-reg))) 795 (:result-types unsigned-num unsigned-num) 796 (:generator 3 797 ;; Make sure X is less then Y. 798 (inst comclr x-arg y-arg tmp :<<) 799 (inst xor x-arg y-arg tmp) 800 (inst xor x-arg tmp x) 801 (inst xor y-arg tmp y) 802 803 ;; Blow out of here if the result is zero. 804 (inst li 0 hi) 805 (inst comb := x zero-tn done) 806 (inst li 0 lo) 807 (inst li 0 tmp) 808 809 LOOP 810 (inst comb :ev x zero-tn next-bit) 811 (inst srl x 1 x) 812 (inst add lo y lo) 813 (inst addc hi tmp hi) 814 NEXT-BIT 815 (inst add y y y) 816 (inst comb :<> x zero-tn loop) 817 (inst addc tmp tmp tmp) 818 819 DONE)) 820 821(define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0)) 822 #+nil ;; This would be greate if it worked, but it doesn't. 823 (if (eql extra 0) 824 `(multiple-value-call #'sb!bignum:%dual-word-add 825 (sb!bignum:%multiply ,x ,y) 826 (values ,carry)) 827 `(multiple-value-call #'sb!bignum:%dual-word-add 828 (multiple-value-call #'sb!bignum:%dual-word-add 829 (sb!bignum:%multiply ,x ,y) 830 (values ,carry)) 831 (values ,extra))) 832 (with-unique-names (hi lo) 833 (if (eql extra 0) 834 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y) 835 (sb!bignum::%dual-word-add ,hi ,lo ,carry)) 836 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y) 837 (multiple-value-bind 838 (,hi ,lo) 839 (sb!bignum::%dual-word-add ,hi ,lo ,carry) 840 (sb!bignum::%dual-word-add ,hi ,lo ,extra)))))) 841 842(defknown sb!bignum::%dual-word-add 843 (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type) 844 (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type) 845 (flushable movable)) 846 847(define-vop (dual-word-add) 848 (:policy :fast-safe) 849 (:translate sb!bignum::%dual-word-add) 850 (:args (hi :scs (unsigned-reg) :to (:result 1)) 851 (lo :scs (unsigned-reg)) 852 (extra :scs (unsigned-reg))) 853 (:arg-types unsigned-num unsigned-num unsigned-num) 854 (:results (hi-res :scs (unsigned-reg) :from (:result 1)) 855 (lo-res :scs (unsigned-reg) :from (:result 0))) 856 (:result-types unsigned-num unsigned-num) 857 (:affected) 858 (:effects) 859 (:generator 3 860 (inst add lo extra lo-res) 861 (inst addc hi zero-tn hi-res))) 862 863(define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned) 864 (:translate sb!bignum:%lognot)) 865 866(define-vop (fixnum-to-digit) 867 (:translate sb!bignum:%fixnum-to-digit) 868 (:policy :fast-safe) 869 (:args (fixnum :scs (any-reg))) 870 (:arg-types tagged-num) 871 (:results (digit :scs (unsigned-reg))) 872 (:result-types unsigned-num) 873 (:generator 1 874 (inst sra fixnum n-fixnum-tag-bits digit))) 875 876(define-vop (bignum-floor) 877 (:translate sb!bignum:%bigfloor) 878 (:policy :fast-safe) 879 (:args (hi :scs (unsigned-reg) :to (:argument 1)) 880 (lo :scs (unsigned-reg) :to (:argument 0)) 881 (divisor :scs (unsigned-reg))) 882 (:arg-types unsigned-num unsigned-num unsigned-num) 883 (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp) 884 (:results (quo :scs (unsigned-reg) :from (:argument 0)) 885 (rem :scs (unsigned-reg) :from (:argument 1))) 886 (:result-types unsigned-num unsigned-num) 887 (:generator 65 888 (inst sub zero-tn divisor temp) 889 (inst ds zero-tn temp zero-tn) 890 (inst add lo lo quo) 891 (inst ds hi divisor rem) 892 (inst addc quo quo quo) 893 (dotimes (i 31) 894 (inst ds rem divisor rem) 895 (inst addc quo quo quo)) 896 (inst comclr rem zero-tn zero-tn :>=) 897 (inst add divisor rem rem))) 898 899(define-vop (signify-digit) 900 (:translate sb!bignum:%fixnum-digit-with-correct-sign) 901 (:policy :fast-safe) 902 (:args (digit :scs (unsigned-reg) :target res)) 903 (:arg-types unsigned-num) 904 (:results (res :scs (any-reg signed-reg))) 905 (:result-types signed-num) 906 (:generator 1 907 (sc-case res 908 (any-reg 909 (inst sll digit n-fixnum-tag-bits res)) 910 (signed-reg 911 (move digit res))))) 912 913(define-vop (digit-lshr) 914 (:translate sb!bignum:%digit-logical-shift-right) 915 (:policy :fast-safe) 916 (:args (digit :scs (unsigned-reg)) 917 (count :scs (unsigned-reg))) 918 (:arg-types unsigned-num positive-fixnum) 919 (:results (result :scs (unsigned-reg))) 920 (:result-types unsigned-num) 921 (:generator 2 922 (inst mtctl count :sar) 923 (inst shd zero-tn digit :variable result))) 924 925(define-vop (digit-ashr digit-lshr) 926 (:translate sb!bignum:%ashr) 927 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp) 928 (:generator 1 929 (inst extrs digit 0 1 temp) 930 (inst mtctl count :sar) 931 (inst shd temp digit :variable result))) 932 933(define-vop (digit-ashl digit-ashr) 934 (:translate sb!bignum:%ashl) 935 (:generator 1 936 (inst subi 31 count temp) 937 (inst mtctl temp :sar) 938 (inst zdep digit :variable 32 result))) 939 940 941;;;; Static functions. 942 943(define-static-fun two-arg-gcd (x y) :translate gcd) 944(define-static-fun two-arg-lcm (x y) :translate lcm) 945 946(define-static-fun two-arg-+ (x y) :translate +) 947(define-static-fun two-arg-- (x y) :translate -) 948(define-static-fun two-arg-* (x y) :translate *) 949(define-static-fun two-arg-/ (x y) :translate /) 950 951(define-static-fun two-arg-< (x y) :translate <) 952(define-static-fun two-arg-<= (x y) :translate <=) 953(define-static-fun two-arg-> (x y) :translate >) 954(define-static-fun two-arg->= (x y) :translate >=) 955(define-static-fun two-arg-= (x y) :translate =) 956(define-static-fun two-arg-/= (x y) :translate /=) 957 958(define-static-fun %negate (x) :translate %negate) 959 960(define-static-fun two-arg-and (x y) :translate logand) 961(define-static-fun two-arg-ior (x y) :translate logior) 962(define-static-fun two-arg-xor (x y) :translate logxor) 963 964