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