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 7)            ; 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 3)               ; remove *4 fixnum bias
  88     (inst imul y)                  ; result in edx:eax
  89     (inst jmp :no OKAY)            ; still fixnum
  90
  91     ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
  92     ;;     pfw says that loses big -- edx is target for arg x and result res
  93     ;;     note that 'edx' is not defined -- using x
  94     (inst shrd rax x 3)            ; high bits from edx
  95     (inst sar x 3)                 ; now shift edx too
  96
  97     (move rcx x)                   ; save high bits from cqo
  98     (inst cqo)                     ; edx:eax <- sign-extend of eax
  99     (inst cmp x rcx)
 100     (inst jmp :e SINGLE-WORD-BIGNUM)
 101
 102     (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
 103       (storew rax res bignum-digits-offset other-pointer-lowtag)
 104       (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
 105     (inst jmp DONE)
 106
 107     SINGLE-WORD-BIGNUM
 108
 109     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
 110       (storew rax res bignum-digits-offset other-pointer-lowtag))
 111     (inst jmp DONE)
 112
 113     OKAY
 114     (move res rax)
 115     DONE))
 116 \f
 117 ;;;; negation
 118
 119 (define-assembly-routine (generic-negate
 120                           (:cost 10)
 121                           (:return-style :full-call)
 122                           (:policy :safe)
 123                           (:translate %negate)
 124                           (:save-p t))
 125                          ((:arg x (descriptor-reg any-reg) rdx-offset)
 126                           (:res res (descriptor-reg any-reg) rdx-offset)
 127
 128                           (:temp rax unsigned-reg rax-offset)
 129                           (:temp rcx unsigned-reg rcx-offset))
 130   (inst test x 7)
 131   (inst jmp :z FIXNUM)
 132
 133   (inst pop rax)
 134   (inst push rbp-tn)
 135   (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
 136   (inst sub rsp-tn (fixnumize 2))
 137   (inst push rax)
 138   (inst mov rcx (fixnumize 1))    ; arg count
 139   (inst jmp (make-ea :qword
 140                      :disp (+ nil-value (static-fun-offset '%negate))))
 141
 142   FIXNUM
 143   (move res x)
 144   (inst neg res)                        ; (- most-negative-fixnum) is BIGNUM
 145   (inst jmp :no OKAY)
 146   (inst shr res 3)                    ; sign bit is data - remove type bits
 147   (move rcx res)
 148
 149   (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
 150     (storew rcx res bignum-digits-offset other-pointer-lowtag))
 151
 152   OKAY)
 153 \f
 154 ;;;; comparison
 155
 156 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
 157              `(define-assembly-routine (,name
 158                                         (:cost 10)
 159                                         (:return-style :full-call)
 160                                         (:policy :safe)
 161                                         (:translate ,translate)
 162                                         (:save-p t))
 163                 ((:arg x (descriptor-reg any-reg) rdx-offset)
 164                  (:arg y (descriptor-reg any-reg) rdi-offset)
 165
 166                  (:res res descriptor-reg rdx-offset)
 167
 168                  (:temp eax unsigned-reg rax-offset)
 169                  (:temp ecx unsigned-reg rcx-offset))
 170
 171                 ;; KLUDGE: The "3" here is a mask for the bits which will be
 172                 ;; zero in a fixnum. It should have a symbolic name. (Actually,
 173                 ;; it might already have a symbolic name which the coder
 174                 ;; couldn't be bothered to use..) -- WHN 19990917
 175                 (inst test x 7)
 176                 (inst jmp :nz TAIL-CALL-TO-STATIC-FN)
 177                 (inst test y 7)
 178                 (inst jmp :z INLINE-FIXNUM-COMPARE)
 179
 180                 TAIL-CALL-TO-STATIC-FN
 181                 (inst pop eax)
 182                 (inst push rbp-tn)
 183                 (inst lea rbp-tn (make-ea :qword
 184                                           :base rsp-tn
 185                                           :disp n-word-bytes))
 186                 (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack,
 187                                                 ; weirdly?
 188                 (inst push eax)
 189                 (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and
 190                                         ; SINGLE-FLOAT-BITS are parallel,
 191                                         ; should be named parallelly.
 192                 (inst jmp (make-ea :qword
 193                                    :disp (+ nil-value
 194                                             (static-fun-offset ',static-fn))))
 195
 196                 INLINE-FIXNUM-COMPARE
 197                 (inst cmp x y)
 198                 (inst mov res nil-value)
 199                 (inst jmp ,test RETURN-FALSE)
 200                 RETURN-TRUE
 201                 (load-symbol res t)
 202                 RETURN-FALSE
 203                 DONE)))
 204
 205   (define-cond-assem-rtn generic-< < two-arg-< :ge)
 206   (define-cond-assem-rtn generic-> > two-arg-> :le))
 207
 208 (define-assembly-routine (generic-eql
 209                           (:cost 10)
 210                           (:return-style :full-call)
 211                           (:policy :safe)
 212                           (:translate eql)
 213                           (:save-p t))
 214                          ((:arg x (descriptor-reg any-reg) rdx-offset)
 215                           (:arg y (descriptor-reg any-reg) rdi-offset)
 216
 217                           (:res res descriptor-reg rdx-offset)
 218
 219                           (:temp eax unsigned-reg rax-offset)
 220                           (:temp ecx unsigned-reg rcx-offset))
 221   (inst cmp x y)
 222   (inst jmp :e RETURN-T)
 223   (inst test x 7)
 224   (inst jmp :z RETURN-NIL)
 225   (inst test y 7)
 226   (inst jmp :nz DO-STATIC-FN)
 227
 228   RETURN-NIL
 229   (inst mov res nil-value)
 230   (inst jmp DONE)
 231
 232   DO-STATIC-FN
 233   (inst pop eax)
 234   (inst push rbp-tn)
 235   (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
 236   (inst sub rsp-tn (fixnumize 2))
 237   (inst push eax)
 238   (inst mov ecx (fixnumize 2))
 239   (inst jmp (make-ea :qword
 240                      :disp (+ nil-value (static-fun-offset 'eql))))
 241
 242   RETURN-T
 243   (load-symbol res t)
 244   DONE)
 245
 246 (define-assembly-routine (generic-=
 247                           (:cost 10)
 248                           (:return-style :full-call)
 249                           (:policy :safe)
 250                           (:translate =)
 251                           (:save-p t))
 252                          ((:arg x (descriptor-reg any-reg) rdx-offset)
 253                           (:arg y (descriptor-reg any-reg) rdi-offset)
 254
 255                           (:res res descriptor-reg rdx-offset)
 256
 257                           (:temp eax unsigned-reg rax-offset)
 258                           (:temp ecx unsigned-reg rcx-offset)
 259                           )
 260   (inst test x 7)                      ; descriptor?
 261   (inst jmp :nz DO-STATIC-FN)          ; yes, do it here
 262   (inst test y 7)                      ; descriptor?
 263   (inst jmp :nz DO-STATIC-FN)
 264   (inst cmp x y)
 265   (inst jmp :e RETURN-T)                ; ok
 266
 267   (inst mov res nil-value)
 268   (inst jmp DONE)
 269
 270   DO-STATIC-FN
 271   (inst pop eax)
 272   (inst push rbp-tn)
 273   (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
 274   (inst sub rsp-tn (fixnumize 2))
 275   (inst push eax)
 276   (inst mov ecx (fixnumize 2))
 277   (inst jmp (make-ea :qword
 278                      :disp (+ nil-value (static-fun-offset 'two-arg-=))))
 279
 280   RETURN-T
 281   (load-symbol res t)
 282   DONE)
 283
 284