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