src/assembly/sparc/arith.lisp

   1 ;;;; Stuff to handle simple cases for generic arithmetic.
   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 \f
  14 ;;;; Addition and subtraction.
  15
  16 (define-assembly-routine (generic-+
  17                           (:cost 10)
  18                           (:return-style :full-call)
  19                           (:translate +)
  20                           (:policy :safe)
  21                           (:save-p t))
  22                          ((:arg x (descriptor-reg any-reg) a0-offset)
  23                           (:arg y (descriptor-reg any-reg) a1-offset)
  24
  25                           (:res res (descriptor-reg any-reg) a0-offset)
  26
  27                           (:temp temp non-descriptor-reg nl0-offset)
  28                           (:temp temp2 non-descriptor-reg nl1-offset)
  29                           (:temp lra descriptor-reg lra-offset)
  30                           (:temp nargs any-reg nargs-offset)
  31                           (:temp ocfp any-reg ocfp-offset))
  32   (inst andcc zero-tn x fixnum-tag-mask)
  33   (inst b :ne DO-STATIC-FUN)
  34   (inst andcc zero-tn y fixnum-tag-mask)
  35   (inst b :ne DO-STATIC-FUN)
  36   (inst nop)
  37   (inst addcc temp x y)
  38   (inst b :vc done)
  39   (inst nop)
  40
  41   (inst sra temp x fixnum-tag-bits)
  42   (inst sra temp2 y fixnum-tag-bits)
  43   (inst add temp2 temp)
  44   (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
  45     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
  46   (lisp-return lra :offset 2)
  47
  48   DO-STATIC-FUN
  49   (inst ld code-tn null-tn (static-fun-offset 'two-arg-+))
  50   (inst li nargs (fixnumize 2))
  51   (inst move ocfp cfp-tn)
  52   (inst j code-tn
  53         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
  54   (inst move cfp-tn csp-tn)
  55
  56   DONE
  57   (move res temp))
  58
  59
  60 (define-assembly-routine (generic--
  61                           (:cost 10)
  62                           (:return-style :full-call)
  63                           (:translate -)
  64                           (:policy :safe)
  65                           (:save-p t))
  66                          ((:arg x (descriptor-reg any-reg) a0-offset)
  67                           (:arg y (descriptor-reg any-reg) a1-offset)
  68
  69                           (:res res (descriptor-reg any-reg) a0-offset)
  70
  71                           (:temp temp non-descriptor-reg nl0-offset)
  72                           (:temp temp2 non-descriptor-reg nl1-offset)
  73                           (:temp lra descriptor-reg lra-offset)
  74                           (:temp nargs any-reg nargs-offset)
  75                           (:temp ocfp any-reg ocfp-offset))
  76   (inst andcc zero-tn x fixnum-tag-mask)
  77   (inst b :ne DO-STATIC-FUN)
  78   (inst andcc zero-tn y fixnum-tag-mask)
  79   (inst b :ne DO-STATIC-FUN)
  80   (inst nop)
  81   (inst subcc temp x y)
  82   (inst b :vc done)
  83   (inst nop)
  84
  85   (inst sra temp x fixnum-tag-bits)
  86   (inst sra temp2 y fixnum-tag-bits)
  87   (inst sub temp2 temp temp2)
  88   (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
  89     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
  90   (lisp-return lra :offset 2)
  91
  92   DO-STATIC-FUN
  93   (inst ld code-tn null-tn (static-fun-offset 'two-arg--))
  94   (inst li nargs (fixnumize 2))
  95   (inst move ocfp cfp-tn)
  96   (inst j code-tn
  97         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
  98   (inst move cfp-tn csp-tn)
  99
 100   DONE
 101   (move res temp))
 102
 103
 104 \f
 105 ;;;; Multiplication
 106
 107
 108 (define-assembly-routine (generic-*
 109                           (:cost 50)
 110                           (:return-style :full-call)
 111                           (:translate *)
 112                           (:policy :safe)
 113                           (:save-p t))
 114                          ((:arg x (descriptor-reg any-reg) a0-offset)
 115                           (:arg y (descriptor-reg any-reg) a1-offset)
 116
 117                           (:res res (descriptor-reg any-reg) a0-offset)
 118
 119                           (:temp temp non-descriptor-reg nl0-offset)
 120                           (:temp lo non-descriptor-reg nl1-offset)
 121                           (:temp hi non-descriptor-reg nl2-offset)
 122                           (:temp lra descriptor-reg lra-offset)
 123                           (:temp nargs any-reg nargs-offset)
 124                           (:temp ocfp any-reg ocfp-offset))
 125   ;; If either arg is not a fixnum, call the static function.
 126   (inst andcc zero-tn x fixnum-tag-mask)
 127   (inst b :ne DO-STATIC-FUN)
 128   (inst andcc zero-tn y fixnum-tag-mask)
 129   (inst b :ne DO-STATIC-FUN)
 130   (inst nop)
 131
 132   ;; Remove the tag from one arg so that the result will have the correct
 133   ;; fixnum tag.
 134   (inst sra temp x fixnum-tag-bits)
 135   ;; Compute the produce temp * y and return the double-word product
 136   ;; in hi:lo.
 137   ;;
 138   ;; FIXME: Note that the below shebang read-time conditionals aren't
 139   ;; actually shebang. This is because the assembly files are also
 140   ;; built in warm-init, when #! is not a defined read-macro. This
 141   ;; problem will actually go away when we rewrite these low-level
 142   ;; bits and pieces to use the backend-subfeatures machinery, as we
 143   ;; will then conditionalize at code-emission time or assembly time
 144   ;; for the VOP and the assembly routine respectively. - CSR,
 145   ;; 2002-02-11
 146   #+:sparc-64
 147   ;; Sign extend y to a full 64-bits.  temp was already
 148   ;; sign-extended by the sra instruction above.
 149   (progn
 150     (inst sra y 0)
 151     (inst mulx hi temp y)
 152     (inst move lo hi)
 153     (inst srax hi 32))
 154   #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
 155   (progn
 156     (inst smul lo temp y)
 157     (inst rdy hi))
 158   #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
 159   (let ((MULTIPLIER-POSITIVE (gen-label)))
 160     (inst wry temp)
 161     (inst andcc hi zero-tn)
 162     (inst nop)
 163     (inst nop)
 164     (dotimes (i 32)
 165       (inst mulscc hi y))
 166     (inst mulscc hi zero-tn)
 167     (inst cmp x)
 168     (inst b :ge MULTIPLIER-POSITIVE)
 169     (inst nop)
 170     (inst sub hi y)
 171     (emit-label MULTIPLIER-POSITIVE)
 172     (inst rdy lo))
 173
 174   ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
 175   ;; is just 32 copies of the sign bit of the low word).
 176   (inst sra temp lo 31)
 177   (inst xorcc temp hi)
 178   (inst b :eq LOW-FITS-IN-FIXNUM)
 179   ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
 180   (inst sll temp hi 30)
 181   (inst srl lo fixnum-tag-bits)
 182   (inst or lo temp)
 183   (inst sra hi fixnum-tag-bits)
 184   ;; Allocate a BIGNUM for the result.
 185   #+nil
 186   (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
 187     (let ((one-word (gen-label)))
 188       (inst or res alloc-tn other-pointer-lowtag)
 189       ;; We start out assuming that we need one word.  Is that correct?
 190       (inst sra temp lo 31)
 191       (inst xorcc temp hi)
 192       (inst b :eq one-word)
 193       (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
 194       ;; Nope, we need two, so allocate the addition space.
 195       (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
 196                             (pad-data-block (1+ bignum-digits-offset))))
 197       (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
 198       (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
 199       (emit-label one-word)
 200       (storew temp res 0 other-pointer-lowtag)
 201       (storew lo res bignum-digits-offset other-pointer-lowtag)))
 202   ;; Always allocate 2 words for the bignum result, even if we only
 203   ;; need one.  The copying GC will take care of the extra word if it
 204   ;; isn't needed.
 205   (with-fixed-allocation
 206       (res temp bignum-widetag (+ 2 bignum-digits-offset))
 207     (let ((one-word (gen-label)))
 208       (inst or res alloc-tn other-pointer-lowtag)
 209       ;; We start out assuming that we need one word.  Is that correct?
 210       (inst sra temp lo 31)
 211       (inst xorcc temp hi)
 212       (inst b :eq one-word)
 213       (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
 214       ;; Need 2 words.  Set the header appropriately, and save the
 215       ;; high and low parts.
 216       (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
 217       (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
 218       (emit-label one-word)
 219       (storew temp res 0 other-pointer-lowtag)
 220       (storew lo res bignum-digits-offset other-pointer-lowtag)))
 221   ;; Out of here
 222   (lisp-return lra :offset 2)
 223
 224   DO-STATIC-FUN
 225   (inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
 226   (inst li nargs (fixnumize 2))
 227   (inst move ocfp cfp-tn)
 228   (inst j code-tn
 229         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
 230   (inst move cfp-tn csp-tn)
 231
 232   LOW-FITS-IN-FIXNUM
 233   (move res lo))
 234
 235 (macrolet
 236     ((frob (name note cost type sc)
 237        `(define-assembly-routine (,name
 238                                   (:note ,note)
 239                                   (:cost ,cost)
 240                                   (:translate *)
 241                                   (:policy :fast-safe)
 242                                   (:arg-types ,type ,type)
 243                                   (:result-types ,type))
 244                                  ((:arg x ,sc nl0-offset)
 245                                   (:arg y ,sc nl1-offset)
 246                                   (:res res ,sc nl0-offset)
 247                                   (:temp temp ,sc nl2-offset))
 248           ,@(when (eq type 'tagged-num)
 249               `((inst sra x 2)))
 250          #+:sparc-64
 251          ;; Sign extend, then multiply
 252          (progn
 253            (inst sra x 0)
 254            (inst sra y 0)
 255            (inst mulx res x y))
 256          #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
 257          (inst smul res x y)
 258          #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
 259          (progn
 260            (inst wry x)
 261            (inst andcc temp zero-tn)
 262            (inst nop)
 263            (inst nop)
 264            (dotimes (i 32)
 265              (inst mulscc temp y))
 266            (inst mulscc temp zero-tn)
 267            (inst rdy res)))))
 268   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
 269   (frob signed-* "unsigned *" 41 signed-num signed-reg)
 270   (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
 271
 272
 273 \f
 274 ;;;; Division.
 275
 276 #+sb-assembling
 277 (defun emit-divide-loop (divisor rem quo tagged)
 278   (inst li quo 0)
 279   (labels
 280       ((do-loop (depth)
 281          (cond
 282           ((zerop depth)
 283            (inst unimp 0))
 284           (t
 285            (let ((label-1 (gen-label))
 286                  (label-2 (gen-label)))
 287              (inst cmp divisor rem)
 288              (inst b :geu label-1)
 289              (inst nop)
 290              (inst sll divisor 1)
 291              (do-loop (1- depth))
 292              (inst srl divisor 1)
 293              (inst cmp divisor rem)
 294              (emit-label label-1)
 295              (inst b :gtu label-2)
 296              (inst sll quo 1)
 297              (inst add quo (if tagged (fixnumize 1) 1))
 298              (inst sub rem divisor)
 299              (emit-label label-2))))))
 300     (do-loop (if tagged 30 32))))
 301
 302 (define-assembly-routine (positive-fixnum-truncate
 303                           (:note "unsigned fixnum truncate")
 304                           (:cost 45)
 305                           (:translate truncate)
 306                           (:policy :fast-safe)
 307                           (:arg-types positive-fixnum positive-fixnum)
 308                           (:result-types positive-fixnum positive-fixnum))
 309                          ((:arg dividend any-reg nl0-offset)
 310                           (:arg divisor any-reg nl1-offset)
 311
 312                           (:res quo any-reg nl2-offset)
 313                           (:res rem any-reg nl0-offset))
 314
 315   (let ((error (generate-error-code nil division-by-zero-error
 316                                     dividend divisor)))
 317     (inst cmp divisor)
 318     (inst b :eq error))
 319
 320   (move rem dividend)
 321   (emit-divide-loop divisor rem quo t))
 322
 323
 324 (define-assembly-routine (fixnum-truncate
 325                           (:note "fixnum truncate")
 326                           (:cost 50)
 327                           (:policy :fast-safe)
 328                           (:translate truncate)
 329                           (:arg-types tagged-num tagged-num)
 330                           (:result-types tagged-num tagged-num))
 331                          ((:arg dividend any-reg nl0-offset)
 332                           (:arg divisor any-reg nl1-offset)
 333
 334                           (:res quo any-reg nl2-offset)
 335                           (:res rem any-reg nl0-offset)
 336
 337                           (:temp quo-sign any-reg nl5-offset)
 338                           (:temp rem-sign any-reg nargs-offset))
 339
 340   (let ((error (generate-error-code nil division-by-zero-error
 341                                     dividend divisor)))
 342     (inst cmp divisor)
 343     (inst b :eq error))
 344
 345   (inst xor quo-sign dividend divisor)
 346   (inst move rem-sign dividend)
 347   (let ((label (gen-label)))
 348     (inst cmp dividend)
 349     (inst ba :lt label)
 350     (inst neg dividend)
 351     (emit-label label))
 352   (let ((label (gen-label)))
 353     (inst cmp divisor)
 354     (inst ba :lt label)
 355     (inst neg divisor)
 356     (emit-label label))
 357   (move rem dividend)
 358   (emit-divide-loop divisor rem quo t)
 359   (let ((label (gen-label)))
 360     ;; If the quo-sign is negative, we need to negate quo.
 361     (inst cmp quo-sign)
 362     (inst ba :lt label)
 363     (inst neg quo)
 364     (emit-label label))
 365   (let ((label (gen-label)))
 366     ;; If the rem-sign is negative, we need to negate rem.
 367     (inst cmp rem-sign)
 368     (inst ba :lt label)
 369     (inst neg rem)
 370     (emit-label label)))
 371
 372
 373 (define-assembly-routine (signed-truncate
 374                           (:note "(signed-byte 32) truncate")
 375                           (:cost 60)
 376                           (:policy :fast-safe)
 377                           (:translate truncate)
 378                           (:arg-types signed-num signed-num)
 379                           (:result-types signed-num signed-num))
 380
 381                          ((:arg dividend signed-reg nl0-offset)
 382                           (:arg divisor signed-reg nl1-offset)
 383
 384                           (:res quo signed-reg nl2-offset)
 385                           (:res rem signed-reg nl0-offset)
 386
 387                           (:temp quo-sign signed-reg nl5-offset)
 388                           (:temp rem-sign signed-reg nargs-offset))
 389
 390   (let ((error (generate-error-code nil division-by-zero-error
 391                                     dividend divisor)))
 392     (inst cmp divisor)
 393     (inst b :eq error))
 394
 395   (inst xor quo-sign dividend divisor)
 396   (inst move rem-sign dividend)
 397   (let ((label (gen-label)))
 398     (inst cmp dividend)
 399     (inst ba :lt label)
 400     (inst neg dividend)
 401     (emit-label label))
 402   (let ((label (gen-label)))
 403     (inst cmp divisor)
 404     (inst ba :lt label)
 405     (inst neg divisor)
 406     (emit-label label))
 407   (move rem dividend)
 408   (emit-divide-loop divisor rem quo nil)
 409   (let ((label (gen-label)))
 410     ;; If the quo-sign is negative, we need to negate quo.
 411     (inst cmp quo-sign)
 412     (inst ba :lt label)
 413     (inst neg quo)
 414     (emit-label label))
 415   (let ((label (gen-label)))
 416     ;; If the rem-sign is negative, we need to negate rem.
 417     (inst cmp rem-sign)
 418     (inst ba :lt label)
 419     (inst neg rem)
 420     (emit-label label)))
 421
 422 \f
 423 ;;;; Comparison
 424
 425 (macrolet
 426     ((define-cond-assem-rtn (name translate static-fn cmp)
 427        `(define-assembly-routine (,name
 428                                   (:cost 10)
 429                                   (:return-style :full-call)
 430                                   (:policy :safe)
 431                                   (:translate ,translate)
 432                                   (:save-p t))
 433                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 434                                   (:arg y (descriptor-reg any-reg) a1-offset)
 435
 436                                   (:res res descriptor-reg a0-offset)
 437
 438                                   (:temp nargs any-reg nargs-offset)
 439                                   (:temp ocfp any-reg ocfp-offset))
 440           (inst andcc zero-tn x fixnum-tag-mask)
 441           (inst b :ne DO-STATIC-FN)
 442           (inst andcc zero-tn y fixnum-tag-mask)
 443           (inst b :eq DO-COMPARE)
 444           (inst cmp x y)
 445
 446           DO-STATIC-FN
 447           (inst ld code-tn null-tn (static-fun-offset ',static-fn))
 448           (inst li nargs (fixnumize 2))
 449           (inst move ocfp cfp-tn)
 450           (inst j code-tn
 451                 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
 452           (inst move cfp-tn csp-tn)
 453
 454           DO-COMPARE
 455           (inst b ,cmp done)
 456           (load-symbol res t)
 457           (inst move res null-tn)
 458           DONE)))
 459
 460   (define-cond-assem-rtn generic-< < two-arg-< :lt)
 461   (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
 462   (define-cond-assem-rtn generic-> > two-arg-> :gt)
 463   (define-cond-assem-rtn generic->= >= two-arg->= :ge))
 464
 465
 466 (define-assembly-routine (generic-eql
 467                           (:cost 10)
 468                           (:return-style :full-call)
 469                           (:policy :safe)
 470                           (:translate eql)
 471                           (:save-p t))
 472                          ((:arg x (descriptor-reg any-reg) a0-offset)
 473                           (:arg y (descriptor-reg any-reg) a1-offset)
 474
 475                           (:res res descriptor-reg a0-offset)
 476
 477                           (:temp lra descriptor-reg lra-offset)
 478                           (:temp nargs any-reg nargs-offset)
 479                           (:temp ocfp any-reg ocfp-offset))
 480   (inst cmp x y)
 481   (inst b :eq RETURN-T)
 482   (inst andcc zero-tn x fixnum-tag-mask)
 483   (inst b :eq RETURN-NIL)
 484   (inst andcc zero-tn y fixnum-tag-mask)
 485   (inst b :ne DO-STATIC-FN)
 486   (inst nop)
 487
 488   RETURN-NIL
 489   (inst move res null-tn)
 490   (lisp-return lra :offset 2)
 491
 492   DO-STATIC-FN
 493   (inst ld code-tn null-tn (static-fun-offset 'eql))
 494   (inst li nargs (fixnumize 2))
 495   (inst move ocfp cfp-tn)
 496   (inst j code-tn
 497         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
 498   (inst move cfp-tn csp-tn)
 499
 500   RETURN-T
 501   (load-symbol res t))
 502
 503 (define-assembly-routine (generic-=
 504                           (:cost 10)
 505                           (:return-style :full-call)
 506                           (:policy :safe)
 507                           (:translate =)
 508                           (:save-p t))
 509                          ((:arg x (descriptor-reg any-reg) a0-offset)
 510                           (:arg y (descriptor-reg any-reg) a1-offset)
 511
 512                           (:res res descriptor-reg a0-offset)
 513
 514                           (:temp lra descriptor-reg lra-offset)
 515                           (:temp nargs any-reg nargs-offset)
 516                           (:temp ocfp any-reg ocfp-offset))
 517   (inst andcc zero-tn x fixnum-tag-mask)
 518   (inst b :ne DO-STATIC-FN)
 519   (inst andcc zero-tn y fixnum-tag-mask)
 520   (inst b :ne DO-STATIC-FN)
 521   (inst cmp x y)
 522   (inst b :eq RETURN-T)
 523   (inst nop)
 524
 525   (inst move res null-tn)
 526   (lisp-return lra :offset 2)
 527
 528   DO-STATIC-FN
 529   (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
 530   (inst li nargs (fixnumize 2))
 531   (inst move ocfp cfp-tn)
 532   (inst j code-tn
 533         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
 534   (inst move cfp-tn csp-tn)
 535
 536   RETURN-T
 537   (load-symbol res t))
 538
 539 (define-assembly-routine (generic-/=
 540                           (:cost 10)
 541                           (:return-style :full-call)
 542                           (:policy :safe)
 543                           (:translate /=)
 544                           (:save-p t))
 545                          ((:arg x (descriptor-reg any-reg) a0-offset)
 546                           (:arg y (descriptor-reg any-reg) a1-offset)
 547
 548                           (:res res descriptor-reg a0-offset)
 549
 550                           (:temp lra descriptor-reg lra-offset)
 551                           (:temp nargs any-reg nargs-offset)
 552                           (:temp ocfp any-reg ocfp-offset))
 553   (inst cmp x y)
 554   (inst b :eq RETURN-NIL)
 555   (inst andcc zero-tn x fixnum-tag-mask)
 556   (inst b :ne DO-STATIC-FN)
 557   (inst andcc zero-tn y fixnum-tag-mask)
 558   (inst b :ne DO-STATIC-FN)
 559   (inst nop)
 560
 561   (load-symbol res t)
 562   (lisp-return lra :offset 2)
 563
 564   DO-STATIC-FN
 565   (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
 566   (inst li nargs (fixnumize 2))
 567   (inst move ocfp cfp-tn)
 568   (inst j code-tn
 569         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
 570   (inst move cfp-tn csp-tn)
 571
 572   RETURN-NIL
 573   (inst move res null-tn))