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