mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
0077dde930
Some checks are pending
CL-host / ecl (push) Waiting to run
CL-host / clisp (push) Waiting to run
CL-host / ccl (push) Waiting to run
CL-host / cmucl (push) Waiting to run
CL-host / sbcl (push) Waiting to run
CL-host / compare-xc-host-fasls (ccl, false) (push) Blocked by required conditions
CL-host / compare-xc-host-fasls (clisp, false) (push) Blocked by required conditions
CL-host / compare-xc-host-fasls (cmucl, false) (push) Blocked by required conditions
CL-host / compare-xc-host-fasls (self, false) (push) Blocked by required conditions
Linux arm / build (push) Waiting to run
Linux arm64 / build () (push) Waiting to run
Linux qemu / build (ppc64le) (push) Waiting to run
Linux qemu / build (riscv64) (push) Waiting to run
Linux / build (x86, --with-sb-thread, ) (push) Waiting to run
Linux / build (x86, --without-sb-thread, ) (push) Waiting to run
Linux / build (x86, --without-sb-unicode, ) (push) Waiting to run
Linux / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call) (push) Waiting to run
Linux / build (x86-64, --with-sb-fasteval --without-sb-eval --with-nonstop-foreign-call, fasteval) (push) Waiting to run
Linux / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return, sse4) (push) Waiting to run
Linux / build (x86-64, --with-sb-thread, ) (push) Waiting to run
Linux / build (x86-64, --without-sb-thread, ) (push) Waiting to run
Linux / build (x86-64, --without-sb-unicode, ) (push) Waiting to run
Mac / build (arm64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (arm64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (x86-64, --with-mark-region-gc --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Mac / build (x86-64, --with-sb-thread --with-nonstop-foreign-call --with-tls-based-mv-return) (push) Waiting to run
Windows arm64 / build (arm64, clang-aarch64, clangarm64) (push) Waiting to run
Windows / build (x86-64, ucrt-x86_64, ucrt64) (push) Waiting to run
Do not cons positive bignums at the start of the loop, the result can be adjusted in place by subtraction at the end. On arm64 and x86-64, write the whole loop in assembly, not just the first iteration.
396 lines
16 KiB
Common Lisp
396 lines
16 KiB
Common Lisp
;;;; X86-64-specific runtime stuff
|
||
|
||
;;;; This software is part of the SBCL system. See the README file for
|
||
;;;; more information.
|
||
;;;;
|
||
;;;; This software is derived from the CMU CL system, which was
|
||
;;;; written at Carnegie Mellon University and released into the
|
||
;;;; public domain. The software is in the public domain and is
|
||
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
|
||
;;;; files for more information.
|
||
|
||
(in-package "SB-VM")
|
||
(defun machine-type ()
|
||
"Return a string describing the type of the local machine."
|
||
"X86-64")
|
||
|
||
(defun return-machine-address (context)
|
||
(let ((sp (context-register context sb-vm::rsp-offset)))
|
||
(sap-ref-word (int-sap sp) return-pc-save-offset)))
|
||
|
||
#+(or darwin linux openbsd win32 sunos (and freebsd x86-64))
|
||
(define-alien-routine ("os_context_float_register_addr" context-float-register-addr)
|
||
(* unsigned) (context (* os-context-t)) (index int))
|
||
|
||
#+linux
|
||
(progn
|
||
(define-alien-routine ("os_context_ymm_register_addr" context-ymm-register-addr)
|
||
(* unsigned) (context (* os-context-t)) (index int))
|
||
|
||
(define-alien-routine ("os_context_zmm_register_addr" context-zmm-register-addr)
|
||
(* unsigned) (context (* os-context-t)) (index int)))
|
||
|
||
;;; This is like CONTEXT-REGISTER, but returns the value of a float
|
||
;;; register. FORMAT is the type of float to return.
|
||
|
||
(defun context-float-register (context index format &optional integer)
|
||
(declare (ignorable context index integer))
|
||
#-(or darwin linux openbsd win32 sunos (and freebsd x86-64))
|
||
(progn
|
||
(warn "stub CONTEXT-FLOAT-REGISTER")
|
||
(coerce 0 format))
|
||
#+(or darwin linux openbsd win32 sunos (and freebsd x86-64))
|
||
(let ((sap (alien-sap (context-float-register-addr context index))))
|
||
(ecase format
|
||
(single-float
|
||
(if integer
|
||
(values (sap-ref-32 sap 0) 4)
|
||
(sap-ref-single sap 0)))
|
||
(double-float
|
||
(if integer
|
||
(values (sap-ref-64 sap 0) 8)
|
||
(sap-ref-double sap 0)))
|
||
(complex-single-float
|
||
(complex (sap-ref-single sap 0)
|
||
(sap-ref-single sap 4)))
|
||
(complex-double-float
|
||
(if integer
|
||
(values (dpb (sap-ref-64 sap 8)
|
||
(byte 64 64)
|
||
(sap-ref-64 sap 0))
|
||
16)
|
||
(complex (sap-ref-double sap 0)
|
||
(sap-ref-double sap 8))))
|
||
#+sb-simd-pack
|
||
(simd-pack-int
|
||
(if integer
|
||
(values (dpb (sap-ref-64 sap 8)
|
||
(byte 64 64)
|
||
(sap-ref-64 sap 0))
|
||
16)
|
||
(sap-ref-128 sap 0)))
|
||
#+sb-simd-pack
|
||
(simd-pack-single
|
||
(%simd-pack-int-to-single (sap-ref-128 sap 0)))
|
||
#+sb-simd-pack
|
||
(simd-pack-double
|
||
(%simd-pack-int-to-double (sap-ref-128 sap 0)))
|
||
#+sb-simd-pack-256
|
||
((simd-pack-256-int simd-pack-256-single simd-pack-256-double)
|
||
(let ((saph #+linux (alien-sap (context-ymm-register-addr context index))
|
||
#-linux sap)) ;; Unimplemented
|
||
(if integer
|
||
(values (dpb (dpb (sap-ref-64 saph 8)
|
||
(byte 64 64)
|
||
(sap-ref-64 saph 0))
|
||
(byte 128 128)
|
||
(dpb (sap-ref-64 sap 8)
|
||
(byte 64 64)
|
||
(sap-ref-64 sap 0)))
|
||
32)
|
||
(let ((pack (%make-simd-pack-256-ub64
|
||
(sap-ref-64 sap 0)
|
||
(sap-ref-64 sap 8)
|
||
(sap-ref-64 saph 0)
|
||
(sap-ref-64 saph 8))))
|
||
(case format
|
||
(simd-pack-256-single
|
||
(%simd-pack-256-int-to-single pack))
|
||
(simd-pack-256-double
|
||
(%simd-pack-256-int-to-double pack))
|
||
(t pack))))))
|
||
;; fixme512: check if this is correct
|
||
#+sb-simd-pack-512
|
||
((simd-pack-512-int simd-pack-512-double simd-pack-512-single)
|
||
(let ((pack (if (< index 16)
|
||
;; ZMM0 - ZMM15
|
||
(let ((sapy #+linux (alien-sap (context-ymm-register-addr context index))
|
||
#-linux sap)
|
||
(sapz #+linux (alien-sap (context-zmm-register-addr context index))
|
||
#-linux sap))
|
||
(if integer
|
||
(values (logior (sap-ref-64 sap 0)
|
||
(ash (sap-ref-64 sap 8) 64)
|
||
(ash (sap-ref-64 sapy 0) 128)
|
||
(ash (sap-ref-64 sapy 8) 192)
|
||
(ash (sap-ref-64 sapz 0) 256)
|
||
(ash (sap-ref-64 sapz 8) 320)
|
||
(ash (sap-ref-64 sapz 16) 384)
|
||
(ash (sap-ref-64 sapz 24) 448))
|
||
64)
|
||
(%make-simd-pack-512-ub64
|
||
(sap-ref-64 sap 0)
|
||
(sap-ref-64 sap 8)
|
||
(sap-ref-64 sapy 0)
|
||
(sap-ref-64 sapy 8)
|
||
(sap-ref-64 sapz 0)
|
||
(sap-ref-64 sapz 8)
|
||
(sap-ref-64 sapz 16)
|
||
(sap-ref-64 sapz 24))))
|
||
;; ZMM16 - ZMM31
|
||
(let ((sapz #+linux (alien-sap (context-zmm-register-addr context index))
|
||
#-linux sap))
|
||
(if integer
|
||
(values (logior (sap-ref-64 sapz 0)
|
||
(ash (sap-ref-64 sapz 8) 64)
|
||
(ash (sap-ref-64 sapz 16) 128)
|
||
(ash (sap-ref-64 sapz 24) 192)
|
||
(ash (sap-ref-64 sapz 32) 256)
|
||
(ash (sap-ref-64 sapz 40) 320)
|
||
(ash (sap-ref-64 sapz 48) 384)
|
||
(ash (sap-ref-64 sapz 56) 448))
|
||
64)
|
||
(%make-simd-pack-512-ub64
|
||
(sap-ref-64 sapz 0)
|
||
(sap-ref-64 sapz 8)
|
||
(sap-ref-64 sapz 16)
|
||
(sap-ref-64 sapz 24)
|
||
(sap-ref-64 sapz 32)
|
||
(sap-ref-64 sapz 40)
|
||
(sap-ref-64 sapz 48)
|
||
(sap-ref-64 sapz 56)))))))
|
||
(case format
|
||
(simd-pack-512-single
|
||
(%simd-pack-512-int-to-single pack))
|
||
(simd-pack-512-double
|
||
(%simd-pack-512-int-to-double pack))
|
||
(t pack)))))))
|
||
|
||
(defun %set-context-float-register (context index format value)
|
||
(declare (ignorable context index format))
|
||
;; Don't make the whole thing use avx512 registers
|
||
#-(or linux win32)
|
||
(progn
|
||
(warn "stub %SET-CONTEXT-FLOAT-REGISTER")
|
||
value)
|
||
#+(or linux win32)
|
||
(let ((sap (alien-sap (context-float-register-addr context index))))
|
||
(ecase format
|
||
(single-float
|
||
(setf (sap-ref-single sap 0) value))
|
||
(double-float
|
||
(setf (sap-ref-double sap 0) value))
|
||
(complex-single-float
|
||
(locally
|
||
(declare (type (complex single-float) value))
|
||
(setf (sap-ref-single sap 0) (realpart value)
|
||
(sap-ref-single sap 4) (imagpart value))))
|
||
(complex-double-float
|
||
(locally
|
||
(declare (type (complex double-float) value))
|
||
(setf (sap-ref-double sap 0) (realpart value)
|
||
(sap-ref-double sap 8) (imagpart value))))
|
||
#+sb-simd-pack
|
||
(simd-pack
|
||
(setf (sap-ref-64 sap 0) (%simd-pack-ref-64 value 0)
|
||
(sap-ref-64 sap 8) (%simd-pack-ref-64 value 1)))
|
||
;; FIXME: Wrong offsets
|
||
;; #+sb-simd-pack-256
|
||
;; (simd-pack-256
|
||
;; (setf (sap-ref-64 sap 0) (%simd-pack-ref-64 value 0)
|
||
;; (sap-ref-64 sap 8) (%simd-pack-ref-64 value 1)
|
||
;; (sap-ref-64 sap 16) (%simd-pack-ref-64 value 2)
|
||
;; (sap-ref-64 sap 24) (%simd-pack-ref-64 value 3)))
|
||
;; #+sb-simd-pack-512
|
||
;; (simd-pack-512
|
||
;; (setf (sap-ref-64 sap 0) (%simd-pack-ref-64 value 0)
|
||
;; (sap-ref-64 sap 8) (%simd-pack-ref-64 value 1)
|
||
;; (sap-ref-64 sap 16) (%simd-pack-ref-64 value 2)
|
||
;; (sap-ref-64 sap 24) (%simd-pack-ref-64 value 3)
|
||
;; (sap-ref-64 sap 32) (%simd-pack-ref-64 value 4)
|
||
;; (sap-ref-64 sap 40) (%simd-pack-ref-64 value 5)
|
||
;; (sap-ref-64 sap 48) (%simd-pack-ref-64 value 6)
|
||
;; (sap-ref-64 sap 56) (%simd-pack-ref-64 value 7)))
|
||
)))
|
||
|
||
;;; Given a signal context, return the floating point modes word in
|
||
;;; the same format as returned by FLOATING-POINT-MODES.
|
||
#-linux
|
||
(defun context-floating-point-modes (context)
|
||
(declare (ignore context)) ; stub!
|
||
(warn "stub CONTEXT-FLOATING-POINT-MODES")
|
||
0)
|
||
#+linux
|
||
(define-alien-routine ("os_context_fp_control" context-floating-point-modes)
|
||
(unsigned 32)
|
||
(context (* os-context-t)))
|
||
#+linux
|
||
(define-alien-routine ("os_context_set_fp_control" context-set-floating-point-modes) void
|
||
(context (* os-context-t))
|
||
(value (unsigned 32)))
|
||
|
||
(define-alien-routine
|
||
("arch_get_fp_modes" floating-point-modes) (unsigned 32))
|
||
|
||
(define-alien-routine
|
||
("arch_set_fp_modes" %floating-point-modes-setter) void (fp (unsigned 32)))
|
||
|
||
(defun (setf floating-point-modes) (val) (%floating-point-modes-setter val))
|
||
|
||
|
||
;;;; INTERNAL-ERROR-ARGS
|
||
|
||
;;; Given a (POSIX) signal context, extract the internal error
|
||
;;; arguments from the instruction stream.
|
||
(defun internal-error-args (context)
|
||
(declare (type (alien (* os-context-t)) context))
|
||
(let* ((pc (context-pc context))
|
||
(trap-number (sap-ref-8 pc 0)))
|
||
(declare (type system-area-pointer pc))
|
||
(cond ((= trap-number invalid-arg-count-trap)
|
||
(values #.(error-number-or-lose 'invalid-arg-count-error)
|
||
'(#.arg-count-sc)))
|
||
#+linux
|
||
((= trap-number uninitialized-load-trap)
|
||
(values #.(error-number-or-lose 'uninitialized-memory-error)
|
||
(locally
|
||
(declare (optimize (safety 0)))
|
||
(let* ((data (sap-ref-8 pc 1)) ; encodes dst register and size
|
||
(value (sb-vm:context-register context (ash data -2)))
|
||
(nbytes (ash 1 (logand data #b11)))
|
||
;; EMIT-SAP-REF wires the EA to a predetermined register,
|
||
;; which now points to the shadow space, not the user memory.
|
||
(ea (logxor (sb-vm:context-register context msan-temp-reg-number)
|
||
msan-mem-to-shadow-xor-const)))
|
||
`(:raw ,ea ,nbytes ,value)))))
|
||
(t
|
||
(sb-kernel::decode-internal-error-args (sap+ pc 1) trap-number)))))
|
||
|
||
|
||
(defun write-funinstance-prologue (fin)
|
||
;; Encode: MOV RAX,[RIP+9] / JMP [RAX-3] / NOP / MOV EBX, #x0
|
||
;; and the #x0 is replaced with a hash code.
|
||
(with-pinned-objects (fin)
|
||
(let* ((sap (sap+ (int-sap (get-lisp-obj-address fin))
|
||
(- (ash 2 word-shift) fun-pointer-lowtag))))
|
||
;; Scavenging these words when you shouldn't is actually harmless
|
||
;; because by a stroke of luck, they all look fixnum-tagged.
|
||
(setf (sap-ref-sap sap -8) sap
|
||
(sap-ref-word sap 0) #xFF00000009058B48
|
||
(sap-ref-word sap 8) #x00000000BB90FD60)))
|
||
(update-dynamic-space-code-tree fin)
|
||
fin)
|
||
|
||
(sb-kernel:!defstruct-with-alternate-metaclass closure-trampoline
|
||
:slot-names ()
|
||
:constructor %alloc-closure-trampoline
|
||
:superclass-name function
|
||
:metaclass-name static-classoid
|
||
:metaclass-constructor make-static-classoid
|
||
:dd-type funcallable-structure)
|
||
|
||
(defmethod print-object ((self closure-trampoline) stream)
|
||
(print-unreadable-object (self stream :identity t)
|
||
(let ((payload (%primitive slot self 'function
|
||
funcallable-instance-function-slot fun-pointer-lowtag)))
|
||
(write-string (if (functionp payload) "Tramp " "Undefined-fun ") stream)
|
||
(prin1 payload stream))))
|
||
|
||
(defun ensure-simplistic (function name)
|
||
(when (and (functionp function) (not (closurep function)))
|
||
(return-from ensure-simplistic function))
|
||
(let ((tramp (%alloc-closure-trampoline)))
|
||
(with-pinned-objects (tramp)
|
||
(if (or (eql function 0) (null function))
|
||
(let* ((asm-code (sb-fasl::get-asm-routine 'undefined-tramp))
|
||
(base (sap+ (int-sap (get-lisp-obj-address tramp)) (- fun-pointer-lowtag)))
|
||
(sap (sap+ base 23)))
|
||
(setf (sap-ref-32 sap 0) #x24A4FF41 ; JMP [R12+disp]
|
||
(signed-sap-ref-32 sap 4) (asm-routine-indirect-address asm-code)
|
||
(sap-ref-32 sap 8) #x90
|
||
;; The undefined function name is stored in the "function" slot.
|
||
;; The slot setter doesn't like this of course.
|
||
(sap-ref-lispobj base (ash funcallable-instance-function-slot word-shift))
|
||
name))
|
||
(setf (%funcallable-instance-fun tramp) function)))
|
||
tramp))
|
||
|
||
(defun stepper-fun (closure) (ensure-simplistic closure nil))
|
||
|
||
;;; Undo the effects of XEP-ALLOCATE-FRAME
|
||
;;; and point PC to FUNCTION
|
||
(defun context-call-function (context function &optional arg-count)
|
||
(with-pinned-objects (function)
|
||
(let ((rsp (decf (context-register context rsp-offset) n-word-bytes))
|
||
(rbp (context-register context rbp-offset))
|
||
(fun-addr (get-lisp-obj-address function)))
|
||
(setf (sap-ref-word (int-sap rsp) 0)
|
||
(sap-ref-word (int-sap rbp) 8))
|
||
(when arg-count
|
||
(setf (context-register context rcx-offset)
|
||
(get-lisp-obj-address arg-count)))
|
||
(setf (context-register context rax-offset) fun-addr)
|
||
(set-context-pc context (sap-ref-word (int-sap fun-addr)
|
||
(- (ash simple-fun-self-slot word-shift)
|
||
fun-pointer-lowtag))))))
|
||
|
||
(defconstant cf-bit 0)
|
||
(defconstant sf-bit 7)
|
||
(defconstant of-bit 11)
|
||
|
||
(defun context-overflow-carry-flags (context)
|
||
(let ((flags (context-flags context)))
|
||
(values (logbitp of-bit flags)
|
||
(logbitp cf-bit flags))))
|
||
|
||
(def-cpu-feature :avx2
|
||
(plusp (sb-alien:extern-alien "avx2_supported" int)))
|
||
|
||
(def-cpu-feature :ssse3+popcnt
|
||
(when (>= (sb-vm::%cpu-identification 0 0) 1)
|
||
(multiple-value-bind (eax ebx ecx) (sb-vm::%cpu-identification 1 0)
|
||
(declare (ignore eax ebx))
|
||
(= (logand #1=(logior (ash 1 9) ;; ssse3
|
||
(ash 1 23)) ;; popcnt
|
||
ecx)
|
||
#1#))))
|
||
|
||
(def-cpu-feature :bmi2
|
||
(multiple-value-bind (eax ebx) (sb-vm::%cpu-identification 7 0)
|
||
(declare (ignore eax))
|
||
(logtest ebx #x100)))
|
||
|
||
(in-package :sb-bignum)
|
||
|
||
#+x86-64
|
||
(sb-vm::def-variant multiply-bignum-and-fixnum :bmi2 (bignum fixnum)
|
||
(declare (type bignum bignum) (type fixnum fixnum)
|
||
(optimize speed (safety 0)))
|
||
(cond ((eql fixnum 1)
|
||
bignum)
|
||
((eql fixnum -1)
|
||
(- bignum))
|
||
(t
|
||
(let* ((bignum-len (%bignum-length bignum))
|
||
(abs-fixnum (abs fixnum))
|
||
(result (%allocate-bignum (1+ bignum-len))))
|
||
(declare (type bignum bignum result)
|
||
(type bignum-element-type abs-fixnum))
|
||
(sb-sys:%primitive sb-vm::bignum-mulx-and-add-word-loop bignum abs-fixnum bignum-len result)
|
||
(unless (bignum-plus-p bignum)
|
||
(setf (%bignum-ref result bignum-len)
|
||
(logand (- (%bignum-ref result bignum-len) abs-fixnum)
|
||
most-positive-word)))
|
||
(when (minusp fixnum)
|
||
(negate-bignum-in-place result))
|
||
(%normalize-bignum result (1+ bignum-len))))))
|
||
|
||
(sb-vm::def-variant multiply-bignums :bmi2 (a b)
|
||
(declare (type bignum a b)
|
||
(optimize speed (safety 0)))
|
||
(let* ((len-a (%bignum-length a))
|
||
(len-b (%bignum-length b))
|
||
(res (%allocate-bignum (+ len-a len-b))))
|
||
(when (> len-a len-b)
|
||
(rotatef a b)
|
||
(rotatef len-a len-b))
|
||
|
||
(sb-sys:%primitive sb-vm::bignum-mulx-multiply-loop a len-a b len-b res)
|
||
(unless (bignum-plus-p a)
|
||
(%subtract-bignum-in-place res b len-a len-b))
|
||
(unless (bignum-plus-p b)
|
||
(%subtract-bignum-in-place res a len-b len-a))
|
||
(%normalize-bignum res (+ len-a len-b))))
|
||
|
||
(in-package :sb-vm)
|