common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

x86-64: Allow static spaces in +4GB space.

Browse source 
Still a bit buggy; GC invariant lost in some tests and I haven't
tracked down a pointer truncation yet.

Only builds without compact instance header, immobile code, and
immobile space.
This commit is contained in:
Charles Zhang 2021-10-19 10:40:17 -07:00
parent 97868b15d4
commit 711698b4ee
15 changed files with 113 additions and 86 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/assembly/x86-64/arith.lisp
View file

@ -192,7 +192,7 @@
,@(ecase test
(:l `((inst mov y (1+ nil-value))
(inst cmp y x)))
(:g `((inst cmp x (1+ nil-value))))))))
(:g `((inst cmp x (constantize (1+ nil-value)))))))))
(define-cond-assem-rtn generic-< < two-arg-< :l)
(define-cond-assem-rtn generic-> > two-arg-> :g))
@ -215,7 +215,7 @@
DO-STATIC-FUN
(call-static-fun 'two-arg-= 2)
(inst cmp x (+ nil-value (static-symbol-offset t))))
(inst cmp x (constantize (+ nil-value (static-symbol-offset t)))))
#+sb-assembling
(define-assembly-routine (logcount)

6
src/assembly/x86-64/assem-rtns.lisp
View file

@ -386,11 +386,13 @@
(defun ensure-thread-base-tn-loaded ()
#-sb-thread
(progn
;; Load THREAD-BASE-TN from the all_threads. Does not need to be spilled
;; Load THREAD-TN from the all_threads. Does not need to be spilled
;; to stack, because we do do not give the register allocator access to it.
;; And call_into_lisp saves it as per convention, not that it matters,
;; because there's no way to get back into C code anyhow.
(inst mov thread-tn (ea (make-fixup "all_threads" :foreign-dataref)))
(inst mov thread-tn (make-fixup "all_threads" :foreign-dataref))
(inst mov thread-tn (ea thread-tn))
(inst mov thread-tn (ea thread-tn))))
;;; Perform a store to code, updating the GC page (card) protection bits.

4
src/assembly/x86-64/support.lisp
View file

@ -21,7 +21,7 @@
;; emitting code into :ELSEWHERE when requesting a unique label.
(assemble (:indirections)
(emit-label label)
(inst jmp (ea (make-fixup name :assembly-routine*))))
(inst jmp (ea (make-fixup name :asm-routine-nil-offset*) null-tn)))
(push (cons name label) (sb-assem::asmstream-indirection-table asmstream))
label)))
@ -33,7 +33,7 @@
(uniquify
(uniquify-fixup routine))
(t
(ea (make-fixup routine :assembly-routine*))))))
(ea (make-fixup routine :asm-routine-nil-offset*) null-tn)))))
(ecase inst
(jmp (inst jmp fixup))
(call (inst call fixup)))))

4
src/compiler/dump.lisp
View file

@ -1016,7 +1016,7 @@
(assert (<= (length +fixup-kinds+) 8))) ; fixup-kind fits in 3 bits
(defconstant-eqx +fixup-flavors+
#(:assembly-routine :assembly-routine* :asm-routine-nil-offset
#(:assembly-routine :assembly-routine* :asm-routine-nil-offset :asm-routine-nil-offset*
:symbol-tls-index
:foreign :foreign-dataref :code-object
:layout :immobile-symbol :named-call :static-call
@ -1070,7 +1070,7 @@
(t name)))))
(:layout-id
(the wrapper name))
((:assembly-routine :assembly-routine* :asm-routine-nil-offset
((:assembly-routine :assembly-routine* :asm-routine-nil-offset :asm-routine-nil-offset*
:symbol-tls-index
;; Only #+immobile-space can use the following two flavors.
;; An :IMMOBILE-SYMBOL fixup references the symbol itself,

2
src/compiler/generic/genesis.lisp
View file

@ -2747,6 +2747,8 @@ Legal values for OFFSET are -4, -8, -12, ..."
(:assembly-routine* (lookup-assembler-reference sym :indirect))
(:asm-routine-nil-offset
(- (lookup-assembler-reference sym) sb-vm:nil-value))
(:asm-routine-nil-offset*
(- (lookup-assembler-reference sym :indirect) sb-vm:nil-value))
(:foreign
(linkage-table-note-symbol (base-string-from-core sym) nil))
(:foreign-dataref

8
src/compiler/generic/target-core.lisp
View file

@ -82,10 +82,12 @@
(when (sb-vm:fixup-code-object
code-obj offset
(ecase flavor
((:assembly-routine :assembly-routine* :asm-routine-nil-offset)
(- (or (get-asm-routine sym (eq flavor :assembly-routine*))
((:assembly-routine :assembly-routine* :asm-routine-nil-offset :asm-routine-nil-offset*)
(- (or (get-asm-routine sym (member flavor '(:assembly-routine* :asm-routine-nil-offset*)))
(error "undefined assembler routine: ~S" sym))
(if (eq flavor :asm-routine-nil-offset) sb-vm:nil-value 0)))
(if (member flavor '(:asm-routine-nil-offset :asm-routine-nil-offset*))
sb-vm:nil-value
0)))
(:foreign (foreign-symbol-address sym))
(:foreign-dataref (foreign-symbol-address sym t))
(:code-object (get-lisp-obj-address code-obj))

7
src/compiler/x86-64/alloc.lisp
View file

@ -168,7 +168,7 @@
;; This jump is always encoded as 5 bytes
(inst call (if (or (not node) ; assembly routine
(sb-c::code-immobile-p node))
(make-fixup helper :assembly-routine)
(ea (make-fixup helper :asm-routine-nil-offset*) null-tn)
(uniquify-fixup helper))))
(inst nop)
;; Emit "TEST AL, imm" where the immediate value
@ -731,6 +731,7 @@
(:policy :fast-safe)
(:translate make-fdefn)
(:args (name :scs (descriptor-reg) :to :eval))
(:temporary (:sc unsigned-reg) temp)
(:results (result :scs (descriptor-reg) :from :argument))
#+gs-seg (:temporary (:sc unsigned-reg :offset 15) thread-tn)
(:node-var node)
@ -738,8 +739,8 @@
(alloc-other fdefn-widetag fdefn-size result node nil thread-tn)
(storew name result fdefn-name-slot other-pointer-lowtag)
(storew null-tn result fdefn-fun-slot other-pointer-lowtag)
(storew (make-fixup 'undefined-tramp :assembly-routine)
result fdefn-raw-addr-slot other-pointer-lowtag)))
(inst mov temp (make-fixup 'undefined-tramp :assembly-routine))
(storew temp result fdefn-raw-addr-slot other-pointer-lowtag)))
(define-vop (make-closure)
; (:args (function :to :save :scs (descriptor-reg)))

8
src/compiler/x86-64/c-call.lisp
View file

@ -240,11 +240,13 @@
(:policy :fast-safe)
(:args)
(:arg-types (:constant simple-string))
(:temporary (:sc unsigned-reg) temp)
(:info foreign-symbol)
(:results (res :scs (sap-reg)))
(:result-types system-area-pointer)
(:generator 2
(inst mov res (ea (make-fixup foreign-symbol :foreign-dataref)))))
(inst mov temp (make-fixup foreign-symbol :foreign-dataref))
(inst mov res (ea temp))))
#+sb-safepoint
(defconstant thread-saved-csp-offset (- (1+ sb-vm::thread-header-slots)))
@ -369,7 +371,9 @@
#-win32
(inst call (cond ((tn-p fun) fun)
((sb-c::code-immobile-p vop) (make-fixup fun :foreign))
(t (ea (make-fixup fun :foreign 8)))))
(t (inst mov null-tn (make-fixup fun :foreign 8))
(ea null-tn))))
(inst mov null-tn nil-value)
;; On win64, we don't support immobile space (yet) and calls go through one of
;; the thunks defined in set_up_win64_seh_data(). If the linkage table is
;; involved, RBX either points to a linkage table trampoline or to the linkage

2
src/compiler/x86-64/call.lisp
View file

@ -882,7 +882,7 @@
(%lea-for-lowtag-test rbx-tn fun fun-pointer-lowtag)
(inst test :byte rbx-tn lowtag-mask)
(inst jmp :nz (if relative-call
(make-fixup 'call-symbol :assembly-routine)
(ea (make-fixup 'call-symbol :asm-routine-nil-offset*) null-tn)
not-fun))
(inst jmp fun-ea)
not-fun

5
src/compiler/x86-64/cell.lisp
View file

@ -491,6 +491,7 @@
(:policy :fast-safe)
(:translate fdefn-makunbound)
(:args (fdefn :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp)
(:vop-var vop)
(:generator 38
;; Change the JMP instruction to INT3 so that a trap occurs in the fdefn
@ -506,8 +507,8 @@
;; and resume at undefined-tramp. However, CALL-SYMBOL jumps via raw-addr if
;; its callable object was not a function. In that case RAX holds a symbol,
;; so we're OK because we can identify the undefined function.
(storew (make-fixup 'undefined-tramp :assembly-routine)
fdefn fdefn-raw-addr-slot other-pointer-lowtag)))
(inst mov temp (make-fixup 'undefined-tramp :assembly-routine))
(storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)))
;;;; binding and unbinding

130
src/compiler/x86-64/insts.lisp
View file

@ -1412,74 +1412,80 @@
(defun emit-mov (segment size dst src)
(cond ((gpr-p dst)
(cond ((integerp src)
;; We want to encode the immediate using the fewest bytes possible.
(let ((imm-size
;; If it's a :qword constant that fits in an unsigned
;; :dword, then use a zero-extended :dword immediate.
(if (and (eq size :qword) (typep src '(unsigned-byte 32)))
:dword
size)))
(emit-prefixes segment dst nil imm-size))
(acond ((neq size :qword) ; :dword or smaller dst is straightforward
(emit-byte+reg segment (if (eq size :byte) #xB0 #xB8) dst)
(emit-imm-operand segment src size))
;; This must be move to a :qword register.
((typep src '(unsigned-byte 32))
;; Encode as B8+dst using operand size of 32 bits
;; and implicit zero-extension.
;; Instruction size: 5 if no REX prefix, or 6 with.
(emit-byte+reg segment #xB8 dst)
(emit-dword segment src))
((plausible-signed-imm32-operand-p src)
;; It's either a signed-byte-32, or a large unsigned
;; value whose 33 high bits are all 1.
;; Encode as C7 which sign-extends a 32-bit imm to 64 bits.
;; Instruction size: 7 bytes.
(emit-byte segment #xC7)
(emit-mod-reg-r/m-byte segment #b11 #b000
(reg-encoding dst segment))
(emit-signed-dword segment it))
(t
;; 64-bit immediate. Instruction size: 10 bytes.
(emit-byte+reg segment #xB8 dst)
(emit-qword segment src))))
((fixup-p src) ; treat as a 32-bit unsigned integer
;; But imm-to-reg could take a 64-bit operand if needed.
(emit-prefixes segment dst nil :dword)
(emit-byte+reg segment #xB8 dst)
(emit-absolute-fixup segment src))
(t
(emit-prefixes segment src dst size)
(emit-byte segment (opcode+size-bit #x8A size))
(emit-ea segment src dst))))
(cond ((integerp src)
;; We want to encode the immediate using the fewest bytes possible.
(let ((imm-size
;; If it's a :qword constant that fits in an unsigned
;; :dword, then use a zero-extended :dword immediate.
(if (and (eq size :qword) (typep src '(unsigned-byte 32)))
:dword
size)))
(emit-prefixes segment dst nil imm-size))
(acond ((neq size :qword) ; :dword or smaller dst is straightforward
(emit-byte+reg segment (if (eq size :byte) #xB0 #xB8) dst)
(emit-imm-operand segment src size))
;; This must be move to a :qword register.
((typep src '(unsigned-byte 32))
;; Encode as B8+dst using operand size of 32 bits
;; and implicit zero-extension.
;; Instruction size: 5 if no REX prefix, or 6 with.
(emit-byte+reg segment #xB8 dst)
(emit-dword segment src))
((plausible-signed-imm32-operand-p src)
;; It's either a signed-byte-32, or a large unsigned
;; value whose 33 high bits are all 1.
;; Encode as C7 which sign-extends a 32-bit imm to 64 bits.
;; Instruction size: 7 bytes.
(emit-byte segment #xC7)
(emit-mod-reg-r/m-byte segment #b11 #b000
(reg-encoding dst segment))
(emit-signed-dword segment it))
(t
;; 64-bit immediate. Instruction size: 10 bytes.
(emit-byte+reg segment #xB8 dst)
(emit-qword segment src))))
((fixup-p src)
;; We emit the fixup as 32-bit or 64-bit, depending
;; on where read only spaces are located.
(cond ((<= read-only-space-start #xffffffff)
(emit-prefixes segment dst nil :dword)
(emit-byte+reg segment #xB8 dst)
(emit-absolute-fixup segment src))
(t
(emit-prefixes segment dst nil :qword)
(emit-byte+reg segment #xB8 dst)
(emit-absolute-fixup segment src t))))
(t
(emit-prefixes segment src dst size)
(emit-byte segment (opcode+size-bit #x8A size))
(emit-ea segment src dst))))
((integerp src) ; imm to memory
;; C7 only deals with 32 bit immediates even if the
;; destination is a 64-bit location. The value is
;; sign-extended in this case.
(let ((imm-size (if (eq size :qword) :dword size))
;; If IMMEDIATE32-P returns NIL, use the original value,
;; which will signal an error in EMIT-IMMEDIATE
(imm-val (or (and (eq size :qword)
(plausible-signed-imm32-operand-p src))
src)))
(emit-prefixes segment dst nil size)
(emit-byte segment (opcode+size-bit #xC6 size))
;; The EA could be RIP-relative, thus it is important
;; to get :REMAINING-BYTES correct.
(emit-ea segment dst #b000 :remaining-bytes (size-nbyte imm-size))
(emit-imm-operand segment imm-val imm-size)))
;; C7 only deals with 32 bit immediates even if the
;; destination is a 64-bit location. The value is
;; sign-extended in this case.
(let ((imm-size (if (eq size :qword) :dword size))
;; If IMMEDIATE32-P returns NIL, use the original value,
;; which will signal an error in EMIT-IMMEDIATE
(imm-val (or (and (eq size :qword)
(plausible-signed-imm32-operand-p src))
src)))
(emit-prefixes segment dst nil size)
(emit-byte segment (opcode+size-bit #xC6 size))
;; The EA could be RIP-relative, thus it is important
;; to get :REMAINING-BYTES correct.
(emit-ea segment dst #b000 :remaining-bytes (size-nbyte imm-size))
(emit-imm-operand segment imm-val imm-size)))
((gpr-p src) ; reg to mem
(emit-prefixes segment dst src size)
(emit-byte segment (opcode+size-bit #x88 size))
(emit-ea segment dst src))
((fixup-p src) ; equivalent to 32-bit unsigned integer
;; imm-to-mem can not take a 64-bit operand, but could sign-extend
;; to 8 bytes, which is probably not what you want.
(emit-prefixes segment dst nil size)
(emit-byte segment #xC7)
(emit-ea segment dst #b000)
(emit-absolute-fixup segment src))
;; imm-to-mem can not take a 64-bit operand, but could sign-extend
;; to 8 bytes, which is probably not what you want.
(emit-prefixes segment dst nil size)
(emit-byte segment #xC7)
(emit-ea segment dst #b000)
(emit-absolute-fixup segment src))
(t
(error "bogus arguments to MOV: ~S ~S" dst src))))

10
src/compiler/x86-64/memory.lisp
View file

@ -178,6 +178,7 @@
(:policy :fast-safe)
(:translate splat)
(:args (vector :scs (descriptor-reg)))
(:temporary (:sc unsigned-reg) temp) ;fixme conditionalize
(:info words value)
(:arg-types * (:constant (eql 1)) (:constant t))
(:results (result :scs (descriptor-reg)))
@ -185,12 +186,18 @@
(progn words) ; don't put it in :ignore, which gets inherited
(inst mov :qword
(ea (- (* vector-data-offset n-word-bytes) other-pointer-lowtag) vector)
(compute-splat-bits value))
(let ((bits (compute-splat-bits value)))
(cond ((plausible-signed-imm32-operand-p bits)
bits)
(t
(inst mov temp bits)
temp))))
(move result vector)))
(define-vop (splat-small splat-word)
(:arg-types * (:constant (integer 2 10)) (:constant t))
(:temporary (:sc complex-double-reg) zero)
(:ignore temp)
(:generator 5
(let ((bits (compute-splat-bits value)))
(if (= bits 0)
@ -214,6 +221,7 @@
(:args (vector :scs (descriptor-reg) :to (:result 0))
(words :scs (unsigned-reg immediate) :target rcx))
(:info value)
(:ignore temp)
(:arg-types * positive-fixnum (:constant t))
(:temporary (:sc any-reg :offset rdi-offset :from (:argument 0)
:to (:result 0)) rdi)

2
src/compiler/x86-64/parms.lisp
View file

@ -96,7 +96,7 @@
;;; it would cause. -- JES, 2005-12-11
#+(or linux darwin)
(!gencgc-space-setup #x50000000
(!gencgc-space-setup #x1dead0000
:read-only-space-size #+metaspace #.(* 2 1024 1024)
#-metaspace 0
:fixedobj-space-size #.(* 40 1024 1024)

4
src/runtime/x86-64-assem.S
View file

@ -289,10 +289,10 @@ GNAME(funcall_alien_callback):
#ifdef LISP_FEATURE_IMMOBILE_CODE
#include "genesis/vector.h"
// An extra instruction is needed to load the fdefn.
mov (STATIC_FDEFNS+VECTOR_DATA_OFFSET+8*ENTER_ALIEN_CALLBACK_fdefn),%rax
movabsq (STATIC_FDEFNS+VECTOR_DATA_OFFSET+8*ENTER_ALIEN_CALLBACK_fdefn),%rax
mov FDEFN_FUN_OFFSET(%rax),%rax
#else
mov (ENTER_ALIEN_CALLBACK_FDEFN+FDEFN_FUN_OFFSET),%rax
movabsq (ENTER_ALIEN_CALLBACK_FDEFN+FDEFN_FUN_OFFSET),%rax
#endif
call *CLOSURE_FUN_OFFSET(%rax)

3
tests/call-into-lisp.impure.lisp
View file

@ -61,7 +61,8 @@
;; Making room for 3 args aligns the stack to a 16-byte boundary
;; presuming it was at CALL to me. Darwin requires the alignment, others don't care.
`((sub ,rsp-tn 24)
(mov :qword ,(ea 16 rsp-tn) ,(get-lisp-obj-address T))
(mov ,rdi-tn ,(get-lisp-obj-address T))
(mov ,(ea 16 rsp-tn) ,rdi-tn)
(mov :qword ,(ea 8 rsp-tn) ,(fixnumize 311))
(mov :qword ,(ea 0 rsp-tn) ,(get-lisp-obj-address #\A))
(mov ,rdi-tn ,(get-lisp-obj-address #'monkeybiz)) ; C arg 0 = Lisp function