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