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   (move ocfp cfp-tn)
  31   (inst j lip)
  32   (move cfp-tn csp-tn t)
  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   (move ocfp cfp-tn)
  81   (inst j lip)
  82   (move cfp-tn csp-tn t)
  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   (inst b DONE)
 156   (storew lo res bignum-digits-offset other-pointer-lowtag)
 157
 158   TWO-WORDS
 159   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
 160     (inst or res alloc-tn other-pointer-lowtag)
 161     (storew temp res 0 other-pointer-lowtag))
 162
 163   (storew lo res bignum-digits-offset other-pointer-lowtag)
 164   (inst b DONE)
 165   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
 166
 167   DO-STATIC-FUN
 168   (inst lw lip null-tn (static-fun-offset 'two-arg-*))
 169   (inst li nargs (fixnumize 2))
 170   (move ocfp cfp-tn)
 171   (inst j lip)
 172   (move cfp-tn csp-tn t)
 173
 174   DONE)
 175
 176
 177 \f
 178 ;;;; Comparison routines.
 179
 180 (macrolet
 181     ((define-cond-assem-rtn (name translate static-fn cmp)
 182        `(define-assembly-routine (,name
 183                                   (:cost 10)
 184                                   (:return-style :full-call)
 185                                   (:policy :safe)
 186                                   (:translate ,translate)
 187                                   (:save-p t))
 188                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 189                                   (:arg y (descriptor-reg any-reg) a1-offset)
 190
 191                                   (:res res descriptor-reg a0-offset)
 192
 193                                   (:temp temp non-descriptor-reg nl0-offset)
 194                                   (:temp lip interior-reg lip-offset)
 195                                   (:temp nargs any-reg nargs-offset)
 196                                   (:temp ocfp any-reg ocfp-offset))
 197           (inst or temp x y)
 198           (inst and temp fixnum-tag-mask)
 199           (inst beq temp DO-COMPARE)
 200           ,cmp
 201
 202           ;; DO-STATIC-FUN
 203           (inst lw lip null-tn (static-fun-offset ',static-fn))
 204           (inst li nargs (fixnumize 2))
 205           (move ocfp cfp-tn)
 206           (inst j lip)
 207           (move cfp-tn csp-tn t)
 208
 209           DO-COMPARE
 210           (inst beq temp DONE)
 211           (move res null-tn t)
 212           (load-symbol res t)
 213
 214           DONE)))
 215
 216   (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y))
 217   (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x)))
 218
 219
 220 (define-assembly-routine (generic-eql
 221                           (:cost 10)
 222                           (:return-style :full-call)
 223                           (:policy :safe)
 224                           (:translate eql)
 225                           (:save-p t))
 226                          ((:arg x (descriptor-reg any-reg) a0-offset)
 227                           (:arg y (descriptor-reg any-reg) a1-offset)
 228
 229                           (:res res descriptor-reg a0-offset)
 230
 231                           (:temp temp non-descriptor-reg nl0-offset)
 232                           (:temp lip interior-reg lip-offset)
 233                           (:temp nargs any-reg nargs-offset)
 234                           (:temp ocfp any-reg ocfp-offset))
 235   (inst beq x y RETURN-T)
 236   (inst or temp x y)
 237   (inst and temp fixnum-tag-mask)
 238   (inst beq temp RETURN)
 239   (inst nop)
 240
 241   ;; DO-STATIC-FUN
 242   (inst lw lip null-tn (static-fun-offset 'eql))
 243   (inst li nargs (fixnumize 2))
 244   (move ocfp cfp-tn)
 245   (inst j lip)
 246   (move cfp-tn csp-tn t)
 247
 248   RETURN
 249   (inst bne x y DONE)
 250   (move res null-tn t)
 251
 252   RETURN-T
 253   (load-symbol res t)
 254
 255   DONE)
 256
 257
 258 (define-assembly-routine (generic-=
 259                           (:cost 10)
 260                           (:return-style :full-call)
 261                           (:policy :safe)
 262                           (:translate =)
 263                           (:save-p t))
 264                          ((:arg x (descriptor-reg any-reg) a0-offset)
 265                           (:arg y (descriptor-reg any-reg) a1-offset)
 266
 267                           (:res res descriptor-reg a0-offset)
 268
 269                           (:temp temp non-descriptor-reg nl0-offset)
 270                           (:temp lip interior-reg lip-offset)
 271                           (:temp nargs any-reg nargs-offset)
 272                           (:temp ocfp any-reg ocfp-offset))
 273   (inst or temp x y)
 274   (inst and temp fixnum-tag-mask)
 275   (inst beq temp RETURN)
 276   (inst nop)
 277
 278   ;; DO-STATIC-FUN
 279   (inst lw lip null-tn (static-fun-offset 'two-arg-=))
 280   (inst li nargs (fixnumize 2))
 281   (move ocfp cfp-tn)
 282   (inst j lip)
 283   (move cfp-tn csp-tn t)
 284
 285   RETURN
 286   (inst bne x y DONE)
 287   (move res null-tn t)
 288   (load-symbol res t)
 289
 290   DONE)
 291
 292
 293 (define-assembly-routine (generic-/=
 294                           (:cost 10)
 295                           (:return-style :full-call)
 296                           (:policy :safe)
 297                           (:translate /=)
 298                           (:save-p t))
 299                          ((:arg x (descriptor-reg any-reg) a0-offset)
 300                           (:arg y (descriptor-reg any-reg) a1-offset)
 301
 302                           (:res res descriptor-reg a0-offset)
 303
 304                           (:temp temp non-descriptor-reg nl0-offset)
 305                           (:temp lip interior-reg lip-offset)
 306                           (:temp nargs any-reg nargs-offset)
 307                           (:temp ocfp any-reg ocfp-offset))
 308   (inst or temp x y)
 309   (inst and temp fixnum-tag-mask)
 310   (inst beq temp RETURN)
 311   (inst nop)
 312
 313   ;; DO-STATIC-FUN
 314   (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
 315   (inst li nargs (fixnumize 2))
 316   (move ocfp cfp-tn)
 317   (inst j lip)
 318   (move cfp-tn csp-tn t)
 319
 320   RETURN
 321   (inst beq x y DONE)
 322   (move res null-tn t)
 323   (load-symbol res t)
 324
 325   DONE)