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