src/assembly/ppc/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
  14   (generic-+
  15    (:cost 10)
  16    (:return-style :full-call)
  17    (:translate +)
  18    (:policy :safe)
  19    (:save-p t))
  20   ((:arg x (descriptor-reg any-reg) a0-offset)
  21    (:arg y (descriptor-reg any-reg) a1-offset)
  22
  23    (:res res (descriptor-reg any-reg) a0-offset)
  24
  25    (:temp temp non-descriptor-reg nl0-offset)
  26    (:temp temp2 non-descriptor-reg nl1-offset)
  27    (:temp flag non-descriptor-reg nl3-offset)
  28    (:temp lra descriptor-reg lra-offset)
  29    (:temp nargs any-reg nargs-offset)
  30    (:temp lip interior-reg lip-offset)
  31    (:temp ocfp any-reg ocfp-offset))
  32
  33   ; Clear the damned "sticky overflow" bit in :cr0 and :xer
  34   (inst mtxer zero-tn)
  35   (inst or temp x y)
  36   (inst andi. temp temp 3)
  37   (inst bne DO-STATIC-FUN)
  38   (inst addo. temp x y)
  39   (inst bns done)
  40
  41   (inst srawi temp x 2)
  42   (inst srawi temp2 y 2)
  43   (inst add temp2 temp2 temp)
  44   (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset))
  45     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
  46   (lisp-return lra lip :offset 2)
  47
  48   DO-STATIC-FUN
  49   (inst lwz lip null-tn (static-fun-offset 'two-arg-+) )
  50   (inst li nargs (fixnumize 2))
  51   (inst mr ocfp cfp-tn)
  52   (inst mr cfp-tn csp-tn)
  53   (inst j lip 0)
  54
  55   DONE
  56   (move res temp))
  57
  58
  59 (define-assembly-routine
  60   (generic--
  61    (:cost 10)
  62    (:return-style :full-call)
  63    (:translate -)
  64    (:policy :safe)
  65    (:save-p t))
  66   ((:arg x (descriptor-reg any-reg) a0-offset)
  67    (:arg y (descriptor-reg any-reg) a1-offset)
  68
  69    (:res res (descriptor-reg any-reg) a0-offset)
  70
  71    (:temp temp non-descriptor-reg nl0-offset)
  72    (:temp temp2 non-descriptor-reg nl1-offset)
  73    (:temp flag non-descriptor-reg nl3-offset)
  74    (:temp lip interior-reg lip-offset)
  75    (:temp lra descriptor-reg lra-offset)
  76    (:temp nargs any-reg nargs-offset)
  77    (:temp ocfp any-reg ocfp-offset))
  78
  79   ; Clear the damned "sticky overflow" bit in :cr0
  80   (inst mtxer zero-tn)
  81
  82   (inst or temp x y)
  83   (inst andi. temp temp 3)
  84   (inst bne DO-STATIC-FUN)
  85
  86   (inst subo. temp x y)
  87   (inst bns done)
  88
  89   (inst srawi temp x 2)
  90   (inst srawi temp2 y 2)
  91   (inst sub temp2 temp temp2)
  92   (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset))
  93     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
  94   (lisp-return lra lip :offset 2)
  95
  96   DO-STATIC-FUN
  97   (inst lwz lip null-tn (static-fun-offset 'two-arg--))
  98   (inst li nargs (fixnumize 2))
  99   (inst mr ocfp cfp-tn)
 100   (inst mr cfp-tn csp-tn)
 101   (inst j lip 0)
 102
 103   DONE
 104   (move res temp))
 105
 106
 107 \f
 108 ;;;; Multiplication
 109
 110
 111 (define-assembly-routine
 112   (generic-*
 113    (:cost 50)
 114    (:return-style :full-call)
 115    (:translate *)
 116    (:policy :safe)
 117    (:save-p t))
 118   ((:arg x (descriptor-reg any-reg) a0-offset)
 119    (:arg y (descriptor-reg any-reg) a1-offset)
 120
 121    (:res res (descriptor-reg any-reg) a0-offset)
 122
 123    (:temp temp non-descriptor-reg nl0-offset)
 124    (:temp lo non-descriptor-reg nl1-offset)
 125    (:temp hi non-descriptor-reg nl2-offset)
 126    (:temp pa-flag non-descriptor-reg nl3-offset)
 127    (:temp lip interior-reg lip-offset)
 128    (:temp lra descriptor-reg lra-offset)
 129    (:temp nargs any-reg nargs-offset)
 130    (:temp ocfp any-reg ocfp-offset))
 131
 132   ;; If either arg is not a fixnum, call the static function.  But first ...
 133   (inst mtxer zero-tn)
 134
 135   (inst or temp x y)
 136   (inst andi. temp temp 3)
 137   ;; Remove the tag from both args, so I don't get so confused.
 138   (inst srawi temp x 2)
 139   (inst srawi nargs y 2)
 140   (inst bne DO-STATIC-FUN)
 141
 142
 143   (inst mullwo. lo nargs temp)
 144   (inst srawi hi lo 31)                 ; hi = 32 copies of lo's sign bit
 145   (inst bns ONE-WORD-ANSWER)
 146   (inst mulhw hi nargs temp)
 147   (inst b CONS-BIGNUM)
 148
 149   ONE-WORD-ANSWER                       ; We know that all of the overflow bits are clear.
 150   (inst addo temp lo lo)
 151   (inst addo. res temp temp)
 152   (inst bns GO-HOME)
 153
 154   CONS-BIGNUM
 155   ;; Allocate a BIGNUM for the result.
 156   (pseudo-atomic (pa-flag :extra (pad-data-block (1+ bignum-digits-offset)))
 157     (let ((one-word (gen-label)))
 158       (inst ori res alloc-tn other-pointer-lowtag)
 159       ;; We start out assuming that we need one word.  Is that correct?
 160       (inst srawi temp lo 31)
 161       (inst xor. temp temp hi)
 162       (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
 163       (inst beq one-word)
 164       ;; Nope, we need two, so allocate the additional space.
 165       (inst addi alloc-tn alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
 166                                       (pad-data-block (1+ bignum-digits-offset))))
 167       (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
 168       (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
 169       (emit-label one-word)
 170       (storew temp res 0 other-pointer-lowtag)
 171       (storew lo res bignum-digits-offset other-pointer-lowtag)))
 172   ;; Out of here
 173   GO-HOME
 174   (lisp-return lra lip :offset 2)
 175
 176   DO-STATIC-FUN
 177   (inst lwz lip null-tn (static-fun-offset 'two-arg-*))
 178   (inst li nargs (fixnumize 2))
 179   (inst mr ocfp cfp-tn)
 180   (inst mr cfp-tn csp-tn)
 181   (inst j lip 0)
 182
 183   LOW-FITS-IN-FIXNUM
 184   (move res lo))
 185
 186 (macrolet
 187     ((frob (name note cost type sc)
 188        `(define-assembly-routine (,name
 189                                   (:note ,note)
 190                                   (:cost ,cost)
 191                                   (:translate *)
 192                                   (:policy :fast-safe)
 193                                   (:arg-types ,type ,type)
 194                                   (:result-types ,type))
 195                                  ((:arg x ,sc nl0-offset)
 196                                   (:arg y ,sc nl1-offset)
 197                                   (:res res ,sc nl0-offset))
 198           ,@(when (eq type 'tagged-num)
 199               `((inst srawi x x 2)))
 200           (inst mullw res x y))))
 201   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
 202   (frob signed-* "unsigned *" 41 signed-num signed-reg)
 203   (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
 204
 205
 206 \f
 207 ;;;; Division.
 208
 209
 210 (define-assembly-routine (positive-fixnum-truncate
 211                           (:note "unsigned fixnum truncate")
 212                           (:cost 45)
 213                           (:translate truncate)
 214                           (:policy :fast-safe)
 215                           (:arg-types positive-fixnum positive-fixnum)
 216                           (:result-types positive-fixnum positive-fixnum))
 217                          ((:arg dividend any-reg nl0-offset)
 218                           (:arg divisor any-reg nl1-offset)
 219
 220                           (:res quo any-reg nl2-offset)
 221                           (:res rem any-reg nl0-offset))
 222   (aver (location= rem dividend))
 223   (let ((error (generate-error-code nil division-by-zero-error
 224                                     dividend divisor)))
 225     (inst cmpwi divisor 0)
 226     (inst beq error))
 227     (inst divwu quo dividend divisor)
 228     (inst mullw divisor quo divisor)
 229     (inst sub rem dividend divisor)
 230     (inst slwi quo quo 2))
 231
 232
 233
 234 (define-assembly-routine (fixnum-truncate
 235                           (:note "fixnum truncate")
 236                           (:cost 50)
 237                           (:policy :fast-safe)
 238                           (:translate truncate)
 239                           (:arg-types tagged-num tagged-num)
 240                           (:result-types tagged-num tagged-num))
 241                          ((:arg dividend any-reg nl0-offset)
 242                           (:arg divisor any-reg nl1-offset)
 243
 244                           (:res quo any-reg nl2-offset)
 245                           (:res rem any-reg nl0-offset))
 246
 247   (aver (location= rem dividend))
 248   (let ((error (generate-error-code nil division-by-zero-error
 249                                     dividend divisor)))
 250     (inst cmpwi divisor 0)
 251     (inst beq error))
 252
 253     (inst divw quo dividend divisor)
 254     (inst mullw divisor quo divisor)
 255     (inst subf rem divisor dividend)
 256     (inst slwi quo 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 nl0-offset))
 272
 273   (let ((error (generate-error-code nil division-by-zero-error
 274                                     dividend divisor)))
 275     (inst cmpwi divisor 0)
 276     (inst beq error))
 277
 278     (inst divw quo dividend divisor)
 279     (inst mullw divisor quo divisor)
 280     (inst subf rem divisor dividend))
 281
 282 \f
 283 ;;;; Comparison
 284
 285 (macrolet
 286     ((define-cond-assem-rtn (name translate static-fn cmp)
 287        `(define-assembly-routine
 288           (,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 lip interior-reg lip-offset)
 300            (:temp nargs any-reg nargs-offset)
 301            (:temp ocfp any-reg ocfp-offset))
 302
 303           (inst or nargs x y)
 304           (inst andi. nargs nargs 3)
 305           (inst cmpw :cr1 x y)
 306           (inst beq DO-COMPARE)
 307
 308           DO-STATIC-FN
 309           (inst lwz lip null-tn (static-fun-offset ',static-fn))
 310           (inst li nargs (fixnumize 2))
 311           (inst mr ocfp cfp-tn)
 312           (inst mr cfp-tn csp-tn)
 313           (inst j lip 0)
 314
 315           DO-COMPARE
 316           (load-symbol res t)
 317           (inst b? :cr1 ,cmp done)
 318           (inst mr res null-tn)
 319           DONE)))
 320
 321   (define-cond-assem-rtn generic-< < two-arg-< :lt)
 322   (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
 323   (define-cond-assem-rtn generic-> > two-arg-> :gt)
 324   (define-cond-assem-rtn generic->= >= two-arg->= :ge))
 325
 326
 327 (define-assembly-routine (generic-eql
 328                           (:cost 10)
 329                           (:return-style :full-call)
 330                           (:policy :safe)
 331                           (:translate eql)
 332                           (:save-p t))
 333                          ((:arg x (descriptor-reg any-reg) a0-offset)
 334                           (:arg y (descriptor-reg any-reg) a1-offset)
 335
 336                           (:res res descriptor-reg a0-offset)
 337
 338                           (:temp lra descriptor-reg lra-offset)
 339                           (:temp lip interior-reg lip-offset)
 340                           (:temp nargs any-reg nargs-offset)
 341                           (:temp ocfp any-reg ocfp-offset))
 342   (inst cmpw :cr1 x y)
 343   (inst andi. nargs x 3)
 344   (inst beq :cr1 RETURN-T)
 345   (inst beq RETURN-NIL)                 ; x was fixnum, not eq y
 346   (inst andi. nargs y 3)
 347   (inst bne DO-STATIC-FN)
 348
 349   RETURN-NIL
 350   (inst mr res null-tn)
 351   (lisp-return lra lip :offset 2)
 352
 353   DO-STATIC-FN
 354   (inst lwz lip null-tn (static-fun-offset 'eql))
 355   (inst li nargs (fixnumize 2))
 356   (inst mr ocfp cfp-tn)
 357   (inst mr cfp-tn csp-tn)
 358   (inst j lip 0)
 359
 360   RETURN-T
 361   (load-symbol res t))
 362
 363 (define-assembly-routine
 364   (generic-=
 365    (:cost 10)
 366    (:return-style :full-call)
 367    (:policy :safe)
 368    (:translate =)
 369    (:save-p t))
 370   ((:arg x (descriptor-reg any-reg) a0-offset)
 371    (:arg y (descriptor-reg any-reg) a1-offset)
 372
 373    (:res res descriptor-reg a0-offset)
 374
 375    (:temp lip interior-reg lip-offset)
 376    (:temp lra descriptor-reg lra-offset)
 377    (:temp nargs any-reg nargs-offset)
 378    (:temp ocfp any-reg ocfp-offset))
 379
 380   (inst or nargs x y)
 381   (inst andi. nargs nargs 3)
 382   (inst cmpw :cr1 x y)
 383   (inst bne DO-STATIC-FN)
 384   (inst beq :cr1 RETURN-T)
 385
 386   (inst mr res null-tn)
 387   (lisp-return lra lip :offset 2)
 388
 389   DO-STATIC-FN
 390   (inst lwz lip null-tn (static-fun-offset 'two-arg-=))
 391   (inst li nargs (fixnumize 2))
 392   (inst mr ocfp cfp-tn)
 393   (inst mr cfp-tn csp-tn)
 394   (inst j lip 0)
 395
 396   RETURN-T
 397   (load-symbol res t))
 398
 399 (define-assembly-routine (generic-/=
 400                           (:cost 10)
 401                           (:return-style :full-call)
 402                           (:policy :safe)
 403                           (:translate /=)
 404                           (:save-p t))
 405                          ((:arg x (descriptor-reg any-reg) a0-offset)
 406                           (:arg y (descriptor-reg any-reg) a1-offset)
 407
 408                           (:res res descriptor-reg a0-offset)
 409
 410                           (:temp lra descriptor-reg lra-offset)
 411                           (:temp lip interior-reg lip-offset)
 412
 413                           (:temp nargs any-reg nargs-offset)
 414                           (:temp ocfp any-reg ocfp-offset))
 415   (inst or nargs x y)
 416   (inst andi. nargs nargs 3)
 417   (inst cmpw :cr1 x y)
 418   (inst bne DO-STATIC-FN)
 419   (inst beq :cr1 RETURN-NIL)
 420
 421   (load-symbol res t)
 422   (lisp-return lra lip :offset 2)
 423
 424   DO-STATIC-FN
 425   (inst lwz lip null-tn (static-fun-offset 'two-arg-/=))
 426   (inst li nargs (fixnumize 2))
 427   (inst mr ocfp cfp-tn)
 428   (inst j lip 0)
 429   (inst mr cfp-tn csp-tn)
 430
 431   RETURN-NIL
 432   (inst mr res null-tn))