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