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 lip interior-reg lip-offset)
  29                           (:temp nargs any-reg nargs-offset)
  30                           (:temp ocfp any-reg ocfp-offset))
  31   (inst or temp x y)
  32   (inst and temp fixnum-tag-mask)
  33   (inst beq temp DO-ADD)
  34   (inst sra temp1 x n-fixnum-tag-bits)
  35
  36   ;; DO-STATIC-FUN
  37   (inst lw lip null-tn (static-fun-offset 'two-arg-+))
  38   (inst li nargs (fixnumize 2))
  39   (move ocfp cfp-tn)
  40   (inst j lip)
  41   (move cfp-tn csp-tn t)
  42
  43   DO-ADD
  44   (inst sra temp2 y n-fixnum-tag-bits)
  45   (inst addu temp temp1 temp2)
  46   ;; check for overflow
  47   (inst sra temp1 temp (- n-word-bits n-lowtag-bits))
  48   (inst beq temp1 RETURN)
  49   (inst nor temp1 temp1)
  50   (inst beq temp1 RETURN)
  51   (inst nop)
  52   (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
  53     (storew temp res bignum-digits-offset other-pointer-lowtag))
  54   (inst b DONE)
  55   (inst nop)
  56
  57   RETURN
  58   (inst sll res temp n-fixnum-tag-bits)
  59
  60   DONE)
  61
  62
  63 (define-assembly-routine (generic--
  64                           (:cost 10)
  65                           (:return-style :full-call)
  66                           (:translate -)
  67                           (:policy :safe)
  68                           (:save-p t))
  69                          ((:arg x (descriptor-reg any-reg) a0-offset)
  70                           (:arg y (descriptor-reg any-reg) a1-offset)
  71
  72                           (:res res (descriptor-reg any-reg) a0-offset)
  73
  74                           (:temp temp non-descriptor-reg nl0-offset)
  75                           (:temp temp1 non-descriptor-reg nl1-offset)
  76                           (:temp temp2 non-descriptor-reg nl2-offset)
  77                           (:temp pa-flag non-descriptor-reg nl4-offset)
  78                           (:temp lip interior-reg lip-offset)
  79                           (:temp nargs any-reg nargs-offset)
  80                           (:temp ocfp any-reg ocfp-offset))
  81   (inst or temp x y)
  82   (inst and temp fixnum-tag-mask)
  83   (inst beq temp DO-SUB)
  84   (inst sra temp1 x n-fixnum-tag-bits)
  85
  86   ;; DO-STATIC-FUN
  87   (inst lw lip null-tn (static-fun-offset 'two-arg--))
  88   (inst li nargs (fixnumize 2))
  89   (move ocfp cfp-tn)
  90   (inst j lip)
  91   (move cfp-tn csp-tn t)
  92
  93   DO-SUB
  94   (inst sra temp2 y n-fixnum-tag-bits)
  95   (inst subu temp temp1 temp2)
  96   ;; check for overflow
  97   (inst sra temp1 temp (- n-word-bits n-lowtag-bits))
  98   (inst beq temp1 RETURN)
  99   (inst nor temp1 temp1)
 100   (inst beq temp1 RETURN)
 101   (inst nop)
 102   (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
 103     (storew temp res bignum-digits-offset other-pointer-lowtag))
 104   (inst b DONE)
 105   (inst nop)
 106
 107   RETURN
 108   (inst sll res temp n-fixnum-tag-bits)
 109
 110   DONE)
 111
 112
 113 \f
 114 ;;;; Multiplication
 115
 116
 117 (define-assembly-routine (generic-*
 118                           (:cost 25)
 119                           (:return-style :full-call)
 120                           (:translate *)
 121                           (:policy :safe)
 122                           (:save-p t))
 123                          ((:arg x (descriptor-reg any-reg) a0-offset)
 124                           (:arg y (descriptor-reg any-reg) a1-offset)
 125
 126                           (:res res (descriptor-reg any-reg) a0-offset)
 127
 128                           (:temp temp non-descriptor-reg nl0-offset)
 129                           (:temp lo non-descriptor-reg nl1-offset)
 130                           (:temp hi non-descriptor-reg nl2-offset)
 131                           (:temp pa-flag non-descriptor-reg nl4-offset)
 132                           (:temp lip interior-reg lip-offset)
 133                           (:temp nargs any-reg nargs-offset)
 134                           (:temp ocfp any-reg ocfp-offset))
 135   ;; If either arg is not a fixnum, call the static function.
 136   (inst or temp x y)
 137   (inst and temp fixnum-tag-mask)
 138   (inst bne temp DO-STATIC-FUN)
 139   ;; Remove the tag from one arg so that the result will have the correct
 140   ;; fixnum tag.
 141   (inst sra temp x n-fixnum-tag-bits)
 142   (inst mult temp y)
 143   (inst mflo res)
 144   (inst mfhi hi)
 145   ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
 146   ;; is just 32 copies of the sign bit of the low word).
 147   (inst sra temp res 31)
 148   (inst beq temp hi DONE)
 149   ;; Shift the double word hi:res down two bits into hi:low to get rid of the
 150   ;; fixnum tag.
 151   (inst srl lo res n-fixnum-tag-bits)
 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   (inst b DONE)
 169   (storew lo res bignum-digits-offset other-pointer-lowtag)
 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   (inst b DONE)
 178   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
 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   DONE)
 188
 189 (macrolet
 190     ((frob (name note cost type sc signed-p)
 191        `(define-assembly-routine (,name
 192                                   (:note ,note)
 193                                   (:cost ,cost)
 194                                   (:translate *)
 195                                   (:policy :fast-safe)
 196                                   (:arg-types ,type ,type)
 197                                   (:result-types ,type))
 198                                  ((:arg x ,sc nl0-offset)
 199                                   (:arg y ,sc nl1-offset)
 200                                   (:res res ,sc nl0-offset))
 201           ,@(when (eq type 'tagged-num)
 202               `((inst sra x 2)))
 203           (inst ,(if signed-p 'mult 'multu) x y)
 204           (inst mflo res))))
 205   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil)
 206   (frob signed-* "signed *" 41 signed-num signed-reg t)
 207   (frob fixnum-* "fixnum *" 30 tagged-num any-reg t))
 208
 209
 210 \f
 211 ;;;; Division.
 212
 213
 214 (define-assembly-routine (positive-fixnum-truncate
 215                           (:note "unsigned fixnum truncate")
 216                           (:cost 45)
 217                           (:translate truncate)
 218                           (:policy :fast-safe)
 219                           (:arg-types positive-fixnum positive-fixnum)
 220                           (:result-types positive-fixnum positive-fixnum))
 221                          ((:arg dividend any-reg nl0-offset)
 222                           (:arg divisor any-reg nl1-offset)
 223
 224                           (:res quo any-reg nl2-offset)
 225                           (:res rem any-reg nl3-offset))
 226   (let ((error (generate-error-code nil division-by-zero-error
 227                                     dividend divisor)))
 228     (inst beq divisor error)
 229     (inst nop))
 230
 231     (inst divu dividend divisor)
 232     (inst mflo quo)
 233     (inst mfhi rem)
 234     (inst sll quo 2))
 235
 236
 237 (define-assembly-routine (fixnum-truncate
 238                           (:note "fixnum truncate")
 239                           (:cost 50)
 240                           (:policy :fast-safe)
 241                           (:translate truncate)
 242                           (:arg-types tagged-num tagged-num)
 243                           (:result-types tagged-num tagged-num))
 244                          ((:arg dividend any-reg nl0-offset)
 245                           (:arg divisor any-reg nl1-offset)
 246
 247                           (:res quo any-reg nl2-offset)
 248                           (:res rem any-reg nl3-offset))
 249   (let ((error (generate-error-code nil division-by-zero-error
 250                                     dividend divisor)))
 251     (inst beq divisor error)
 252     (inst nop))
 253
 254     (inst div dividend divisor)
 255     (inst mflo quo)
 256     (inst mfhi rem)
 257     (inst sll quo 2))
 258
 259
 260 (define-assembly-routine (signed-truncate
 261                           (:note "(signed-byte 32) truncate")
 262                           (:cost 60)
 263                           (:policy :fast-safe)
 264                           (:translate truncate)
 265                           (:arg-types signed-num signed-num)
 266                           (:result-types signed-num signed-num))
 267
 268                          ((:arg dividend signed-reg nl0-offset)
 269                           (:arg divisor signed-reg nl1-offset)
 270
 271                           (:res quo signed-reg nl2-offset)
 272                           (:res rem signed-reg nl3-offset))
 273   (let ((error (generate-error-code nil division-by-zero-error
 274                                     dividend divisor)))
 275     (inst beq divisor error)
 276     (inst nop))
 277
 278     (inst div dividend divisor)
 279     (inst mflo quo)
 280     (inst mfhi rem))
 281
 282
 283 \f
 284 ;;;; Comparison routines.
 285
 286 (macrolet
 287     ((define-cond-assem-rtn (name translate static-fn cmp not-p)
 288        `(define-assembly-routine (,name
 289                                   (:cost 10)
 290                                   (:return-style :full-call)
 291                                   (:policy :safe)
 292                                   (:translate ,translate)
 293                                   (:save-p t))
 294                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 295                                   (:arg y (descriptor-reg any-reg) a1-offset)
 296
 297                                   (:res res descriptor-reg a0-offset)
 298
 299                                   (:temp temp non-descriptor-reg nl0-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 beq temp DO-COMPARE)
 306           ,cmp
 307
 308           ;; DO-STATIC-FUN
 309           (inst lw lip null-tn (static-fun-offset ',static-fn))
 310           (inst li nargs (fixnumize 2))
 311           (move ocfp cfp-tn)
 312           (inst j lip)
 313           (move cfp-tn csp-tn t)
 314
 315           DO-COMPARE
 316           (inst ,(if not-p 'beq 'bne) temp DONE)
 317           (move res null-tn t)
 318           (load-symbol res t)
 319
 320           DONE)))
 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 lip interior-reg lip-offset)
 341                           (:temp nargs any-reg nargs-offset)
 342                           (:temp ocfp any-reg ocfp-offset))
 343   (inst beq x y RETURN-T)
 344   (inst or temp x y)
 345   (inst and temp fixnum-tag-mask)
 346   (inst beq temp RETURN)
 347   (inst nop)
 348
 349   ;; DO-STATIC-FUN
 350   (inst lw lip null-tn (static-fun-offset 'eql))
 351   (inst li nargs (fixnumize 2))
 352   (move ocfp cfp-tn)
 353   (inst j lip)
 354   (move cfp-tn csp-tn t)
 355
 356   RETURN
 357   (inst bne x y DONE)
 358   (move res null-tn t)
 359
 360   RETURN-T
 361   (load-symbol res t)
 362
 363   DONE)
 364
 365
 366 (define-assembly-routine (generic-=
 367                           (:cost 10)
 368                           (:return-style :full-call)
 369                           (:policy :safe)
 370                           (:translate =)
 371                           (:save-p t))
 372                          ((:arg x (descriptor-reg any-reg) a0-offset)
 373                           (:arg y (descriptor-reg any-reg) a1-offset)
 374
 375                           (:res res descriptor-reg a0-offset)
 376
 377                           (:temp temp non-descriptor-reg nl0-offset)
 378                           (:temp lip interior-reg lip-offset)
 379                           (:temp nargs any-reg nargs-offset)
 380                           (:temp ocfp any-reg ocfp-offset))
 381   (inst or temp x y)
 382   (inst and temp fixnum-tag-mask)
 383   (inst beq temp RETURN)
 384   (inst nop)
 385
 386   ;; DO-STATIC-FUN
 387   (inst lw lip null-tn (static-fun-offset 'two-arg-=))
 388   (inst li nargs (fixnumize 2))
 389   (move ocfp cfp-tn)
 390   (inst j lip)
 391   (move cfp-tn csp-tn t)
 392
 393   RETURN
 394   (inst bne x y DONE)
 395   (move res null-tn t)
 396   (load-symbol res t)
 397
 398   DONE)
 399
 400
 401 (define-assembly-routine (generic-/=
 402                           (:cost 10)
 403                           (:return-style :full-call)
 404                           (:policy :safe)
 405                           (:translate /=)
 406                           (:save-p t))
 407                          ((:arg x (descriptor-reg any-reg) a0-offset)
 408                           (:arg y (descriptor-reg any-reg) a1-offset)
 409
 410                           (:res res descriptor-reg a0-offset)
 411
 412                           (:temp temp non-descriptor-reg nl0-offset)
 413                           (:temp lip interior-reg lip-offset)
 414                           (:temp nargs any-reg nargs-offset)
 415                           (:temp ocfp any-reg ocfp-offset))
 416   (inst or temp x y)
 417   (inst and temp fixnum-tag-mask)
 418   (inst beq temp RETURN)
 419   (inst nop)
 420
 421   ;; DO-STATIC-FUN
 422   (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
 423   (inst li nargs (fixnumize 2))
 424   (move ocfp cfp-tn)
 425   (inst j lip)
 426   (move cfp-tn csp-tn t)
 427
 428   RETURN
 429   (inst beq x y DONE)
 430   (move res null-tn t)
 431   (load-symbol res t)
 432
 433   DONE)