src/assembly/alpha/arith.lisp

   1 ;;; **********************************************************************
   2 ;;; This code was written as part of the CMU Common Lisp project at
   3 ;;; Carnegie Mellon University, and has been placed in the public domain.
   4 ;;;
   5 ;;;
   6 ;;; **********************************************************************
   7 ;;;
   8 ;;; Stuff to handle simple cases for generic arithmetic.
   9 ;;;
  10 ;;; Written by William Lott.
  11 ;;; Conversion by Sean Hallgren
  12 ;;;
  13
  14 (in-package "SB!VM")
  15
  16
  17
  18 (define-assembly-routine (generic-+
  19                           (:cost 10)
  20                           (:return-style :full-call)
  21                           (:translate +)
  22                           (:policy :safe)
  23                           (:save-p t))
  24                          ((:arg x (descriptor-reg any-reg) a0-offset)
  25                           (:arg y (descriptor-reg any-reg) a1-offset)
  26
  27                           (:res res (descriptor-reg any-reg) a0-offset)
  28
  29                           (:temp temp non-descriptor-reg nl0-offset)
  30                           (:temp temp2 non-descriptor-reg nl1-offset)
  31                           (:temp temp3 non-descriptor-reg nl2-offset)
  32                           (:temp lip interior-reg lip-offset)
  33                           (:temp lra descriptor-reg lra-offset)
  34                           (:temp nargs any-reg nargs-offset)
  35                           (:temp ocfp any-reg ocfp-offset))
  36   (inst and x 3 temp)
  37   (inst bne temp DO-STATIC-FUN)
  38   (inst and y 3 temp)
  39   (inst bne temp DO-STATIC-FUN)
  40   (inst addq x y res)
  41
  42   ; Check to see if we need a bignum
  43   (inst sra res 31 temp)
  44   (inst beq temp DONE)
  45   (inst not temp temp)
  46   (inst beq temp DONE)
  47   (inst sra res 2 temp3)
  48
  49   ; From move-from-signed
  50   (inst li 2 temp2)
  51   (inst sra temp3 31 temp)
  52   (inst cmoveq temp 1 temp2)
  53   (inst not temp temp)
  54   (inst cmoveq temp 1 temp2)
  55   (inst sll temp2 type-bits temp2)
  56   (inst bis temp2 bignum-type temp2)
  57
  58   (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
  59     (inst bis alloc-tn other-pointer-type res)
  60     (storew temp2 res 0 other-pointer-type)
  61     (storew temp3 res bignum-digits-offset other-pointer-type)
  62     (inst srl temp3 32 temp)
  63     (storew temp res (1+ bignum-digits-offset) other-pointer-type))
  64   DONE
  65   (lisp-return lra lip :offset 2)
  66
  67   DO-STATIC-FUN
  68   (inst ldl lip (static-function-offset 'two-arg-+) null-tn)
  69   (inst li (fixnumize 2) nargs)
  70   (inst move cfp-tn ocfp)
  71   (inst move csp-tn cfp-tn)
  72   (inst jmp zero-tn lip))
  73
  74
  75 (define-assembly-routine (generic--
  76                           (:cost 10)
  77                           (:return-style :full-call)
  78                           (:translate -)
  79                           (:policy :safe)
  80                           (:save-p t))
  81                          ((:arg x (descriptor-reg any-reg) a0-offset)
  82                           (:arg y (descriptor-reg any-reg) a1-offset)
  83
  84                           (:res res (descriptor-reg any-reg) a0-offset)
  85
  86                           (:temp temp non-descriptor-reg nl0-offset)
  87                           (:temp temp2 non-descriptor-reg nl1-offset)
  88                           (:temp temp3 non-descriptor-reg nl2-offset)
  89                           (:temp lip interior-reg lip-offset)
  90                           (:temp lra descriptor-reg lra-offset)
  91                           (:temp nargs any-reg nargs-offset)
  92                           (:temp ocfp any-reg ocfp-offset))
  93   (inst and x 3 temp)
  94   (inst bne temp DO-STATIC-FUN)
  95   (inst and y 3 temp)
  96   (inst bne temp DO-STATIC-FUN)
  97   (inst subq x y res)
  98
  99   ; Check to see if we need a bignum
 100   (inst sra res 31 temp)
 101   (inst beq temp DONE)
 102   (inst not temp temp)
 103   (inst beq temp DONE)
 104   (inst sra res 2 temp3)
 105
 106   ; From move-from-signed
 107   (inst li 2 temp2)
 108   (inst sra temp3 31 temp)
 109   (inst cmoveq temp 1 temp2)
 110   (inst not temp temp)
 111   (inst cmoveq temp 1 temp2)
 112   (inst sll temp2 type-bits temp2)
 113   (inst bis temp2 bignum-type temp2)
 114
 115   (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
 116     (inst bis alloc-tn other-pointer-type res)
 117     (storew temp2 res 0 other-pointer-type)
 118     (storew temp3 res bignum-digits-offset other-pointer-type)
 119     (inst srl temp3 32 temp)
 120     (storew temp res (1+ bignum-digits-offset) other-pointer-type))
 121   DONE
 122   (lisp-return lra lip :offset 2)
 123
 124   DO-STATIC-FUN
 125   (inst ldl lip (static-function-offset 'two-arg--) null-tn)
 126   (inst li (fixnumize 2) nargs)
 127   (inst move cfp-tn ocfp)
 128   (inst move csp-tn cfp-tn)
 129   (inst jmp zero-tn lip))
 130
 131
 132 (define-assembly-routine (generic-*
 133                           (:cost 25)
 134                           (:return-style :full-call)
 135                           (:translate *)
 136                           (:policy :safe)
 137                           (:save-p t))
 138                          ((:arg x (descriptor-reg any-reg) a0-offset)
 139                           (:arg y (descriptor-reg any-reg) a1-offset)
 140
 141                           (:res res (descriptor-reg any-reg) a0-offset)
 142
 143                           (:temp temp non-descriptor-reg nl0-offset)
 144                           (:temp lo non-descriptor-reg nl1-offset)
 145                           (:temp hi non-descriptor-reg nl2-offset)
 146                           (:temp temp2 non-descriptor-reg nl3-offset)
 147                           (:temp lip interior-reg lip-offset)
 148                           (:temp lra descriptor-reg lra-offset)
 149                           (:temp nargs any-reg nargs-offset)
 150                           (:temp ocfp any-reg ocfp-offset))
 151   ;; If either arg is not a fixnum, call the static function.
 152   (inst and x 3 temp)
 153   (inst bne temp DO-STATIC-FUN)
 154   (inst and y 3 temp)
 155   (inst bne temp DO-STATIC-FUN)
 156
 157   ;; Remove the tag from one arg so that the result will have the correct
 158   ;; fixnum tag.
 159   (inst sra x 2 temp)
 160   (inst mulq temp y lo)
 161   (inst sra lo 32 hi)
 162   (inst sll lo 32 res)
 163   (inst sra res 32 res)
 164   ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
 165   ;; is just 32 copies of the sign bit of the low word).
 166   (inst sra res 31 temp)
 167   (inst xor hi temp temp)
 168   (inst beq temp DONE)
 169   ;; Shift the double word hi:res down two bits into hi:low to get rid of the
 170   ;; fixnum tag.
 171   (inst sra lo 2 lo)
 172   (inst sra lo 32 hi)
 173
 174   ;; Do we need one word or two?  Assume two.
 175   (inst li (logior (ash 2 type-bits) bignum-type) temp2)
 176   (inst sra lo 31 temp)
 177   (inst xor temp hi temp)
 178   (inst bne temp two-words)
 179
 180   ;; Only need one word, fix the header.
 181   (inst li (logior (ash 1 type-bits) bignum-type) temp2)
 182   ;; Allocate one word.
 183   (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
 184     (inst bis alloc-tn other-pointer-type res)
 185     (storew temp2 res 0 other-pointer-type))
 186   ;; Store one word
 187   (storew lo res bignum-digits-offset other-pointer-type)
 188   ;; Out of here
 189   (lisp-return lra lip :offset 2)
 190
 191   TWO-WORDS
 192   ;; Allocate two words.
 193   (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset)))
 194     (inst bis alloc-tn other-pointer-type res)
 195     (storew temp2 res 0 other-pointer-type))
 196   ;; Store two words.
 197   (storew lo res bignum-digits-offset other-pointer-type)
 198   (storew hi res (1+ bignum-digits-offset) other-pointer-type)
 199   ;; Out of here
 200   (lisp-return lra lip :offset 2)
 201
 202   DO-STATIC-FUN
 203   (inst ldl lip (static-function-offset 'two-arg-*) null-tn)
 204   (inst li (fixnumize 2) nargs)
 205   (inst move cfp-tn ocfp)
 206   (inst move csp-tn cfp-tn)
 207   (inst jmp zero-tn lip)
 208
 209   DONE)
 210
 211 \f
 212 ;;;; Division.
 213
 214 (define-assembly-routine (signed-truncate
 215                           (:note "(signed-byte 32) truncate")
 216                           (:cost 60)
 217                           (:policy :fast-safe)
 218                           (:translate truncate)
 219                           (:arg-types signed-num signed-num)
 220                           (:result-types signed-num signed-num))
 221
 222                          ((:arg dividend signed-reg nl0-offset)
 223                           (:arg divisor signed-reg nl1-offset)
 224
 225                           (:res quo signed-reg nl2-offset)
 226                           (:res rem signed-reg nl3-offset)
 227
 228                           (:temp quo-sign signed-reg nl5-offset)
 229                           (:temp rem-sign signed-reg nargs-offset)
 230                           (:temp temp1 non-descriptor-reg nl4-offset))
 231
 232   (let ((error (generate-error-code nil division-by-zero-error
 233                                     dividend divisor)))
 234     (inst beq divisor error))
 235
 236   (inst xor dividend divisor quo-sign)
 237   (inst move dividend rem-sign)
 238   (let ((label (gen-label)))
 239     (inst bge dividend label)
 240     (inst subq zero-tn dividend dividend)
 241     (emit-label label))
 242   (let ((label (gen-label)))
 243     (inst bge divisor label)
 244     (inst subq zero-tn divisor divisor)
 245     (emit-label label))
 246   (inst move zero-tn rem)
 247   (inst move zero-tn quo)
 248   (inst sll dividend 32 dividend)
 249
 250   (dotimes (i 32)
 251     (inst srl dividend 63 temp1)
 252     (inst sll rem 1 rem)
 253     (inst bis temp1 rem rem)
 254     (inst cmple divisor rem temp1)
 255     (inst sll quo 1 quo)
 256     (inst bis temp1 quo quo)
 257     (inst sll dividend 1 dividend)
 258     (inst subq temp1 1 temp1)
 259     (inst zap divisor temp1 temp1)
 260     (inst subq rem temp1 rem))
 261
 262   (let ((label (gen-label)))
 263     ;; If the quo-sign is negative, we need to negate quo.
 264     (inst bge quo-sign label)
 265     (inst subq zero-tn quo quo)
 266     (emit-label label))
 267   (let ((label (gen-label)))
 268     ;; If the rem-sign is negative, we need to negate rem.
 269     (inst bge rem-sign label)
 270     (inst subq zero-tn rem rem)
 271     (emit-label label)))
 272
 273 \f
 274 ;;;; Comparison routines.
 275
 276 (macrolet
 277     ((define-cond-assem-rtn (name translate static-fn cmp not-p)
 278        `(define-assembly-routine (,name
 279                                   (:cost 10)
 280                                   (:return-style :full-call)
 281                                   (:policy :safe)
 282                                   (:translate ,translate)
 283                                   (:save-p t))
 284                                  ((:arg x (descriptor-reg any-reg) a0-offset)
 285                                   (:arg y (descriptor-reg any-reg) a1-offset)
 286
 287                                   (:res res descriptor-reg a0-offset)
 288
 289                                   (:temp temp non-descriptor-reg nl0-offset)
 290                                   (:temp lip interior-reg lip-offset)
 291                                   (:temp nargs any-reg nargs-offset)
 292                                   (:temp ocfp any-reg ocfp-offset))
 293           (inst and x 3 temp)
 294           (inst bne temp DO-STATIC-FN)
 295           (inst and y 3 temp)
 296           (inst beq temp DO-COMPARE)
 297
 298           DO-STATIC-FN
 299           (inst ldl lip (static-function-offset ',static-fn) null-tn)
 300           (inst li (fixnumize 2) nargs)
 301           (inst move cfp-tn ocfp)
 302           (inst move csp-tn cfp-tn)
 303           (inst jmp zero-tn lip)
 304
 305           DO-COMPARE
 306           ,cmp
 307           (inst move null-tn res)
 308           (inst ,(if not-p 'bne 'beq) temp done)
 309           (load-symbol res t)
 310           DONE)))
 311
 312   (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil)
 313   (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil))
 314
 315
 316 (define-assembly-routine (generic-eql
 317                           (:cost 10)
 318                           (:return-style :full-call)
 319                           (:policy :safe)
 320                           (:translate eql)
 321                           (:save-p t))
 322                          ((:arg x (descriptor-reg any-reg) a0-offset)
 323                           (:arg y (descriptor-reg any-reg) a1-offset)
 324
 325                           (:res res descriptor-reg a0-offset)
 326
 327                           (:temp temp non-descriptor-reg nl0-offset)
 328                           (:temp lip interior-reg lip-offset)
 329                           (:temp lra descriptor-reg lra-offset)
 330                           (:temp nargs any-reg nargs-offset)
 331                           (:temp ocfp any-reg ocfp-offset))
 332   (inst cmpeq x y temp)
 333   (inst bne temp RETURN-T)
 334   (inst and x 3 temp)
 335   (inst beq temp RETURN-NIL)
 336   (inst and y 3 temp)
 337   (inst bne temp DO-STATIC-FN)
 338
 339   RETURN-NIL
 340   (inst move null-tn res)
 341   (lisp-return lra lip :offset 2)
 342
 343   DO-STATIC-FN
 344   (inst ldl lip (static-function-offset 'eql) null-tn)
 345   (inst li (fixnumize 2) nargs)
 346   (inst move cfp-tn ocfp)
 347   (inst move csp-tn cfp-tn)
 348   (inst jmp zero-tn lip)
 349
 350   RETURN-T
 351   (load-symbol res t))
 352
 353 (define-assembly-routine (generic-=
 354                           (:cost 10)
 355                           (:return-style :full-call)
 356                           (:policy :safe)
 357                           (:translate =)
 358                           (:save-p t))
 359                          ((:arg x (descriptor-reg any-reg) a0-offset)
 360                           (:arg y (descriptor-reg any-reg) a1-offset)
 361
 362                           (:res res descriptor-reg a0-offset)
 363
 364                           (:temp temp non-descriptor-reg nl0-offset)
 365                           (:temp lip interior-reg lip-offset)
 366                           (:temp lra descriptor-reg lra-offset)
 367                           (:temp nargs any-reg nargs-offset)
 368                           (:temp ocfp any-reg ocfp-offset))
 369   (inst and x 3 temp)
 370   (inst bne temp DO-STATIC-FN)
 371   (inst and y 3 temp)
 372   (inst bne temp DO-STATIC-FN)
 373   (inst cmpeq x y temp)
 374   (inst bne temp RETURN-T)
 375
 376   (inst move null-tn res)
 377   (lisp-return lra lip :offset 2)
 378
 379   DO-STATIC-FN
 380   (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
 381   (inst li (fixnumize 2) nargs)
 382   (inst move cfp-tn ocfp)
 383   (inst move csp-tn cfp-tn)
 384   (inst jmp zero-tn lip)
 385
 386   RETURN-T
 387   (load-symbol res t))
 388
 389 (define-assembly-routine (generic-/=
 390                           (:cost 10)
 391                           (:return-style :full-call)
 392                           (:policy :safe)
 393                           (:translate /=)
 394                           (:save-p t))
 395                          ((:arg x (descriptor-reg any-reg) a0-offset)
 396                           (:arg y (descriptor-reg any-reg) a1-offset)
 397
 398                           (:res res descriptor-reg a0-offset)
 399
 400                           (:temp temp non-descriptor-reg nl0-offset)
 401                           (:temp lip interior-reg lip-offset)
 402                           (:temp lra descriptor-reg lra-offset)
 403                           (:temp nargs any-reg nargs-offset)
 404                           (:temp ocfp any-reg ocfp-offset))
 405   (inst and x 3 temp)
 406   (inst bne temp DO-STATIC-FN)
 407   (inst and y 3 temp)
 408   (inst bne temp DO-STATIC-FN)
 409   (inst cmpeq x y temp)
 410   (inst bne temp RETURN-NIL)
 411
 412   (load-symbol res t)
 413   (lisp-return lra lip :offset 2)
 414
 415   DO-STATIC-FN
 416   (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
 417   (inst li (fixnumize 2) nargs)
 418   (inst move cfp-tn ocfp)
 419   (inst move csp-tn cfp-tn)
 420   (inst jmp zero-tn lip)
 421
 422   RETURN-NIL
 423   (inst move null-tn res))