src/assembly/mips/arith.lisp

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