src/assembly/mips/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
  14
  15 \f
  16 ;;;; Addition and subtraction.
  17
  18 ;;; static-fun-offset returns the address of the raw_addr slot of
  19 ;;; a static function's fdefn.
  20
  21 ;;; Note that there is only one use of static-fun-offset outside this
  22 ;;; file (in genesis.lisp)
  23
  24 (define-assembly-routine (generic-+
  25                           (:cost 10)
  26                           (:return-style :full-call)
  27                           (:translate +)
  28                           (:policy :safe)
  29                           (:save-p t))
  30                          ((:arg x (descriptor-reg any-reg) a0-offset)
  31                           (:arg y (descriptor-reg any-reg) a1-offset)
  32
  33                           (:res res (descriptor-reg any-reg) a0-offset)
  34
  35                           (:temp temp non-descriptor-reg nl0-offset)
  36                           (:temp temp1 non-descriptor-reg nl1-offset)
  37                           (:temp temp2 non-descriptor-reg nl2-offset)
  38                           (:temp pa-flag non-descriptor-reg nl4-offset)
  39                           (:temp lra descriptor-reg lra-offset)
  40                           (:temp lip interior-reg lip-offset)
  41                           (:temp nargs any-reg nargs-offset)
  42                           (:temp ocfp any-reg ocfp-offset))
  43   (inst or temp x y)
  44   (inst and temp fixnum-tag-mask)
  45   (inst bne temp DO-STATIC-FUN)
  46   (inst addu temp x y)
  47   ;; check for overflow
  48   (inst xor temp1 temp x)
  49   (inst xor temp2 temp y)
  50   (inst and temp1 temp2)
  51   (inst bltz temp1 DO-OVERFLOW)
  52   (inst sra temp1 x n-fixnum-tag-bits)
  53   (inst move res temp)
  54   (lisp-return lra lip :offset 2)
  55
  56   DO-OVERFLOW
  57   ;; We did overflow, so do the bignum version
  58   (inst sra temp2 y n-fixnum-tag-bits)
  59   (inst addu temp temp1 temp2)
  60   (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
  61     (storew temp res bignum-digits-offset other-pointer-lowtag))
  62   (lisp-return lra lip :offset 2)
  63
  64   DO-STATIC-FUN
  65   (inst lw lip null-tn (static-fun-offset 'two-arg-+))
  66   (inst li nargs (fixnumize 2))
  67   (move ocfp cfp-tn)
  68   (inst j lip)
  69   (move cfp-tn csp-tn t))
  70
  71
  72 (define-assembly-routine (generic--
  73                           (:cost 10)
  74                           (:return-style :full-call)
  75                           (:translate -)
  76                           (:policy :safe)
  77                           (:save-p t))
  78                          ((:arg x (descriptor-reg any-reg) a0-offset)
  79                           (:arg y (descriptor-reg any-reg) a1-offset)
  80
  81                           (:res res (descriptor-reg any-reg) a0-offset)
  82
  83                           (:temp temp non-descriptor-reg nl0-offset)
  84                           (:temp temp1 non-descriptor-reg nl1-offset)
  85                           (:temp temp2 non-descriptor-reg nl2-offset)
  86                           (:temp pa-flag non-descriptor-reg nl4-offset)
  87                           (:temp lra descriptor-reg lra-offset)
  88                           (:temp lip interior-reg lip-offset)
  89                           (:temp nargs any-reg nargs-offset)
  90                           (:temp ocfp any-reg ocfp-offset))
  91   (inst or temp x y)
  92   (inst and temp fixnum-tag-mask)
  93   (inst bne temp DO-STATIC-FUN)
  94   (inst subu temp x y)
  95   ;; check for overflow
  96   (inst xor temp1 x y)
  97   (inst xor temp2 x temp)
  98   (inst and temp1 temp2)
  99   (inst bltz temp1 DO-OVERFLOW)
 100   (inst sra temp1 x n-fixnum-tag-bits)
 101   (inst move res temp)
 102   (lisp-return lra lip :offset 2)
 103
 104   DO-OVERFLOW
 105   ;; We did overflow, so do the bignum version
 106   (inst sra temp2 y n-fixnum-tag-bits)
 107   (inst subu temp temp1 temp2)
 108   (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
 109     (storew temp res bignum-digits-offset other-pointer-lowtag))
 110   (lisp-return lra lip :offset 2)
 111
 112   DO-STATIC-FUN
 113   (inst lw lip null-tn (static-fun-offset 'two-arg--))
 114   (inst li nargs (fixnumize 2))
 115   (move ocfp cfp-tn)
 116   (inst j lip)
 117   (move cfp-tn csp-tn t))
 118
 119
 120 \f
 121 ;;;; Multiplication
 122
 123
 124 (define-assembly-routine (generic-*
 125                           (:cost 25)
 126                           (:return-style :full-call)
 127                           (:translate *)
 128                           (:policy :safe)
 129                           (:save-p t))
 130                          ((:arg x (descriptor-reg any-reg) a0-offset)
 131                           (:arg y (descriptor-reg any-reg) a1-offset)
 132
 133                           (:res res (descriptor-reg any-reg) a0-offset)
 134
 135                           (:temp temp non-descriptor-reg nl0-offset)
 136                           (:temp lo non-descriptor-reg nl1-offset)
 137                           (:temp hi non-descriptor-reg nl2-offset)
 138                           (:temp pa-flag non-descriptor-reg nl4-offset)
 139                           (:temp lra descriptor-reg lra-offset)
 140                           (:temp lip interior-reg lip-offset)
 141                           (:temp nargs any-reg nargs-offset)
 142                           (:temp ocfp any-reg ocfp-offset))
 143   ;; If either arg is not a fixnum, call the static function.
 144   (inst or temp x y)
 145   (inst and temp fixnum-tag-mask)
 146   (inst bne temp DO-STATIC-FUN)
 147   ;; Remove the tag from one arg so that the result will have the correct
 148   ;; fixnum tag.
 149   (inst sra temp x n-fixnum-tag-bits)
 150   (inst mult temp y)
 151   (inst mflo res)
 152   (inst mfhi hi)
 153   ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
 154   ;; is just 32 copies of the sign bit of the low word).
 155   (inst sra temp res 31)
 156   (inst bne temp hi DO-BIGNUM)
 157   (inst srl lo res n-fixnum-tag-bits)
 158   (lisp-return lra lip :offset 2)
 159
 160   DO-BIGNUM
 161   ;; Shift the double word hi:res down two bits into hi:low to get rid of the
 162   ;; fixnum tag.
 163   (inst sll temp hi (- n-word-bits n-fixnum-tag-bits))
 164   (inst or lo temp)
 165   (inst sra hi n-fixnum-tag-bits)
 166
 167   ;; Do we need one word or two?  Assume two.
 168   (inst sra temp lo 31)
 169   (inst bne temp hi TWO-WORDS)
 170   ;; Assume a two word header.
 171   (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
 172
 173   ;; Only need one word, fix the header.
 174   (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
 175
 176   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
 177     (inst or res alloc-tn other-pointer-lowtag)
 178     (storew temp res 0 other-pointer-lowtag))
 179   (storew lo res bignum-digits-offset other-pointer-lowtag)
 180   (lisp-return lra lip :offset 2)
 181
 182   TWO-WORDS
 183   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
 184     (inst or res alloc-tn other-pointer-lowtag)
 185     (storew temp res 0 other-pointer-lowtag))
 186
 187   (storew lo res bignum-digits-offset other-pointer-lowtag)
 188   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
 189   (lisp-return lra lip :offset 2)
 190
 191   DO-STATIC-FUN
 192   (inst lw lip null-tn (static-fun-offset 'two-arg-*))
 193   (inst li nargs (fixnumize 2))
 194   (move ocfp cfp-tn)
 195   (inst j lip)
 196   (move cfp-tn csp-tn t))
 197
 198
 199 (macrolet
 200     ((frob (name note cost type sc signed-p)
 201        `(define-assembly-routine (,name
 202                                   (:note ,note)
 203                                   (:cost ,cost)
 204                                   (:translate *)
 205                                   (:policy :fast-safe)
 206                                   (:arg-types ,type ,type)
 207                                   (:result-types ,type))
 208                                  ((:arg x ,sc nl0-offset)
 209                                   (:arg y ,sc nl1-offset)
 210                                   (:res res ,sc nl0-offset))
 211           ,@(when (eq type 'tagged-num)
 212               `((inst sra x 2)))
 213           (inst ,(if signed-p 'mult 'multu) x y)
 214           (inst mflo res))))
 215   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil)
 216   (frob signed-* "signed *" 41 signed-num signed-reg t)
 217   (frob fixnum-* "fixnum *" 30 tagged-num any-reg t))
 218
 219
 220 \f
 221 ;;;; Division.
 222
 223
 224 (define-assembly-routine (positive-fixnum-truncate
 225                           (:note "unsigned fixnum truncate")
 226                           (:cost 45)
 227                           (:translate truncate)
 228                           (:policy :fast-safe)
 229                           (:arg-types positive-fixnum positive-fixnum)
 230                           (:result-types positive-fixnum positive-fixnum))
 231                          ((:arg dividend any-reg nl0-offset)
 232                           (:arg divisor any-reg nl1-offset)
 233
 234                           (:res quo any-reg nl2-offset)
 235                           (:res rem any-reg nl3-offset))
 236   (let ((error (generate-error-code nil division-by-zero-error
 237                                     dividend divisor)))
 238     (inst beq divisor error)
 239     (inst nop))
 240
 241     (inst divu dividend divisor)
 242     (inst mflo quo)
 243     (inst mfhi rem)
 244     (inst sll quo 2))
 245
 246
 247 (define-assembly-routine (fixnum-truncate
 248                           (:note "fixnum truncate")
 249                           (:cost 50)
 250                           (:policy :fast-safe)
 251                           (:translate truncate)
 252                           (:arg-types tagged-num tagged-num)
 253                           (:result-types tagged-num tagged-num))
 254                          ((:arg dividend any-reg nl0-offset)
 255                           (:arg divisor any-reg nl1-offset)
 256
 257                           (:res quo any-reg nl2-offset)
 258                           (:res rem any-reg nl3-offset))
 259   (let ((error (generate-error-code nil division-by-zero-error
 260                                     dividend divisor)))
 261     (inst beq divisor error)
 262     (inst nop))
 263
 264     (inst div dividend divisor)
 265     (inst mflo quo)
 266     (inst mfhi rem)
 267     (inst sll quo 2))
 268
 269
 270 (define-assembly-routine (signed-truncate
 271                           (:note "(signed-byte 32) truncate")
 272                           (:cost 60)
 273                           (:policy :fast-safe)
 274                           (:translate truncate)
 275                           (:arg-types signed-num signed-num)
 276                           (:result-types signed-num signed-num))
 277
 278                          ((:arg dividend signed-reg nl0-offset)
 279                           (:arg divisor signed-reg nl1-offset)
 280
 281                           (:res quo signed-reg nl2-offset)
 282                           (:res rem signed-reg nl3-offset))
 283   (let ((error (generate-error-code nil division-by-zero-error
 284                                     dividend divisor)))
 285     (inst beq divisor error)
 286     (inst nop))
 287
 288     (inst div dividend divisor)
 289     (inst mflo quo)
 290     (inst mfhi rem))
 291
 292
 293 \f
 294 ;;;; Comparison routines.
 295
 296 (macrolet
 297     ((define-cond-assem-rtn (name translate static-fn cmp not-p)
 298        `(define-assembly-routine (,name
 299                                   (:cost 10)
 300                                   (:return-style :full-call)
 301                                   (:policy :safe)
 302                                   (:translate ,translate)
 303                                   (:save-p t))
 304                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 305                                   (:arg y (descriptor-reg any-reg) a1-offset)
 306
 307                                   (:res res descriptor-reg a0-offset)
 308
 309                                   (:temp temp non-descriptor-reg nl0-offset)
 310                                   (:temp lra descriptor-reg lra-offset)
 311                                   (:temp lip interior-reg lip-offset)
 312                                   (:temp nargs any-reg nargs-offset)
 313                                   (:temp ocfp any-reg ocfp-offset))
 314           (inst or temp x y)
 315           (inst and temp fixnum-tag-mask)
 316           (inst bne temp DO-STATIC-FUN)
 317           ,cmp
 318
 319           (inst ,(if not-p 'beq 'bne) temp DONE)
 320           (move res null-tn t)
 321           (load-symbol res t)
 322
 323           DONE
 324           (lisp-return lra lip :offset 2)
 325
 326           DO-STATIC-FUN
 327           (inst lw lip null-tn (static-fun-offset ',static-fn))
 328           (inst li nargs (fixnumize 2))
 329           (move ocfp cfp-tn)
 330           (inst j lip)
 331           (move cfp-tn csp-tn t))))
 332
 333   (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) t)
 334   (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp x y) nil)
 335   (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) t)
 336   (define-cond-assem-rtn generic->= >= two-arg->= (inst slt temp y x) nil))
 337
 338
 339 (define-assembly-routine (generic-eql
 340                           (:cost 10)
 341                           (:return-style :full-call)
 342                           (:policy :safe)
 343                           (:translate eql)
 344                           (:save-p t))
 345                          ((:arg x (descriptor-reg any-reg) a0-offset)
 346                           (:arg y (descriptor-reg any-reg) a1-offset)
 347
 348                           (:res res descriptor-reg a0-offset)
 349
 350                           (:temp temp non-descriptor-reg nl0-offset)
 351                           (:temp lra descriptor-reg lra-offset)
 352                           (:temp lip interior-reg lip-offset)
 353                           (:temp nargs any-reg nargs-offset)
 354                           (:temp ocfp any-reg ocfp-offset))
 355   (inst beq x y RETURN-T)
 356   (inst or temp x y)
 357   (inst and temp fixnum-tag-mask)
 358   (inst bne temp DO-STATIC-FUN)
 359   (inst nop)
 360
 361   (inst bne x y DONE)
 362   (move res null-tn t)
 363
 364   RETURN-T
 365   (load-symbol res t)
 366
 367   DONE
 368   (lisp-return lra lip :offset 2)
 369
 370   DO-STATIC-FUN
 371   (inst lw lip null-tn (static-fun-offset 'eql))
 372   (inst li nargs (fixnumize 2))
 373   (move ocfp cfp-tn)
 374   (inst j lip)
 375   (move cfp-tn csp-tn t))
 376
 377
 378 (define-assembly-routine (generic-=
 379                           (:cost 10)
 380                           (:return-style :full-call)
 381                           (:policy :safe)
 382                           (:translate =)
 383                           (:save-p t))
 384                          ((:arg x (descriptor-reg any-reg) a0-offset)
 385                           (:arg y (descriptor-reg any-reg) a1-offset)
 386
 387                           (:res res descriptor-reg a0-offset)
 388
 389                           (:temp temp non-descriptor-reg nl0-offset)
 390                           (:temp lra descriptor-reg lra-offset)
 391                           (:temp lip interior-reg lip-offset)
 392                           (:temp nargs any-reg nargs-offset)
 393                           (:temp ocfp any-reg ocfp-offset))
 394   (inst or temp x y)
 395   (inst and temp fixnum-tag-mask)
 396   (inst bne temp DO-STATIC-FUN)
 397   (inst nop)
 398
 399   (inst bne x y DONE)
 400   (move res null-tn t)
 401   (load-symbol res t)
 402
 403   DONE
 404   (lisp-return lra lip :offset 2)
 405
 406   DO-STATIC-FUN
 407   (inst lw lip null-tn (static-fun-offset 'two-arg-=))
 408   (inst li nargs (fixnumize 2))
 409   (move ocfp cfp-tn)
 410   (inst j lip)
 411   (move cfp-tn csp-tn t))
 412
 413
 414 (define-assembly-routine (generic-/=
 415                           (:cost 10)
 416                           (:return-style :full-call)
 417                           (:policy :safe)
 418                           (:translate /=)
 419                           (:save-p t))
 420                          ((:arg x (descriptor-reg any-reg) a0-offset)
 421                           (:arg y (descriptor-reg any-reg) a1-offset)
 422
 423                           (:res res descriptor-reg a0-offset)
 424
 425                           (:temp temp non-descriptor-reg nl0-offset)
 426                           (:temp lra descriptor-reg lra-offset)
 427                           (:temp lip interior-reg lip-offset)
 428                           (:temp nargs any-reg nargs-offset)
 429                           (:temp ocfp any-reg ocfp-offset))
 430   (inst or temp x y)
 431   (inst and temp fixnum-tag-mask)
 432   (inst bne temp DO-STATIC-FUN)
 433   (inst nop)
 434
 435   (inst beq x y DONE)
 436   (move res null-tn t)
 437   (load-symbol res t)
 438
 439   DONE
 440   (lisp-return lra lip :offset 2)
 441
 442   DO-STATIC-FUN
 443   (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
 444   (inst li nargs (fixnumize 2))
 445   (move ocfp cfp-tn)
 446   (inst j lip)
 447   (move cfp-tn csp-tn t))