src/assembly/x86-64/arith.lisp

   1 ;;;; simple cases for generic arithmetic
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13 \f
  14 ;;;; addition, subtraction, and multiplication
  15
  16 (macrolet ((define-generic-arith-routine ((fun cost) &body body)
  17              `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
  18                                         (:cost ,cost)
  19                                         (:return-style :full-call)
  20                                         (:translate ,fun)
  21                                         (:policy :safe)
  22                                         (:save-p t))
  23                 ((:arg x (descriptor-reg any-reg) rdx-offset)
  24                  (:arg y (descriptor-reg any-reg)
  25                        ;; this seems wrong esi-offset -- FIXME: What's it mean?
  26                        rdi-offset)
  27
  28                  (:res res (descriptor-reg any-reg) rdx-offset)
  29
  30                  (:temp rax unsigned-reg rax-offset)
  31                  (:temp rcx unsigned-reg rcx-offset))
  32
  33                 (inst mov rcx x)
  34                 (inst or rcx y)
  35                 (inst test rcx fixnum-tag-mask) ; both fixnums?
  36                 (inst jmp :nz DO-STATIC-FUN)    ; no - do generic
  37
  38                 ,@body
  39                 (inst clc)
  40                 (inst ret)
  41
  42                 DO-STATIC-FUN
  43                 (inst pop rax)
  44                 (inst push rbp-tn)
  45                 (inst lea
  46                       rbp-tn
  47                       (make-ea :qword :base rsp-tn :disp n-word-bytes))
  48                 (inst sub rsp-tn (fixnumize 2))
  49                 (inst push rax)              ; callers return addr
  50                 (inst mov rcx (fixnumize 2)) ; arg count
  51                 (inst jmp
  52                       (make-ea :qword
  53                                :disp (+ nil-value
  54                                         (static-fun-offset
  55                                          ',(symbolicate "TWO-ARG-" fun))))))))
  56
  57   (define-generic-arith-routine (+ 10)
  58     (move res x)
  59     (inst add res y)
  60     (inst jmp :no OKAY)
  61     (inst rcr res 1)                  ; carry has correct sign
  62     (inst sar res 2)                  ; remove type bits
  63
  64     (move rcx res)
  65
  66     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
  67       (storew rcx res bignum-digits-offset other-pointer-lowtag))
  68
  69     OKAY)
  70
  71   (define-generic-arith-routine (- 10)
  72     (move res x)
  73     (inst sub res y)
  74     (inst jmp :no OKAY)
  75     (inst cmc)                        ; carry has correct sign now
  76     (inst rcr res 1)
  77     (inst sar res 2)                  ; remove type bits
  78
  79     (move rcx res)
  80
  81     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
  82       (storew rcx res bignum-digits-offset other-pointer-lowtag))
  83     OKAY)
  84
  85   (define-generic-arith-routine (* 30)
  86     (move rax x)                     ; must use eax for 64-bit result
  87     (inst sar rax n-fixnum-tag-bits) ; remove *8 fixnum bias
  88     (inst imul y)                    ; result in edx:eax
  89     (inst jmp :no OKAY)              ; still fixnum
  90
  91     (inst shrd rax x n-fixnum-tag-bits) ; high bits from edx
  92     (inst sar x n-fixnum-tag-bits)      ; now shift edx too
  93
  94     (move rcx x)                   ; save high bits from cqo
  95     (inst cqo)                     ; edx:eax <- sign-extend of eax
  96     (inst cmp x rcx)
  97     (inst jmp :e SINGLE-WORD-BIGNUM)
  98
  99     (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
 100       (storew rax res bignum-digits-offset other-pointer-lowtag)
 101       (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
 102     (inst jmp DONE)
 103
 104     SINGLE-WORD-BIGNUM
 105
 106     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
 107       (storew rax res bignum-digits-offset other-pointer-lowtag))
 108     (inst jmp DONE)
 109
 110     OKAY
 111     (move res rax)
 112     DONE))
 113 \f
 114 ;;;; negation
 115
 116 (define-assembly-routine (generic-negate
 117                           (:cost 10)
 118                           (:return-style :full-call)
 119                           (:policy :safe)
 120                           (:translate %negate)
 121                           (:save-p t))
 122                          ((:arg x (descriptor-reg any-reg) rdx-offset)
 123                           (:res res (descriptor-reg any-reg) rdx-offset)
 124
 125                           (:temp rax unsigned-reg rax-offset)
 126                           (:temp rcx unsigned-reg rcx-offset))
 127   (inst test x fixnum-tag-mask)
 128   (inst jmp :z FIXNUM)
 129
 130   (inst pop rax)
 131   (inst push rbp-tn)
 132   (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
 133   (inst sub rsp-tn (fixnumize 2))
 134   (inst push rax)
 135   (inst mov rcx (fixnumize 1))    ; arg count
 136   (inst jmp (make-ea :qword
 137                      :disp (+ nil-value (static-fun-offset '%negate))))
 138
 139   FIXNUM
 140   (move res x)
 141   (inst neg res)                        ; (- most-negative-fixnum) is BIGNUM
 142   (inst jmp :no OKAY)
 143   (inst shr res n-fixnum-tag-bits)      ; sign bit is data - remove type bits
 144   (move rcx res)
 145
 146   (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
 147     (storew rcx res bignum-digits-offset other-pointer-lowtag))
 148
 149   OKAY)
 150 \f
 151 ;;;; comparison
 152
 153 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
 154                (declare (ignorable translate static-fn))
 155              #+sb-assembling
 156              `(define-assembly-routine (,name
 157                                         (:return-style :none))
 158                   ((:arg x (descriptor-reg any-reg) rdx-offset)
 159                    (:arg y (descriptor-reg any-reg) rdi-offset)
 160
 161                    (:temp rcx unsigned-reg rcx-offset))
 162
 163                 (inst mov rcx x)
 164                 (inst or rcx y)
 165                 (inst test rcx fixnum-tag-mask)
 166                 (inst jmp :nz DO-STATIC-FUN)
 167
 168                 (inst cmp x y)
 169                 (inst ret)
 170
 171                 DO-STATIC-FUN
 172                 (move rcx rsp-tn)
 173                 (inst sub rsp-tn (fixnumize 3))
 174                 (inst mov (make-ea :qword
 175                                    :base rcx
 176                                    :disp (fixnumize -1))
 177                       rbp-tn)
 178                 (move rbp-tn rcx)
 179                 (inst mov rcx (fixnumize 2))
 180                 (inst call (make-ea :qword
 181                                     :disp (+ nil-value
 182                                              (static-fun-offset ',static-fn))))
 183                 ;; HACK: We depend on NIL having the lowest address of all
 184                 ;; static symbols (including T)
 185                 ,@(ecase test
 186                     (:l `((inst mov y (1+ nil-value))
 187                           (inst cmp y x)))
 188                     (:g `((inst cmp x (1+ nil-value)))))
 189                 (inst ret))
 190              #-sb-assembling
 191              `(define-vop (,name)
 192                 (:translate ,translate)
 193                 (:policy :safe)
 194                 (:save-p t)
 195                 (:args (x :scs (descriptor-reg any-reg) :target rdx)
 196                        (y :scs (descriptor-reg any-reg) :target rdi))
 197
 198                 (:temporary (:sc unsigned-reg :offset rdx-offset
 199                                  :from (:argument 0))
 200                             rdx)
 201                 (:temporary (:sc unsigned-reg :offset rdi-offset
 202                                  :from (:argument 1))
 203                             rdi)
 204
 205                 (:temporary (:sc unsigned-reg :offset rcx-offset
 206                                  :from :eval)
 207                             rcx)
 208                 (:conditional ,test)
 209                 (:generator 10
 210                    (move rdx x)
 211                    (move rdi y)
 212                    (inst lea rcx (make-ea :qword
 213                                           :disp (make-fixup ',name :assembly-routine)))
 214                    (inst call rcx)))))
 215
 216   (define-cond-assem-rtn generic-< < two-arg-< :l)
 217   (define-cond-assem-rtn generic-> > two-arg-> :g))
 218
 219 #+sb-assembling
 220 (define-assembly-routine (generic-eql
 221                           (:return-style :none))
 222                          ((:arg x (descriptor-reg any-reg) rdx-offset)
 223                           (:arg y (descriptor-reg any-reg) rdi-offset)
 224
 225                           (:temp rcx unsigned-reg rcx-offset))
 226
 227   (inst mov rcx x)
 228   (inst and rcx y)
 229   (inst test rcx fixnum-tag-mask)
 230   (inst jmp :nz DO-STATIC-FUN)
 231
 232   ;; At least one fixnum
 233   (inst cmp x y)
 234   (inst ret)
 235
 236   DO-STATIC-FUN
 237   (move rcx rsp-tn)
 238   (inst sub rsp-tn (fixnumize 3))
 239   (inst mov (make-ea :qword
 240                      :base rcx
 241                      :disp (fixnumize -1))
 242         rbp-tn)
 243   (move rbp-tn rcx)
 244   (inst mov rcx (fixnumize 2))
 245   (inst call (make-ea :qword
 246                       :disp (+ nil-value (static-fun-offset 'eql))))
 247   (load-symbol y t)
 248   (inst cmp x y)
 249   (inst ret))
 250
 251 #-sb-assembling
 252 (define-vop (generic-eql)
 253   (:translate eql)
 254   (:policy :safe)
 255   (:save-p t)
 256   (:args (x :scs (descriptor-reg any-reg) :target rdx)
 257          (y :scs (descriptor-reg any-reg) :target rdi))
 258
 259   (:temporary (:sc unsigned-reg :offset rdx-offset
 260                :from (:argument 0))
 261               rdx)
 262   (:temporary (:sc unsigned-reg :offset rdi-offset
 263                :from (:argument 1))
 264               rdi)
 265
 266   (:temporary (:sc unsigned-reg :offset rcx-offset
 267                :from :eval)
 268               rcx)
 269   (:conditional :e)
 270   (:generator 10
 271     (move rdx x)
 272     (move rdi y)
 273     (inst lea rcx (make-ea :qword
 274                            :disp (make-fixup 'generic-eql :assembly-routine)))
 275     (inst call rcx)))
 276
 277 #+sb-assembling
 278 (define-assembly-routine (generic-=
 279                           (:return-style :none))
 280                          ((:arg x (descriptor-reg any-reg) rdx-offset)
 281                           (:arg y (descriptor-reg any-reg) rdi-offset)
 282
 283                           (:temp rcx unsigned-reg rcx-offset))
 284   (inst mov rcx x)
 285   (inst or rcx y)
 286   (inst test rcx fixnum-tag-mask)
 287   (inst jmp :nz DO-STATIC-FUN)
 288
 289   ;; Both fixnums
 290   (inst cmp x y)
 291   (inst ret)
 292
 293   DO-STATIC-FUN
 294   (move rcx rsp-tn)
 295   (inst sub rsp-tn (fixnumize 3))
 296   (inst mov (make-ea :qword
 297                      :base rcx
 298                      :disp (fixnumize -1))
 299         rbp-tn)
 300   (move rbp-tn rcx)
 301   (inst mov rcx (fixnumize 2))
 302   (inst call (make-ea :qword
 303                       :disp (+ nil-value (static-fun-offset 'two-arg-=))))
 304   (load-symbol y t)
 305   (inst cmp x y)
 306   (inst ret))
 307
 308 #-sb-assembling
 309 (define-vop (generic-=)
 310   (:translate =)
 311   (:policy :safe)
 312   (:save-p t)
 313   (:args (x :scs (descriptor-reg any-reg) :target rdx)
 314          (y :scs (descriptor-reg any-reg) :target rdi))
 315
 316   (:temporary (:sc unsigned-reg :offset rdx-offset
 317                :from (:argument 0))
 318               rdx)
 319   (:temporary (:sc unsigned-reg :offset rdi-offset
 320                :from (:argument 1))
 321               rdi)
 322
 323   (:temporary (:sc unsigned-reg :offset rcx-offset
 324                :from :eval)
 325               rcx)
 326   (:conditional :e)
 327   (:generator 10
 328     (move rdx x)
 329     (move rdi y)
 330     (inst lea rcx (make-ea :qword
 331                            :disp (make-fixup 'generic-= :assembly-routine)))
 332     (inst call rcx)))