src/assembly/mips/arith.lisp

   1 (in-package "SB!VM")
   2
   3
   4 (define-assembly-routine (generic-+
   5                           (:cost 10)
   6                           (:return-style :full-call)
   7                           (:translate +)
   8                           (:policy :safe)
   9                           (:save-p t))
  10                          ((:arg x (descriptor-reg any-reg) a0-offset)
  11                           (:arg y (descriptor-reg any-reg) a1-offset)
  12
  13                           (:res res (descriptor-reg any-reg) a0-offset)
  14
  15                           (:temp temp non-descriptor-reg nl0-offset)
  16                           (:temp temp1 non-descriptor-reg nl1-offset)
  17                           (:temp temp2 non-descriptor-reg nl2-offset)
  18                           (:temp pa-flag non-descriptor-reg nl4-offset)
  19                           (:temp lip interior-reg lip-offset)
  20                           (:temp nargs any-reg nargs-offset)
  21                           (:temp ocfp any-reg ocfp-offset))
  22   (inst or temp x y)
  23   (inst and temp fixnum-tag-mask)
  24   (inst beq temp DO-ADD)
  25   (inst sra temp1 x n-fixnum-tag-bits)
  26
  27   ;; DO-STATIC-FUN
  28   (inst lw lip null-tn (static-fun-offset 'two-arg-+))
  29   (inst li nargs (fixnumize 2))
  30   (inst move ocfp cfp-tn)
  31   (inst j lip)
  32   (inst move cfp-tn csp-tn)
  33
  34   DO-ADD
  35   (inst sra temp2 y n-fixnum-tag-bits)
  36   (inst addu temp temp1 temp2)
  37   ;; check for overflow
  38   (inst sra temp1 temp (- n-word-bits n-lowtag-bits))
  39   (inst beq temp1 RETURN)
  40   (inst nor temp1 temp1)
  41   (inst beq temp1 RETURN)
  42   (inst nop)
  43   (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
  44     (storew temp res bignum-digits-offset other-pointer-lowtag))
  45   (inst b DONE)
  46   (inst nop)
  47
  48   RETURN
  49   (inst sll res temp n-fixnum-tag-bits)
  50
  51   DONE)
  52
  53
  54 (define-assembly-routine (generic--
  55                           (:cost 10)
  56                           (:return-style :full-call)
  57                           (:translate -)
  58                           (:policy :safe)
  59                           (:save-p t))
  60                          ((:arg x (descriptor-reg any-reg) a0-offset)
  61                           (:arg y (descriptor-reg any-reg) a1-offset)
  62
  63                           (:res res (descriptor-reg any-reg) a0-offset)
  64
  65                           (:temp temp non-descriptor-reg nl0-offset)
  66                           (:temp temp1 non-descriptor-reg nl1-offset)
  67                           (:temp temp2 non-descriptor-reg nl2-offset)
  68                           (:temp pa-flag non-descriptor-reg nl4-offset)
  69                           (:temp lip interior-reg lip-offset)
  70                           (:temp nargs any-reg nargs-offset)
  71                           (:temp ocfp any-reg ocfp-offset))
  72   (inst or temp x y)
  73   (inst and temp fixnum-tag-mask)
  74   (inst beq temp DO-SUB)
  75   (inst sra temp1 x n-fixnum-tag-bits)
  76
  77   ;; DO-STATIC-FUN
  78   (inst lw lip null-tn (static-fun-offset 'two-arg--))
  79   (inst li nargs (fixnumize 2))
  80   (inst move ocfp cfp-tn)
  81   (inst j lip)
  82   (inst move cfp-tn csp-tn)
  83
  84   DO-SUB
  85   (inst sra temp2 y n-fixnum-tag-bits)
  86   (inst subu temp temp1 temp2)
  87   ;; check for overflow
  88   (inst sra temp1 temp (- n-word-bits n-lowtag-bits))
  89   (inst beq temp1 RETURN)
  90   (inst nor temp1 temp1)
  91   (inst beq temp1 RETURN)
  92   (inst nop)
  93   (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
  94     (storew temp res bignum-digits-offset other-pointer-lowtag))
  95   (inst b DONE)
  96   (inst nop)
  97
  98   RETURN
  99   (inst sll res temp n-fixnum-tag-bits)
 100
 101   DONE)
 102
 103
 104 (define-assembly-routine (generic-*
 105                           (:cost 25)
 106                           (:return-style :full-call)
 107                           (:translate *)
 108                           (:policy :safe)
 109                           (:save-p t))
 110                          ((:arg x (descriptor-reg any-reg) a0-offset)
 111                           (:arg y (descriptor-reg any-reg) a1-offset)
 112
 113                           (:res res (descriptor-reg any-reg) a0-offset)
 114
 115                           (:temp temp non-descriptor-reg nl0-offset)
 116                           (:temp lo non-descriptor-reg nl1-offset)
 117                           (:temp hi non-descriptor-reg nl2-offset)
 118                           (:temp pa-flag non-descriptor-reg nl4-offset)
 119                           (:temp lip interior-reg lip-offset)
 120                           (:temp nargs any-reg nargs-offset)
 121                           (:temp ocfp any-reg ocfp-offset))
 122   ;; If either arg is not a fixnum, call the static function.
 123   (inst or temp x y)
 124   (inst and temp fixnum-tag-mask)
 125   (inst bne temp DO-STATIC-FUN)
 126   ;; Remove the tag from one arg so that the result will have the correct
 127   ;; fixnum tag.
 128   (inst sra temp x n-fixnum-tag-bits)
 129   (inst mult temp y)
 130   (inst mflo res)
 131   (inst mfhi hi)
 132   ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
 133   ;; is just 32 copies of the sign bit of the low word).
 134   (inst sra temp res 31)
 135   (inst beq temp hi DONE)
 136   ;; Shift the double word hi:res down two bits into hi:low to get rid of the
 137   ;; fixnum tag.
 138   (inst srl lo res n-fixnum-tag-bits)
 139   (inst sll temp hi (- n-word-bits n-fixnum-tag-bits))
 140   (inst or lo temp)
 141   (inst sra hi n-fixnum-tag-bits)
 142
 143   ;; Do we need one word or two?  Assume two.
 144   (inst sra temp lo 31)
 145   (inst bne temp hi TWO-WORDS)
 146   ;; Assume a two word header.
 147   (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
 148
 149   ;; Only need one word, fix the header.
 150   (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
 151
 152   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
 153     (inst or res alloc-tn other-pointer-lowtag)
 154     (storew temp res 0 other-pointer-lowtag))
 155
 156   (storew lo res bignum-digits-offset other-pointer-lowtag)
 157
 158   ;; Out of here
 159   (inst b DONE)
 160   (inst nop)
 161
 162   TWO-WORDS
 163   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
 164     (inst or res alloc-tn other-pointer-lowtag)
 165     (storew temp res 0 other-pointer-lowtag))
 166
 167   (storew lo res bignum-digits-offset other-pointer-lowtag)
 168   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
 169
 170   ;; Out of here
 171   (inst b DONE)
 172   (inst nop)
 173
 174   DO-STATIC-FUN
 175   (inst lw lip null-tn (static-fun-offset 'two-arg-*))
 176   (inst li nargs (fixnumize 2))
 177   (inst move ocfp cfp-tn)
 178   (inst j lip)
 179   (inst move cfp-tn csp-tn)
 180
 181   DONE)
 182
 183
 184 \f
 185 ;;;; Comparison routines.
 186
 187 (macrolet
 188     ((define-cond-assem-rtn (name translate static-fn cmp)
 189        `(define-assembly-routine (,name
 190                                   (:cost 10)
 191                                   (:return-style :full-call)
 192                                   (:policy :safe)
 193                                   (:translate ,translate)
 194                                   (:save-p t))
 195                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 196                                   (:arg y (descriptor-reg any-reg) a1-offset)
 197
 198                                   (:res res descriptor-reg a0-offset)
 199
 200                                   (:temp temp non-descriptor-reg nl0-offset)
 201                                   (:temp lip interior-reg lip-offset)
 202                                   (:temp nargs any-reg nargs-offset)
 203                                   (:temp ocfp any-reg ocfp-offset))
 204           (inst or temp x y)
 205           (inst and temp fixnum-tag-mask)
 206           (inst beq temp DO-COMPARE)
 207           ,cmp
 208
 209           ;; DO-STATIC-FUN
 210           (inst lw lip null-tn (static-fun-offset ',static-fn))
 211           (inst li nargs (fixnumize 2))
 212           (inst move ocfp cfp-tn)
 213           (inst j lip)
 214           (inst move cfp-tn csp-tn)
 215
 216           DO-COMPARE
 217           (inst beq temp DONE)
 218           (inst move res null-tn)
 219           (load-symbol res t)
 220
 221           DONE)))
 222
 223   (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y))
 224   (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x)))
 225
 226
 227 (define-assembly-routine (generic-eql
 228                           (:cost 10)
 229                           (:return-style :full-call)
 230                           (:policy :safe)
 231                           (:translate eql)
 232                           (:save-p t))
 233                          ((:arg x (descriptor-reg any-reg) a0-offset)
 234                           (:arg y (descriptor-reg any-reg) a1-offset)
 235
 236                           (:res res descriptor-reg a0-offset)
 237
 238                           (:temp temp non-descriptor-reg nl0-offset)
 239                           (:temp lip interior-reg lip-offset)
 240                           (:temp nargs any-reg nargs-offset)
 241                           (:temp ocfp any-reg ocfp-offset))
 242   (inst beq x y RETURN-T)
 243   (inst or temp x y)
 244   (inst and temp fixnum-tag-mask)
 245   (inst beq temp RETURN)
 246   (inst nop)
 247
 248   ;; DO-STATIC-FUN
 249   (inst lw lip null-tn (static-fun-offset 'eql))
 250   (inst li nargs (fixnumize 2))
 251   (inst move ocfp cfp-tn)
 252   (inst j lip)
 253   (inst move cfp-tn csp-tn)
 254
 255   RETURN
 256   (inst bne x y DONE)
 257   (inst move res null-tn)
 258
 259   RETURN-T
 260   (load-symbol res t)
 261
 262   DONE)
 263
 264
 265 (define-assembly-routine (generic-=
 266                           (:cost 10)
 267                           (:return-style :full-call)
 268                           (:policy :safe)
 269                           (:translate =)
 270                           (:save-p t))
 271                          ((:arg x (descriptor-reg any-reg) a0-offset)
 272                           (:arg y (descriptor-reg any-reg) a1-offset)
 273
 274                           (:res res descriptor-reg a0-offset)
 275
 276                           (:temp temp non-descriptor-reg nl0-offset)
 277                           (:temp lip interior-reg lip-offset)
 278                           (:temp nargs any-reg nargs-offset)
 279                           (:temp ocfp any-reg ocfp-offset))
 280   (inst or temp x y)
 281   (inst and temp fixnum-tag-mask)
 282   (inst beq temp RETURN)
 283   (inst nop)
 284
 285   ;; DO-STATIC-FUN
 286   (inst lw lip null-tn (static-fun-offset 'two-arg-=))
 287   (inst li nargs (fixnumize 2))
 288   (inst move ocfp cfp-tn)
 289   (inst j lip)
 290   (inst move cfp-tn csp-tn)
 291
 292   RETURN
 293   (inst bne x y DONE)
 294   (inst move res null-tn)
 295   (load-symbol res t)
 296
 297   DONE)
 298
 299
 300 (define-assembly-routine (generic-/=
 301                           (:cost 10)
 302                           (:return-style :full-call)
 303                           (:policy :safe)
 304                           (: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 lip interior-reg lip-offset)
 313                           (:temp nargs any-reg nargs-offset)
 314                           (:temp ocfp any-reg ocfp-offset))
 315   (inst or temp x y)
 316   (inst and temp fixnum-tag-mask)
 317   (inst beq temp RETURN)
 318   (inst nop)
 319
 320   ;; DO-STATIC-FUN
 321   (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
 322   (inst li nargs (fixnumize 2))
 323   (inst move ocfp cfp-tn)
 324   (inst j lip)
 325   (inst move cfp-tn csp-tn)
 326
 327   RETURN
 328   (inst beq x y DONE)
 329   (inst move res null-tn)
 330   (load-symbol res t)
 331
 332   DONE)