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