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 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) edx-offset) 24 (:arg y (descriptor-reg any-reg) edi-offset) 25 26 (:res res (descriptor-reg any-reg) edx-offset) 27 28 (:temp eax unsigned-reg eax-offset) 29 (:temp ecx unsigned-reg ecx-offset)) 30 31 (inst mov ecx x) 32 (inst or ecx y) 33 (inst test ecx 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 (fixnumize 1)) 42 (inst push ebp-tn) 43 (inst mov ebp-tn esp-tn) 44 (inst sub esp-tn (fixnumize 1)) 45 (inst push (make-ea :dword :base ebp-tn 46 :disp (frame-byte-offset return-pc-save-offset))) 47 (inst mov ecx (fixnumize 2)) ; arg count 48 (inst jmp 49 (make-ea :dword 50 :disp (+ nil-value 51 (static-fun-offset 52 ',(symbolicate "TWO-ARG-" fun)))))))) 53 54 (define-generic-arith-routine (+ 10) 55 (move res x) 56 (inst add res y) 57 (inst jmp :no OKAY) 58 (inst rcr res 1) ; carry has correct sign 59 (inst sar res 1) ; remove type bits 60 61 (move ecx res) 62 63 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) 64 (storew ecx res bignum-digits-offset other-pointer-lowtag)) 65 66 OKAY) 67 68 (define-generic-arith-routine (- 10) 69 (move res x) 70 (inst sub res y) 71 (inst jmp :no OKAY) 72 (inst cmc) ; carry has correct sign now 73 (inst rcr res 1) 74 (inst sar res 1) ; remove type bits 75 76 (move ecx res) 77 78 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) 79 (storew ecx res bignum-digits-offset other-pointer-lowtag)) 80 OKAY) 81 82 (define-generic-arith-routine (* 30) 83 (move eax x) ; must use eax for 64-bit result 84 (inst sar eax n-fixnum-tag-bits) ; remove *4 fixnum bias 85 (inst imul y) ; result in edx:eax 86 (inst jmp :no OKAY) ; still fixnum 87 88 ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above 89 ;; pfw says that loses big -- edx is target for arg x and result res 90 ;; note that 'edx' is not defined -- using x 91 (inst shrd eax x n-fixnum-tag-bits) ; high bits from edx 92 (inst sar x n-fixnum-tag-bits) ; now shift edx too 93 94 (move ecx x) ; save high bits from cdq 95 (inst cdq) ; edx:eax <- sign-extend of eax 96 (inst cmp x ecx) 97 (inst jmp :e SINGLE-WORD-BIGNUM) 98 99 (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2)) 100 (storew eax res bignum-digits-offset other-pointer-lowtag) 101 (storew ecx 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 eax res bignum-digits-offset other-pointer-lowtag)) 108 (inst jmp DONE) 109 110 OKAY 111 (move res eax) 112 DONE)) 113 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) edx-offset) 123 (:res res (descriptor-reg any-reg) edx-offset) 124 (:temp ecx unsigned-reg ecx-offset)) 125 (inst test x fixnum-tag-mask) 126 (inst jmp :z FIXNUM) 127 128 (inst push ebp-tn) 129 (inst mov ebp-tn esp-tn) 130 (inst sub esp-tn (fixnumize 1)) 131 (inst push (make-ea :dword :base ebp-tn 132 :disp (frame-byte-offset return-pc-save-offset))) 133 (inst mov ecx (fixnumize 1)) ; arg count 134 (inst jmp (make-ea :dword 135 :disp (+ nil-value (static-fun-offset '%negate)))) 136 137 FIXNUM 138 (move res x) 139 (inst neg res) ; (- most-negative-fixnum) is BIGNUM 140 (inst jmp :no OKAY) 141 (inst shr res n-fixnum-tag-bits) ; sign bit is data - remove type bits 142 (move ecx res) 143 144 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset)) 145 (storew ecx res bignum-digits-offset other-pointer-lowtag)) 146 147 OKAY) 148 149;;;; comparison 150 151(macrolet ((define-cond-assem-rtn (name translate static-fn test) 152 `(define-assembly-routine (,name 153 (:translate ,translate) 154 (:policy :safe) 155 (:save-p t) 156 (:conditional ,test) 157 (:cost 10)) 158 ((:arg x (descriptor-reg any-reg) edx-offset) 159 (:arg y (descriptor-reg any-reg) edi-offset) 160 161 (:temp ecx unsigned-reg ecx-offset)) 162 163 (inst mov ecx x) 164 (inst or ecx y) 165 (inst test ecx fixnum-tag-mask) 166 (inst jmp :nz DO-STATIC-FUN) ; are both fixnums? 167 168 (inst cmp x y) 169 (inst ret) 170 171 DO-STATIC-FUN 172 (inst push ebp-tn) 173 (inst mov ebp-tn esp-tn) 174 (inst sub esp-tn (fixnumize 3)) 175 (inst mov (make-ea :dword :base esp-tn 176 :disp (frame-byte-offset 177 (+ sp->fp-offset 178 -3 179 ocfp-save-offset))) 180 ebp-tn) 181 (inst lea ebp-tn (make-ea :dword :base esp-tn 182 :disp (frame-byte-offset 183 (+ sp->fp-offset 184 -3 185 ocfp-save-offset)))) 186 (inst mov ecx (fixnumize 2)) 187 (inst call (make-ea :dword 188 :disp (+ nil-value 189 (static-fun-offset ',static-fn)))) 190 ;; HACK: We depend on NIL having the lowest address of all 191 ;; static symbols (including T) 192 ,@(ecase test 193 (:l `((inst mov y (1+ nil-value)) 194 (inst cmp y x))) 195 (:g `((inst cmp x (1+ nil-value))))) 196 (inst pop ebp-tn)))) 197 (define-cond-assem-rtn generic-< < two-arg-< :l) 198 (define-cond-assem-rtn generic-> > two-arg-> :g)) 199 200(define-assembly-routine (generic-eql 201 (:translate eql) 202 (:policy :safe) 203 (:save-p t) 204 (:conditional :e) 205 (:cost 10)) 206 ((:arg x (descriptor-reg any-reg) edx-offset) 207 (:arg y (descriptor-reg any-reg) edi-offset) 208 209 (:temp ecx unsigned-reg ecx-offset)) 210 (inst mov ecx x) 211 (inst and ecx y) 212 (inst and ecx lowtag-mask) 213 (inst cmp ecx other-pointer-lowtag) 214 (inst jmp :e DO-STATIC-FUN) 215 216 ;; At least one fixnum 217 (inst cmp x y) 218 RET 219 (inst ret) 220 221 DO-STATIC-FUN 222 ;; Might as well fast path that... 223 (inst cmp x y) 224 (inst jmp :e RET) 225 226 (inst push ebp-tn) 227 (inst mov ebp-tn esp-tn) 228 (inst sub esp-tn (fixnumize 3)) 229 (inst mov (make-ea :dword :base esp-tn 230 :disp (frame-byte-offset 231 (+ sp->fp-offset 232 -3 233 ocfp-save-offset))) 234 ebp-tn) 235 (inst lea ebp-tn (make-ea :dword :base esp-tn 236 :disp (frame-byte-offset 237 (+ sp->fp-offset 238 -3 239 ocfp-save-offset)))) 240 (inst mov ecx (fixnumize 2)) 241 (inst call (make-ea :dword 242 :disp (+ nil-value (static-fun-offset 'eql)))) 243 (load-symbol y t) 244 (inst cmp x y) 245 (inst pop ebp-tn)) 246 247(define-assembly-routine (generic-= 248 (:translate =) 249 (:policy :safe) 250 (:save-p t) 251 (:conditional :e) 252 (:cost 10)) 253 ((:arg x (descriptor-reg any-reg) edx-offset) 254 (:arg y (descriptor-reg any-reg) edi-offset) 255 256 (:temp ecx unsigned-reg ecx-offset)) 257 (inst mov ecx x) 258 (inst or ecx y) 259 (inst test ecx fixnum-tag-mask) 260 (inst jmp :nz DO-STATIC-FUN) 261 262 ;; Both fixnums 263 (inst cmp x y) 264 (inst ret) 265 266 DO-STATIC-FUN 267 (inst push ebp-tn) 268 (inst mov ebp-tn esp-tn) 269 (inst sub esp-tn (fixnumize 3)) 270 (inst mov (make-ea :dword :base esp-tn 271 :disp (frame-byte-offset 272 (+ sp->fp-offset 273 -3 274 ocfp-save-offset))) 275 ebp-tn) 276 (inst lea ebp-tn (make-ea :dword :base esp-tn 277 :disp (frame-byte-offset 278 (+ sp->fp-offset 279 -3 280 ocfp-save-offset)))) 281 (inst mov ecx (fixnumize 2)) 282 (inst call (make-ea :dword 283 :disp (+ nil-value (static-fun-offset 'two-arg-=)))) 284 (load-symbol y t) 285 (inst cmp x y) 286 (inst pop ebp-tn)) 287 288 289;;; Support for the Mersenne Twister, MT19937, random number generator 290;;; due to Matsumoto and Nishimura. 291;;; 292;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A 293;;; 623-dimensionally equidistributed uniform pseudorandom number 294;;; generator.", ACM Transactions on Modeling and Computer Simulation, 295;;; 1997, to appear. 296;;; 297;;; State: 298;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here) 299;;; 2: Index; init. to 1. 300;;; 3-626: State. 301 302;;; This assembly routine is called from the inline VOP and updates 303;;; the state vector with new random numbers. The state vector is 304;;; passed in the EAX register. 305#+sb-assembling ; We don't want a vop for this one. 306(define-assembly-routine 307 (random-mt19937-update) 308 ((:temp state unsigned-reg eax-offset) 309 (:temp k unsigned-reg ebx-offset) 310 (:temp y unsigned-reg ecx-offset) 311 (:temp tmp unsigned-reg edx-offset)) 312 313 ;; Save the temporary registers. 314 (inst push k) 315 (inst push y) 316 (inst push tmp) 317 318 ;; Generate a new set of results. 319 (inst xor k k) 320 LOOP1 321 (inst mov y (make-ea-for-vector-data state :index k :offset 3)) 322 (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3))) 323 (inst and y #x80000000) 324 (inst and tmp #x7fffffff) 325 (inst or y tmp) 326 (inst shr y 1) 327 (inst jmp :nc skip1) 328 (inst xor y #x9908b0df) 329 SKIP1 330 (inst xor y (make-ea-for-vector-data state :index k :offset (+ 397 3))) 331 (inst mov (make-ea-for-vector-data state :index k :offset 3) y) 332 (inst inc k) 333 (inst cmp k (- 624 397)) 334 (inst jmp :b loop1) 335 LOOP2 336 (inst mov y (make-ea-for-vector-data state :index k :offset 3)) 337 (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3))) 338 (inst and y #x80000000) 339 (inst and tmp #x7fffffff) 340 (inst or y tmp) 341 (inst shr y 1) 342 (inst jmp :nc skip2) 343 (inst xor y #x9908b0df) 344 SKIP2 345 (inst xor y (make-ea-for-vector-data state :index k :offset (+ (- 397 624) 3))) 346 (inst mov (make-ea-for-vector-data state :index k :offset 3) y) 347 (inst inc k) 348 (inst cmp k (- 624 1)) 349 (inst jmp :b loop2) 350 351 (inst mov y (make-ea-for-vector-data state :offset (+ (- 624 1) 3))) 352 (inst mov tmp (make-ea-for-vector-data state :offset (+ 0 3))) 353 (inst and y #x80000000) 354 (inst and tmp #x7fffffff) 355 (inst or y tmp) 356 (inst shr y 1) 357 (inst jmp :nc skip3) 358 (inst xor y #x9908b0df) 359 SKIP3 360 (inst xor y (make-ea-for-vector-data state :offset (+ (- 397 1) 3))) 361 (inst mov (make-ea-for-vector-data state :offset (+ (- 624 1) 3)) y) 362 363 ;; Restore the temporary registers and return. 364 (inst pop tmp) 365 (inst pop y) 366 (inst pop k)) 367