mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
redo "x86-64: defrag fdefns, GFs, and closure trampolines into varyobj space"
As before with 2 fixes: * absolute fixup application performed C pointer subtraction at 'native_pointer(...) - header_addr' which computed a difference in words where it meant to get a difference in bytes. * calc_n_varyobj_pages() also mixed up words versus bytes.
This commit is contained in:
Douglas Katzman
parent
af96b1ac4c
commit
b85b160a31
|
|
@ -447,3 +447,28 @@
|
|||
(inst pop rdi-tn) ; restore
|
||||
(inst pop rax-tn)
|
||||
(inst ret 24)) ; remove 3 stack args
|
||||
|
||||
#+sb-assembling
|
||||
(define-assembly-routine (touch-gc-card (:return-style :none)) ()
|
||||
;; stack: ret-pc, object
|
||||
#!-sb-thread
|
||||
(progn
|
||||
#!+sb-dynamic-core
|
||||
(progn
|
||||
(inst mov thread-base-tn (ea (make-fixup "all_threads" :foreign-dataref)))
|
||||
(inst mov thread-base-tn (ea thread-base-tn)))
|
||||
#!-sb-dynamic-core
|
||||
(inst mov thread-base-tn (ea (make-fixup "all_threads" :foreign))))
|
||||
(inst mov temp-reg-tn (ea 8 rsp-tn))
|
||||
(inst sub temp-reg-tn (thread-slot-ea thread-varyobj-space-addr-slot))
|
||||
(inst shr temp-reg-tn (integer-length (1- immobile-card-bytes)))
|
||||
(inst cmp temp-reg-tn (thread-slot-ea thread-varyobj-card-count-slot))
|
||||
(inst jmp :ae DONE)
|
||||
|
||||
(inst push rax-tn)
|
||||
(inst mov rax-tn (thread-slot-ea thread-varyobj-card-marks-slot))
|
||||
(inst bts (ea rax-tn) temp-reg-tn :lock)
|
||||
(inst pop rax-tn)
|
||||
|
||||
DONE
|
||||
(inst ret 8)) ; remove 1 stack arg
|
||||
|
|
|
|||
|
|
@ -1241,7 +1241,7 @@ We could try a few things to mitigate this:
|
|||
(values))
|
||||
|
||||
#+nil ; for debugging
|
||||
(defun dump-dynamic-space-code (&optional (stream *standard-output*)
|
||||
(defun show-dynamic-space-code (&optional (stream *standard-output*)
|
||||
&aux (n-code-bytes 0)
|
||||
(total-pages next-free-page)
|
||||
(pages
|
||||
|
|
@ -1285,6 +1285,23 @@ We could try a few things to mitigate this:
|
|||
n-code-bytes n-pages waste
|
||||
(* 100 (/ waste tot))))))
|
||||
|
||||
#+nil ; for debugging
|
||||
(defun show-immobile-spaces (which)
|
||||
(flet ((show (obj type size)
|
||||
(declare (ignore type size))
|
||||
(let ((*print-pretty* nil))
|
||||
(format t "~x: ~s~%" (get-lisp-obj-address obj) obj))))
|
||||
(when (or (eq which :fixed) (eq which :both))
|
||||
(format t "Fixedobj space~%==============~%")
|
||||
(map-objects-in-range #'show
|
||||
(%make-lisp-obj fixedobj-space-start)
|
||||
(%make-lisp-obj (sap-int *fixedobj-space-free-pointer*))))
|
||||
(when (or (eq which :variable) (eq which :both))
|
||||
(format t "Varyobj space~%=============~%")
|
||||
(map-objects-in-range #'show
|
||||
(%make-lisp-obj varyobj-space-start)
|
||||
(%make-lisp-obj (sap-int *varyobj-space-free-pointer*))))))
|
||||
|
||||
#+gencgc
|
||||
(defun generation-of (object)
|
||||
(let* ((addr (get-lisp-obj-address object))
|
||||
|
|
|
|||
|
|
@ -236,14 +236,15 @@
|
|||
(jmp-origin ; 5 = instruction length
|
||||
(+ fdefn-addr (ash fdefn-raw-addr-slot word-shift) 5))
|
||||
(jmp-operand
|
||||
(ldb (byte 32 0) (the (signed-byte 32) (- jmp-target jmp-origin)))))
|
||||
(setf (sap-ref-word (int-sap fdefn-addr) (ash fdefn-raw-addr-slot word-shift))
|
||||
(ldb (byte 32 0) (the (signed-byte 32) (- jmp-target jmp-origin))))
|
||||
(instruction
|
||||
(logior #xE9 ; JMP opcode
|
||||
(ash jmp-operand 8)
|
||||
(ash #xA890 40) ; "NOP ; TEST %AL, #xNN"
|
||||
(ash tagged-ptr-bias 56))
|
||||
(sap-ref-lispobj (int-sap fdefn-addr) (ash fdefn-fun-slot word-shift))
|
||||
fun)))))
|
||||
(ash tagged-ptr-bias 56))))
|
||||
(%primitive sb!vm::set-fdefn-fun fdefn fun instruction))))
|
||||
fun)
|
||||
|
||||
) ; end PROGN
|
||||
|
||||
;;; Find an immobile FDEFN or FUNCTION given an interior pointer to it.
|
||||
|
|
|
|||
|
|
@ -53,6 +53,9 @@
|
|||
(inst push offset)
|
||||
(inst push object)))
|
||||
(invoke-asm-routine 'call 'code-header-set vop))
|
||||
((equal name '(setf %funcallable-instance-fun))
|
||||
(gen-cell-set (make-ea-for-object-slot object offset lowtag)
|
||||
value nil vop t))
|
||||
(t
|
||||
(gen-cell-set (make-ea-for-object-slot object offset lowtag)
|
||||
value nil)))))
|
||||
|
|
@ -402,6 +405,20 @@
|
|||
(storew function fdefn fdefn-fun-slot other-pointer-lowtag)
|
||||
(storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
|
||||
(move result function)))
|
||||
#!+immobile-code
|
||||
(define-vop (set-fdefn-fun)
|
||||
(:args (fdefn :scs (descriptor-reg))
|
||||
(function :scs (descriptor-reg))
|
||||
(raw-word :scs (unsigned-reg)))
|
||||
(:vop-var vop)
|
||||
(:generator 38
|
||||
(pseudo-atomic ()
|
||||
(inst push fdefn)
|
||||
(invoke-asm-routine 'call 'touch-gc-card vop)
|
||||
(inst mov (ea (- (ash fdefn-fun-slot word-shift) other-pointer-lowtag) fdefn)
|
||||
function)
|
||||
(inst mov (ea (- (ash fdefn-raw-addr-slot word-shift) other-pointer-lowtag) fdefn)
|
||||
raw-word))))
|
||||
|
||||
(define-vop (fdefn-makunbound)
|
||||
(:policy :fast-safe)
|
||||
|
|
|
|||
|
|
@ -341,7 +341,8 @@
|
|||
`((gen-cell-set
|
||||
(ea (- (* ,offset n-word-bytes) ,lowtag)
|
||||
object index (ash 1 (- word-shift n-fixnum-tag-bits)))
|
||||
value result)))))
|
||||
value result vop
|
||||
,(eq name 'set-funcallable-instance-info))))))
|
||||
,@(when want-both-variants
|
||||
`((define-vop (,(symbolicate name "-C"))
|
||||
,@(when translate
|
||||
|
|
@ -356,11 +357,13 @@
|
|||
,el-type)
|
||||
(:results (result :scs ,scs))
|
||||
(:result-types ,el-type)
|
||||
(:vop-var vop)
|
||||
(:generator 3 ; was 5
|
||||
(gen-cell-set
|
||||
(ea (- (* (+ ,offset index) n-word-bytes) ,lowtag)
|
||||
object)
|
||||
value result))))))))
|
||||
value result vop
|
||||
,(eq name 'set-funcallable-instance-info)))))))))
|
||||
|
||||
(defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate)
|
||||
`(progn
|
||||
|
|
|
|||
|
|
@ -18,7 +18,15 @@
|
|||
(+ nil-value (static-symbol-offset symbol) offset)
|
||||
(make-fixup symbol :immobile-object offset)))))
|
||||
|
||||
(defun gen-cell-set (ea value result)
|
||||
(defun gen-cell-set (ea value result &optional vop pseudo-atomic)
|
||||
(when pseudo-atomic
|
||||
;; (SETF %FUNCALLABLE-INSTANCE-FUN) and (SETF %FUNCALLABLE-INSTANCE-INFO)
|
||||
;; pass in pseudo-atomic = T.
|
||||
(pseudo-atomic ()
|
||||
(inst push (ea-base ea))
|
||||
(invoke-asm-routine 'call 'touch-gc-card vop)
|
||||
(gen-cell-set ea value result))
|
||||
(return-from gen-cell-set))
|
||||
(when (sc-is value immediate)
|
||||
(let ((bits (encode-value-if-immediate value)))
|
||||
(cond ((not result)
|
||||
|
|
|
|||
|
|
@ -4251,7 +4251,9 @@ void gc_show_pte(lispobj obj)
|
|||
page = find_varyobj_page_index((void*)obj);
|
||||
if (page>=0) {
|
||||
extern unsigned char* varyobj_page_gens;
|
||||
printf("page %ld (v) gens %x%s\n", page, varyobj_page_gens[page],
|
||||
printf("page %ld (v) ss=%p gens %x%s\n", page,
|
||||
varyobj_scan_start(page),
|
||||
varyobj_page_gens[page],
|
||||
card_protected_p((void*)obj)? " WP":"");
|
||||
return;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -140,13 +140,7 @@ boolean immobile_card_protected_p(void* addr)
|
|||
lose("immobile_card_protected_p(%p)", addr);
|
||||
}
|
||||
|
||||
// Array of offsets backwards in double-lispwords from the page end
|
||||
// to the lowest-addressed object touching the page. This offset can
|
||||
// point to a hole, but we prefer that it not. If the offset is zero,
|
||||
// the page has no object other than possibly a hole resulting
|
||||
// from a freed object.
|
||||
unsigned short* varyobj_page_scan_start_offset;
|
||||
|
||||
// Array of page generation masks for objects which start on this page.
|
||||
// An object which ends on but does not start on page 'n' does not affect
|
||||
// the generation mask for page 'n'
|
||||
|
|
@ -157,7 +151,7 @@ lispobj varyobj_holes;
|
|||
#define varyobj_page_touched(x) ((varyobj_page_touched_bits[x/32] >> (x&31)) & 1)
|
||||
|
||||
#ifdef VERIFY_PAGE_GENS
|
||||
void check_fixedobj_page(low_page_index_t);
|
||||
void check_fixedobj_page(low_page_index_t, generation_index_t, generation_index_t);
|
||||
void check_varyobj_pages();
|
||||
#endif
|
||||
|
||||
|
|
@ -192,14 +186,6 @@ static inline void set_visited(lispobj* obj)
|
|||
|
||||
//// Variable-length utilities
|
||||
|
||||
/* Calculate the address where the first object touching this page starts. */
|
||||
static inline lispobj*
|
||||
varyobj_scan_start(low_page_index_t page_index)
|
||||
{
|
||||
return (lispobj*)((char*)varyobj_page_address(page_index+1)
|
||||
- varyobj_page_scan_start_offset[page_index] * (2 * N_WORD_BYTES));
|
||||
}
|
||||
|
||||
/* Return the generation mask for objects headers on 'page_index'
|
||||
including at most one object that starts before the page but ends on
|
||||
or after it.
|
||||
|
|
@ -443,7 +429,7 @@ void update_immobile_nursery_bits()
|
|||
fixedobj_pages[page].prior_gc_free_word_index)
|
||||
fixedobj_pages[page].gens |= 1;
|
||||
#ifdef VERIFY_PAGE_GENS
|
||||
check_fixedobj_page(page);
|
||||
check_fixedobj_page(page, 0xff, 0xff);
|
||||
#endif
|
||||
}
|
||||
#ifdef VERIFY_PAGE_GENS
|
||||
|
|
@ -866,6 +852,12 @@ varyobj_points_to_younger_p(lispobj* obj, int gen, int keep_gen, int new_gen,
|
|||
unsigned char widetag = header_widetag(word);
|
||||
if (widetag == CODE_HEADER_WIDETAG) { // usual case. Like scav_code_header()
|
||||
return header_rememberedp(word);
|
||||
} else if (widetag == FDEFN_WIDETAG ||
|
||||
widetag == FUNCALLABLE_INSTANCE_WIDETAG) {
|
||||
// both of these have non-descriptor bits in at least one word,
|
||||
// thus precluding a simple range scan.
|
||||
return fixedobj_points_to_younger_p(obj, sizetab[widetag](obj),
|
||||
gen, keep_gen, new_gen);
|
||||
} else if (widetag == SIMPLE_VECTOR_WIDETAG) {
|
||||
sword_t length = fixnum_value(((struct vector *)obj)->length);
|
||||
begin = obj + 2; // skip the header and length
|
||||
|
|
@ -873,7 +865,7 @@ varyobj_points_to_younger_p(lispobj* obj, int gen, int keep_gen, int new_gen,
|
|||
} else if (unboxed_obj_widetag_p(widetag)) {
|
||||
return 0;
|
||||
} else {
|
||||
lose("Unexpected widetag @ %p", obj);
|
||||
lose("Unexpected widetag %x @ %p", widetag, obj);
|
||||
}
|
||||
// Fallthrough: scan words from begin to end
|
||||
if (page_begin > (os_vm_address_t)begin) begin = (lispobj*)page_begin;
|
||||
|
|
@ -996,7 +988,7 @@ sweep_fixedobj_pages(int raise)
|
|||
&& fixedobj_pages[page].gens > 1
|
||||
&& can_wp_fixedobj_page(page, keep_gen, new_gen)) {
|
||||
SET_WP_FLAG(page, WRITE_PROTECT);
|
||||
dprintf((logfile, "set WP(1) on page %d (mask=%#x)\n",
|
||||
dprintf((logfile, "set WP(1) on fixedobj page %d (mask=%#x)\n",
|
||||
page, fixedobj_pages[page].gens));
|
||||
}
|
||||
continue;
|
||||
|
|
@ -1053,7 +1045,7 @@ sweep_fixedobj_pages(int raise)
|
|||
fixedobj_pages[page].gens = mask;
|
||||
if (wp_it) {
|
||||
SET_WP_FLAG(page, WRITE_PROTECT);
|
||||
dprintf((logfile, "set WP(2) on page %d\n", page));
|
||||
dprintf((logfile, "set WP(2) on fixedobj page %d\n", page));
|
||||
}
|
||||
} else {
|
||||
dprintf((logfile,"page %d is all garbage\n", page));
|
||||
|
|
@ -1061,12 +1053,25 @@ sweep_fixedobj_pages(int raise)
|
|||
fixedobj_pages[page].attr.packed = 0;
|
||||
}
|
||||
#ifdef DEBUG
|
||||
check_fixedobj_page(page);
|
||||
check_fixedobj_page(page, keep_gen, new_gen);
|
||||
#endif
|
||||
dprintf((logfile,"page %d: %d holes\n", page, n_holes));
|
||||
}
|
||||
}
|
||||
|
||||
static void make_filler(void* where, int nbytes)
|
||||
{
|
||||
if (nbytes < 4*N_WORD_BYTES)
|
||||
lose("can't place filler @ %p - too small", where);
|
||||
else { // Create a filler object.
|
||||
struct code* code = (struct code*)where;
|
||||
code->header = CODE_HEADER_WIDETAG; // 0 boxed words
|
||||
code->code_size = make_fixnum(nbytes);
|
||||
code->debug_info = varyobj_holes;
|
||||
varyobj_holes = (lispobj)code;
|
||||
}
|
||||
}
|
||||
|
||||
// Scan for freshly trashed objects and turn them into filler.
|
||||
// Lisp is responsible for consuming the free space
|
||||
// when it next allocates a variable-size object.
|
||||
|
|
@ -1129,15 +1134,7 @@ sweep_varyobj_pages(int raise)
|
|||
if (filler_obj_p(obj)) { // do nothing
|
||||
} else if ((gen = __immobile_obj_gen_bits(obj) & ~OBJ_WRITTEN_FLAG)
|
||||
== discard_gen) {
|
||||
if (size < 4)
|
||||
lose("immobile object @ %p too small to free", obj);
|
||||
else { // Create a filler object.
|
||||
struct code* code = (struct code*)obj;
|
||||
code->header = CODE_HEADER_WIDETAG; // 0 boxed words
|
||||
code->code_size = make_fixnum(size * N_WORD_BYTES);
|
||||
code->debug_info = varyobj_holes;
|
||||
varyobj_holes = (lispobj)code;
|
||||
}
|
||||
make_filler(obj, size * N_WORD_BYTES);
|
||||
} else if (gen == keep_gen) {
|
||||
assign_generation(obj, gen = new_gen);
|
||||
#ifdef DEBUG
|
||||
|
|
@ -1655,7 +1652,7 @@ static lispobj follow_fp(lispobj ptr)
|
|||
else
|
||||
return ptr;
|
||||
}
|
||||
static void fixup_immobile_refs(lispobj, struct code*);
|
||||
static void apply_absolute_fixups(lispobj, struct code*);
|
||||
|
||||
/// It's tricky to try to use the scavtab[] functions for fixing up moved
|
||||
/// objects, because scavenger functions might invoke transport functions.
|
||||
|
|
@ -1703,7 +1700,7 @@ static void fixup_space(lispobj* where, size_t n_words)
|
|||
f->self = adjust_fun_entrypoint(f->self);
|
||||
adjust_words(SIMPLE_FUN_SCAV_START(f), SIMPLE_FUN_SCAV_NWORDS(f), 0);
|
||||
});
|
||||
fixup_immobile_refs(code->fixups, code);
|
||||
apply_absolute_fixups(code->fixups, code);
|
||||
break;
|
||||
case CLOSURE_WIDETAG:
|
||||
where[1] = adjust_fun_entrypoint(where[1]);
|
||||
|
|
@ -1836,12 +1833,81 @@ static inline char* compute_defrag_start_address()
|
|||
|
||||
}
|
||||
|
||||
static int calc_n_pages(int n_objects, int words_per_object)
|
||||
static int calc_n_fixedobj_pages(int n_objects, int words_per_object)
|
||||
{
|
||||
words_per_object = ALIGN_UP(words_per_object, 2);
|
||||
int objects_per_page = WORDS_PER_PAGE / words_per_object;
|
||||
return (n_objects + objects_per_page - 1) / objects_per_page;
|
||||
}
|
||||
static int calc_n_varyobj_pages(int n_objects, int words_per_object)
|
||||
{
|
||||
words_per_object = ALIGN_UP(words_per_object, 2);
|
||||
int objects_per_page = WORDS_PER_PAGE / words_per_object;
|
||||
// varyobj space can't have unused bytes, but filler objects
|
||||
// require at least 4 words. So if there are only 2 words
|
||||
// of trailing fluff, cut out one object.
|
||||
// This could be improved by using 'filler' type object (not code)
|
||||
// which stores the length in the header word, leaving one word
|
||||
// available in which to store a pointer to the next filler object.
|
||||
if (WORDS_PER_PAGE - (words_per_object * objects_per_page) == 2)
|
||||
--objects_per_page;
|
||||
return (n_objects + objects_per_page - 1) / objects_per_page;
|
||||
}
|
||||
|
||||
/// Copy a fixed-size object to a variable-sized object page,
|
||||
/// such that the copy never crosses page boundaries.
|
||||
/// The original object may reside in either varyobj or fixedobj space.
|
||||
static void place_fixedobj(lispobj* obj, int size_in_bytes,
|
||||
char *alloc_ptrs[64], char *symbol_alloc_ptr[])
|
||||
{
|
||||
lispobj word = *obj;
|
||||
int widetag = header_widetag(word);
|
||||
char** alloc_ptr;
|
||||
if (widetag == SYMBOL_WIDETAG)
|
||||
alloc_ptr = &symbol_alloc_ptr[classify_symbol(obj)];
|
||||
else if (!(alloc_ptr = &alloc_ptrs[widetag>>2]))
|
||||
lose("Unexpected widetag %x", widetag);
|
||||
char* new = *alloc_ptr;
|
||||
char* page_end =
|
||||
PTR_ALIGN_DOWN(new, IMMOBILE_CARD_BYTES) + IMMOBILE_CARD_BYTES;
|
||||
// compute space remaining, possibly negative,
|
||||
// if this object were placed on the page.
|
||||
int space_avail = (page_end - new) - size_in_bytes;
|
||||
if (widetag == FDEFN_WIDETAG || widetag == CODE_HEADER_WIDETAG
|
||||
|| widetag == FUNCALLABLE_INSTANCE_WIDETAG) {
|
||||
// transporting into varyobj space.
|
||||
// since filler objects occupy >= 4 words, consider the page
|
||||
// to be overfull if exactly 2 words would remain.
|
||||
if (space_avail < 0 || space_avail == 2*N_WORD_BYTES) {
|
||||
make_filler(tempspace_addr(new), page_end - new);
|
||||
new = page_end;
|
||||
}
|
||||
} else {
|
||||
if (space_avail < 0)
|
||||
new = page_end;
|
||||
}
|
||||
gc_assert(!*tempspace_addr(new)); // better not clobber some other object
|
||||
memcpy(tempspace_addr(new), obj, size_in_bytes);
|
||||
set_forwarding_pointer(obj, make_lispobj(new, lowtag_for_widetag[widetag>>2]));
|
||||
if (widetag == FUNCALLABLE_INSTANCE_WIDETAG) // fix the self-pointer
|
||||
tempspace_addr(new)[1] = (lispobj)(new + 4*N_WORD_BYTES);
|
||||
*alloc_ptr = new + size_in_bytes;
|
||||
}
|
||||
|
||||
static void add_filler_if_needed(char* from, char* to)
|
||||
{
|
||||
if (to>from)
|
||||
make_filler(tempspace_addr(from), to-from);
|
||||
}
|
||||
|
||||
static boolean executable_object_p(lispobj* obj)
|
||||
{
|
||||
int widetag = widetag_of(obj);
|
||||
return widetag == FDEFN_WIDETAG ||
|
||||
(widetag == CODE_HEADER_WIDETAG && code_header_words(*obj) == 4
|
||||
&& lowtag_of(((struct code*)obj)->debug_info) == FUN_POINTER_LOWTAG)
|
||||
|| widetag == FUNCALLABLE_INSTANCE_WIDETAG;
|
||||
}
|
||||
|
||||
static void defrag_immobile_space(boolean verbose)
|
||||
{
|
||||
|
|
@ -1856,6 +1922,17 @@ static void defrag_immobile_space(boolean verbose)
|
|||
bzero(obj_type_histo, sizeof obj_type_histo);
|
||||
bzero(sym_kind_histo, sizeof sym_kind_histo);
|
||||
|
||||
// Count the fdefns, trampolines, and GFs already in varyobj sapace.
|
||||
// There are 3 kinds of code objects we'll see -
|
||||
// (1) ordinary code, (2) trampolines, (3) filler
|
||||
// Make sure only to count the trampolines on this pass.
|
||||
lispobj* obj = (lispobj*)VARYOBJ_SPACE_START;
|
||||
while (obj < varyobj_free_pointer) {
|
||||
int widetag = widetag_of(obj);
|
||||
if (executable_object_p(obj)) ++obj_type_histo[widetag/4];
|
||||
obj += sizetab[widetag](obj);
|
||||
}
|
||||
|
||||
#if DEFRAGMENT_FIXEDOBJ_SUBSPACE
|
||||
// Find the starting address of fixed-size objects that will undergo defrag.
|
||||
// Never move the first pages of LAYOUTs created by genesis.
|
||||
|
|
@ -1888,30 +1965,26 @@ static void defrag_immobile_space(boolean verbose)
|
|||
gc_assert(obj_type_histo[INSTANCE_WIDETAG/4]);
|
||||
|
||||
// Calculate space needed for fixedobj pages after defrag.
|
||||
// page order is: layouts, fdefns, trampolines, GFs, symbols
|
||||
int n_layout_pages = calc_n_pages(obj_type_histo[INSTANCE_WIDETAG/4],
|
||||
LAYOUT_ALIGN / N_WORD_BYTES);
|
||||
int n_fdefn_pages = calc_n_pages(obj_type_histo[FDEFN_WIDETAG/4], FDEFN_SIZE);
|
||||
int n_code_pages = calc_n_pages(obj_type_histo[CODE_HEADER_WIDETAG/4], FUN_TRAMP_SIZE);
|
||||
int n_fin_pages = calc_n_pages(obj_type_histo[FUNCALLABLE_INSTANCE_WIDETAG/4], GF_SIZE);
|
||||
// page order is: layouts, symbols.
|
||||
// FDEFNs, trampolines, and GFs are moved into varyobj space.
|
||||
int n_layout_pages = calc_n_fixedobj_pages(
|
||||
obj_type_histo[INSTANCE_WIDETAG/4],
|
||||
LAYOUT_ALIGN / N_WORD_BYTES);
|
||||
#if !(defined(LISP_FEATURE_IMMOBILE_CODE) && defined(LISP_FEATURE_COMPACT_INSTANCE_HEADER))
|
||||
gc_assert(n_fin_pages == 0);
|
||||
#endif
|
||||
char* layout_alloc_ptr = defrag_base;
|
||||
char* fdefn_alloc_ptr = layout_alloc_ptr + n_layout_pages * IMMOBILE_CARD_BYTES;
|
||||
char* code_alloc_ptr = fdefn_alloc_ptr + n_fdefn_pages * IMMOBILE_CARD_BYTES;
|
||||
char* fin_alloc_ptr = code_alloc_ptr + n_code_pages * IMMOBILE_CARD_BYTES;
|
||||
char* symbol_alloc_ptr[N_SYMBOL_KINDS+1];
|
||||
symbol_alloc_ptr[0] = fin_alloc_ptr + n_fin_pages * IMMOBILE_CARD_BYTES;
|
||||
char* symbol_alloc_ptrs[N_SYMBOL_KINDS+1];
|
||||
symbol_alloc_ptrs[0] = layout_alloc_ptr + n_layout_pages * IMMOBILE_CARD_BYTES;
|
||||
for (i=0; i<N_SYMBOL_KINDS ; ++i)
|
||||
symbol_alloc_ptr[i+1] =
|
||||
symbol_alloc_ptr[i] + calc_n_pages(sym_kind_histo[i].count,
|
||||
sym_kind_histo[i].size)
|
||||
* IMMOBILE_CARD_BYTES;
|
||||
char* ending_alloc_ptr = symbol_alloc_ptr[N_SYMBOL_KINDS];
|
||||
symbol_alloc_ptrs[i+1] =
|
||||
symbol_alloc_ptrs[i] + calc_n_fixedobj_pages(
|
||||
sym_kind_histo[i].count, sym_kind_histo[i].size) * IMMOBILE_CARD_BYTES;
|
||||
char* ending_alloc_ptr = symbol_alloc_ptrs[N_SYMBOL_KINDS];
|
||||
|
||||
fixedobj_tempspace.n_bytes = ending_alloc_ptr - (char*)FIXEDOBJ_SPACE_START;
|
||||
fixedobj_tempspace.start = calloc(fixedobj_tempspace.n_bytes, 1);
|
||||
|
||||
// Copy the first few pages (the permanent pages) from immobile space
|
||||
// into the temporary copy, so that tempspace_addr()
|
||||
// does not have to return the unadjusted addr if below defrag_base.
|
||||
|
|
@ -1921,24 +1994,51 @@ static void defrag_immobile_space(boolean verbose)
|
|||
|
||||
// Compute where each code component will be moved to.
|
||||
int n_code_components = 0;
|
||||
int n_code_bytes = 0;
|
||||
|
||||
if (components) {
|
||||
for (i=0 ; components[i*2] ; ++i) {
|
||||
addr = (lispobj*)(long)components[i*2];
|
||||
gc_assert(lowtag_of((lispobj)addr) == OTHER_POINTER_LOWTAG);
|
||||
addr = native_pointer((lispobj)addr);
|
||||
int widetag = widetag_of(addr);
|
||||
lispobj new_vaddr = 0;
|
||||
// FIXME: generalize
|
||||
gc_assert(widetag == CODE_HEADER_WIDETAG);
|
||||
lispobj new_vaddr = 0;
|
||||
// A code component can become garbage in the final GC
|
||||
// (defrag happens after the last GC) leaving a filler object
|
||||
// which was in components[] because it was live before GC.
|
||||
if (!filler_obj_p(addr)) {
|
||||
// must not be a trampoline object
|
||||
if ((lispobj)addr > VARYOBJ_SPACE_START)
|
||||
gc_assert(code_n_funs((struct code*)addr));
|
||||
++n_code_components;
|
||||
new_vaddr = VARYOBJ_SPACE_START + varyobj_tempspace.n_bytes;
|
||||
varyobj_tempspace.n_bytes += sizetab[widetag](addr) << WORD_SHIFT;
|
||||
new_vaddr = VARYOBJ_SPACE_START + n_code_bytes;
|
||||
n_code_bytes += sizetab[widetag](addr) << WORD_SHIFT;
|
||||
}
|
||||
components[i*2+1] = new_vaddr;
|
||||
}
|
||||
varyobj_tempspace.start = calloc(varyobj_tempspace.n_bytes, 1);
|
||||
}
|
||||
int aligned_nbytes = ALIGN_UP(n_code_bytes, IMMOBILE_CARD_BYTES);
|
||||
if (aligned_nbytes - n_code_bytes == 2 * N_WORD_BYTES)
|
||||
// waste another page because it can't be a 2-word filler
|
||||
aligned_nbytes += IMMOBILE_CARD_BYTES;
|
||||
char* fdefn_alloc_ptr = (char*)VARYOBJ_SPACE_START + aligned_nbytes;
|
||||
|
||||
int n_fdefn_pages =
|
||||
calc_n_varyobj_pages(obj_type_histo[FDEFN_WIDETAG/4],
|
||||
FDEFN_SIZE);
|
||||
int n_gf_pages =
|
||||
calc_n_varyobj_pages(obj_type_histo[FUNCALLABLE_INSTANCE_WIDETAG/4],
|
||||
GF_SIZE);
|
||||
int n_tramp_pages =
|
||||
calc_n_varyobj_pages(obj_type_histo[CODE_HEADER_WIDETAG/4],
|
||||
FUN_TRAMP_SIZE);
|
||||
|
||||
char* tramp_alloc_ptr = fdefn_alloc_ptr + n_fdefn_pages * IMMOBILE_CARD_BYTES;
|
||||
char* gf_alloc_ptr = tramp_alloc_ptr + n_tramp_pages * IMMOBILE_CARD_BYTES;
|
||||
ending_alloc_ptr = gf_alloc_ptr + n_gf_pages * IMMOBILE_CARD_BYTES;
|
||||
varyobj_tempspace.n_bytes = ending_alloc_ptr - (char*)VARYOBJ_SPACE_START;
|
||||
varyobj_tempspace.start = calloc(varyobj_tempspace.n_bytes, 1);
|
||||
|
||||
if (verbose)
|
||||
printf("(fin,inst,fdefn,code,sym)=%d+%d+%d+%d+%d... ",
|
||||
|
|
@ -1971,16 +2071,34 @@ static void defrag_immobile_space(boolean verbose)
|
|||
OTHER_POINTER_LOWTAG));
|
||||
}
|
||||
}
|
||||
if (aligned_nbytes > n_code_bytes)
|
||||
make_filler(tempspace_addr((char*)VARYOBJ_SPACE_START + n_code_bytes),
|
||||
aligned_nbytes - n_code_bytes);
|
||||
}
|
||||
|
||||
#if DEFRAGMENT_FIXEDOBJ_SUBSPACE
|
||||
char** alloc_ptrs[64];
|
||||
char* alloc_ptrs[64];
|
||||
bzero(alloc_ptrs, sizeof alloc_ptrs);
|
||||
alloc_ptrs[INSTANCE_WIDETAG/4] = &layout_alloc_ptr;
|
||||
alloc_ptrs[FDEFN_WIDETAG/4] = &fdefn_alloc_ptr;
|
||||
alloc_ptrs[CODE_HEADER_WIDETAG/4] = &code_alloc_ptr;
|
||||
alloc_ptrs[FUNCALLABLE_INSTANCE_WIDETAG/4] = &fin_alloc_ptr;
|
||||
alloc_ptrs[INSTANCE_WIDETAG/4] = layout_alloc_ptr;
|
||||
alloc_ptrs[FDEFN_WIDETAG/4] = fdefn_alloc_ptr;
|
||||
alloc_ptrs[CODE_HEADER_WIDETAG/4] = tramp_alloc_ptr;
|
||||
alloc_ptrs[FUNCALLABLE_INSTANCE_WIDETAG/4] = gf_alloc_ptr;
|
||||
|
||||
// Copy fixed-sized objects that were already in code space
|
||||
// to a possibly new address in code space.
|
||||
obj = (lispobj*)VARYOBJ_SPACE_START;
|
||||
while (obj < varyobj_free_pointer) {
|
||||
// Use the forwarded object if forwarded, because the header was stomped on.
|
||||
// This handles the code objects that were already forwarded.
|
||||
lispobj* fwdobj =
|
||||
forwarding_pointer_p(obj) ?
|
||||
tempspace_addr(native_pointer(forwarding_pointer_value(obj))) : obj;
|
||||
int size = sizetab[widetag_of(fwdobj)](fwdobj);
|
||||
// Supplying symbol_kind as 0 is fine - symbols can't exist in code space.
|
||||
if (executable_object_p(fwdobj))
|
||||
place_fixedobj(obj, size << WORD_SHIFT, alloc_ptrs, 0);
|
||||
obj += size;
|
||||
}
|
||||
// Permute fixed-sized object pages and deposit forwarding pointers.
|
||||
for ( page_index = find_fixedobj_page_index(defrag_base) ;
|
||||
page_index <= max_used_fixedobj_page ; ++page_index) {
|
||||
|
|
@ -1989,36 +2107,38 @@ static void defrag_immobile_space(boolean verbose)
|
|||
lispobj* obj = fixedobj_page_address(page_index);
|
||||
lispobj* limit = compute_fixedobj_limit(obj, obj_spacing);
|
||||
do {
|
||||
lispobj word = *obj;
|
||||
if (fixnump(word) || filler_obj_p(obj))
|
||||
continue;
|
||||
char** alloc_ptr;
|
||||
int widetag = header_widetag(word);
|
||||
if (widetag == SYMBOL_WIDETAG)
|
||||
alloc_ptr = &symbol_alloc_ptr[classify_symbol(obj)];
|
||||
else if (!(alloc_ptr = alloc_ptrs[widetag>>2]))
|
||||
lose("Unexpected widetag %x", widetag);
|
||||
lispobj* new = (lispobj*)*alloc_ptr;
|
||||
lispobj end = (lispobj)new + obj_spacing;
|
||||
#define ALIGN_MASK (IMMOBILE_CARD_BYTES - 1)
|
||||
if ((end & ALIGN_MASK) < ((lispobj)new & ALIGN_MASK) // wrapped
|
||||
&& (end & ALIGN_MASK) != 0) // ok if exactly on the boundary
|
||||
new = (lispobj*)(end & ~ALIGN_MASK); // snap to page
|
||||
#undef ALIGN_MASK
|
||||
memcpy(tempspace_addr(new), obj, sizetab[widetag](obj) << WORD_SHIFT);
|
||||
set_forwarding_pointer(obj,
|
||||
make_lispobj(new, lowtag_for_widetag[widetag>>2]));
|
||||
*alloc_ptr = (char*)new + obj_spacing;
|
||||
} while (NEXT_FIXEDOBJ(obj, obj_spacing) <= limit);
|
||||
if (fixnump(*obj)) continue;
|
||||
place_fixedobj(obj, obj_spacing, alloc_ptrs, symbol_alloc_ptrs);
|
||||
} while (NEXT_FIXEDOBJ(obj, obj_spacing) <= limit);
|
||||
}
|
||||
// Might require filler between inter-object-type gaps
|
||||
add_filler_if_needed(alloc_ptrs[FDEFN_WIDETAG/4], tramp_alloc_ptr);
|
||||
add_filler_if_needed(alloc_ptrs[CODE_HEADER_WIDETAG/4], gf_alloc_ptr);
|
||||
|
||||
#ifdef LISP_FEATURE_X86_64
|
||||
// Fixup JMP offset in fdefns, and self pointers in funcallable instances.
|
||||
// The former can not be done in the same pass as space permutation,
|
||||
// Fixup JMP displacements in fdefns. This can not be done in the same pass
|
||||
// as space permutation,
|
||||
// because we don't know the order in which a generic function and its
|
||||
// related fdefn will be reached. Were this attempted in a single pass,
|
||||
// it could miss a GF that will be moved after the fdefn is moved.
|
||||
// And it can't be done in fixup_space() because that does not know the
|
||||
// original address of each fdefn, so can't compute the absolute callee.
|
||||
obj = (lispobj*)VARYOBJ_SPACE_START;
|
||||
while (obj < varyobj_free_pointer) {
|
||||
if (!forwarding_pointer_p(obj)) {
|
||||
gc_assert(filler_obj_p(obj));
|
||||
obj += sizetab[widetag_of(obj)](obj);
|
||||
continue;
|
||||
}
|
||||
lispobj* new = native_pointer(forwarding_pointer_value(obj));
|
||||
int widetag = widetag_of(tempspace_addr(new));
|
||||
if (widetag == FDEFN_WIDETAG)
|
||||
// Fix displacement in JMP or CALL instruction.
|
||||
adjust_fdefn_entrypoint(tempspace_addr(new),
|
||||
(char*)new - (char*)obj,
|
||||
(struct fdefn*)obj);
|
||||
obj += sizetab[widetag](tempspace_addr(new));
|
||||
}
|
||||
for ( page_index = find_fixedobj_page_index(defrag_base) ;
|
||||
page_index <= max_used_fixedobj_page ; ++page_index) {
|
||||
int obj_spacing = fixedobj_page_obj_align(page_index);
|
||||
|
|
@ -2026,21 +2146,14 @@ static void defrag_immobile_space(boolean verbose)
|
|||
lispobj* obj = fixedobj_page_address(page_index);
|
||||
lispobj* limit = compute_fixedobj_limit(obj, obj_spacing);
|
||||
do {
|
||||
if (fixnump(*obj) || filler_obj_p(obj))
|
||||
continue;
|
||||
if (fixnump(*obj)) continue;
|
||||
gc_assert(forwarding_pointer_p(obj));
|
||||
lispobj* new = native_pointer(forwarding_pointer_value(obj));
|
||||
switch (widetag_of(tempspace_addr(new))) {
|
||||
case FDEFN_WIDETAG:
|
||||
if (widetag_of(tempspace_addr(new)) == FDEFN_WIDETAG)
|
||||
// Fix displacement in JMP or CALL instruction.
|
||||
adjust_fdefn_entrypoint(tempspace_addr(new),
|
||||
(char*)new - (char*)obj,
|
||||
(struct fdefn*)obj);
|
||||
break;
|
||||
case FUNCALLABLE_INSTANCE_WIDETAG:
|
||||
tempspace_addr(new)[1] = (lispobj)(new + 4);
|
||||
break;
|
||||
}
|
||||
} while (NEXT_FIXEDOBJ(obj, obj_spacing) <= limit);
|
||||
}
|
||||
#endif /* LISP_FEATURE_X86_64 */
|
||||
|
|
@ -2146,12 +2259,15 @@ static void defrag_immobile_space(boolean verbose)
|
|||
|
||||
#ifdef LISP_FEATURE_IMMOBILE_CODE
|
||||
// Variable-size object pages.
|
||||
memcpy((char*)VARYOBJ_SPACE_START,
|
||||
varyobj_tempspace.start, varyobj_tempspace.n_bytes);
|
||||
free_ptr = (lispobj)alloc_ptrs[FUNCALLABLE_INSTANCE_WIDETAG/4];
|
||||
memcpy((char*)VARYOBJ_SPACE_START, varyobj_tempspace.start,
|
||||
free_ptr-VARYOBJ_SPACE_START);
|
||||
// Zero-fill the unused remainder
|
||||
old_free_ptr = (lispobj)varyobj_free_pointer;
|
||||
free_ptr = VARYOBJ_SPACE_START + varyobj_tempspace.n_bytes;
|
||||
bzero((char*)free_ptr, old_free_ptr - free_ptr);
|
||||
// varyobj space can have *more* bytes in it after defrag than before,
|
||||
// as we might have transported fdefns (etc) into it.
|
||||
if (free_ptr < old_free_ptr)
|
||||
bzero((char*)free_ptr, old_free_ptr - free_ptr);
|
||||
varyobj_free_pointer = (lispobj*)free_ptr;
|
||||
free(components);
|
||||
#endif
|
||||
|
|
@ -2171,7 +2287,7 @@ static void defrag_immobile_space(boolean verbose)
|
|||
// in immobile space. Process only the absolute fixups.
|
||||
#include "forwarding-ptr.h"
|
||||
#ifdef LISP_FEATURE_X86_64
|
||||
static void fixup_immobile_refs(lispobj fixups, struct code* code)
|
||||
static void apply_absolute_fixups(lispobj fixups, struct code* code)
|
||||
{
|
||||
struct varint_unpacker unpacker;
|
||||
varint_unpacker_init(&unpacker, fixups);
|
||||
|
|
@ -2187,6 +2303,8 @@ static void fixup_immobile_refs(lispobj fixups, struct code* code)
|
|||
void* fixup_where = instructions + loc;
|
||||
lispobj ptr = (lispobj)UNALIGNED_LOAD32(fixup_where);
|
||||
lispobj* header_addr;
|
||||
long fpval;
|
||||
|
||||
if (is_lisp_pointer(ptr)) {
|
||||
lispobj fixed = follow_fp(ptr);
|
||||
if (fixed != ptr)
|
||||
|
|
@ -2202,7 +2320,7 @@ static void fixup_immobile_refs(lispobj fixups, struct code* code)
|
|||
header_addr = search_immobile_space((void*)ptr);
|
||||
gc_assert(header_addr);
|
||||
if (forwarding_pointer_p(header_addr)) {
|
||||
lispobj fpval = forwarding_pointer_value(header_addr);
|
||||
fpval = forwarding_pointer_value(header_addr);
|
||||
int __attribute__((unused)) widetag =
|
||||
widetag_of(tempspace_addr(native_pointer(fpval)));
|
||||
// Must be an interior pointer to a symbol value slot
|
||||
|
|
@ -2214,26 +2332,43 @@ static void fixup_immobile_refs(lispobj fixups, struct code* code)
|
|||
+ (ptr - (lispobj)header_addr));
|
||||
}
|
||||
} else {
|
||||
/* Depending on things, a call to immobile code from dynamic space
|
||||
* might be emitted as "MOV RAX, #x{addr} ; CALL RAX" where {addr}
|
||||
* is a simple-fun entry point. So assert that */
|
||||
/* Dynamic space functions can call immobile space functions
|
||||
* and fdefns using the two-instruction sequence:
|
||||
* MOV RAX, #x{addr} ; CALL RAX
|
||||
* where the addr is either word index 3 of an fdefn
|
||||
* (the jump instruction), or word index 6 of a simple-fun.
|
||||
* We have to heuristically figure out which it is.
|
||||
* If we started by assuming that it's a simple-fun then
|
||||
* we might go astray if it's an fdefn because we can't
|
||||
* correctly look backwards 6 words. */
|
||||
int delta;
|
||||
header_addr = (lispobj*)(ptr - offsetof(struct fdefn, raw_addr));
|
||||
if (forwarding_pointer_p(header_addr)) {
|
||||
fpval = forwarding_pointer_value(header_addr);
|
||||
if (widetag_of(tempspace_addr(native_pointer(fpval))) == FDEFN_WIDETAG)
|
||||
goto fix;
|
||||
lose("Expected fdefn @ %p", header_addr);
|
||||
}
|
||||
header_addr = (lispobj*)(ptr - offsetof(struct simple_fun, code));
|
||||
lispobj __attribute__((unused)) header_word =
|
||||
*(forwarding_pointer_p(header_addr) ?
|
||||
tempspace_addr(native_pointer(forwarding_pointer_value(header_addr))) :
|
||||
header_addr);
|
||||
gc_assert(header_widetag(header_word) == SIMPLE_FUN_WIDETAG);
|
||||
if (forwarding_pointer_p(header_addr))
|
||||
UNALIGNED_STORE32(fixup_where,
|
||||
forwarding_pointer_value(header_addr)
|
||||
+ FUN_RAW_ADDR_OFFSET);
|
||||
if (forwarding_pointer_p(header_addr)) {
|
||||
fpval = forwarding_pointer_value(header_addr);
|
||||
if (widetag_of(tempspace_addr(native_pointer(fpval))) == SIMPLE_FUN_WIDETAG)
|
||||
goto fix;
|
||||
lose("Expected simple-fun @ %p", header_addr);
|
||||
}
|
||||
lose("Can't determine referent of absolute fixup");
|
||||
fix:
|
||||
delta = (lispobj)native_pointer(fpval) - (lispobj)header_addr;
|
||||
UNALIGNED_STORE32(fixup_where, ptr + delta);
|
||||
}
|
||||
}
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifdef VERIFY_PAGE_GENS
|
||||
void check_fixedobj_page(int page)
|
||||
void check_fixedobj_page(int page,
|
||||
generation_index_t keep_gen,
|
||||
generation_index_t new_gen)
|
||||
{
|
||||
// Every page should have a 'gens' mask which exactly reflects
|
||||
// the aggregate over all objects on that page. Verify that invariant,
|
||||
|
|
@ -2261,8 +2396,11 @@ void check_fixedobj_page(int page)
|
|||
int gen = __immobile_obj_gen_bits(obj);
|
||||
gc_assert(0 <= gen && gen <= PSEUDO_STATIC_GENERATION);
|
||||
genmask |= 1<<gen;
|
||||
if (fixedobj_points_to_younger_p(obj, obj_size, gen, 0xff, 0xff))
|
||||
if (fixedobj_points_to_younger_p(obj, obj_size, gen, keep_gen, new_gen)) {
|
||||
if (fixedobj_page_wp(page))
|
||||
lose("sees_younger @ %p + %d\n", obj, obj_size);
|
||||
sees_younger = 1;
|
||||
}
|
||||
}
|
||||
} while (NEXT_FIXEDOBJ(obj, obj_spacing) <= limit);
|
||||
// It's not wrong if the gen0 bit is set spuriously, but it should only
|
||||
|
|
|
|||
|
|
@ -42,6 +42,20 @@ varyobj_page_address(low_page_index_t page_num)
|
|||
return (void*)(VARYOBJ_SPACE_START + (page_num * IMMOBILE_CARD_BYTES));
|
||||
}
|
||||
|
||||
// Array of offsets backwards in double-lispwords from the page end
|
||||
// to the lowest-addressed object touching the page. This offset can
|
||||
// point to a hole, but we prefer that it not. If the offset is zero,
|
||||
// the page has no object other than possibly a hole resulting
|
||||
// from a freed object.
|
||||
extern unsigned short* varyobj_page_scan_start_offset;
|
||||
/* Calculate the address where the first object touching this page starts. */
|
||||
static inline lispobj*
|
||||
varyobj_scan_start(low_page_index_t page_index)
|
||||
{
|
||||
return (lispobj*)((char*)varyobj_page_address(page_index+1)
|
||||
- varyobj_page_scan_start_offset[page_index] * (2 * N_WORD_BYTES));
|
||||
}
|
||||
|
||||
static inline low_page_index_t find_fixedobj_page_index(void *addr)
|
||||
{
|
||||
if (addr >= (void*)FIXEDOBJ_SPACE_START) {
|
||||
|
|
|
|||
|
|
@ -27,6 +27,15 @@ run_sbcl_with_core "$tmpcore" --no-userinit --no-sysinit \
|
|||
--eval "(setf sb-ext:*evaluator-mode* :${TEST_SBCL_EVALUATOR_MODE:-compile})"
|
||||
check_status_maybe_lose "SAVE-LISP-AND-DIE :TOPLEVEL" $? 0 "(saved core ran)"
|
||||
|
||||
run_sbcl <<EOF
|
||||
(require :asdf)
|
||||
(require :sb-bsd-sockets)
|
||||
(save-lisp-and-die "$tmpcore")
|
||||
EOF
|
||||
run_sbcl_with_core "$tmpcore" --no-userinit --no-sysinit \
|
||||
--eval "(require :sb-posix)" --quit
|
||||
check_status_maybe_lose "SAVE-LISP-AND-DIE" $? 0 "(saved core ran)"
|
||||
|
||||
# In sbcl-0.7.7 SAVE-LISP-AND-DIE didn't work at all because of
|
||||
# flakiness caused by consing/GC/purify twice-and-at-least-twice
|
||||
# mismatch grot.
|
||||
|
|
|
|||
|
|
@ -86,7 +86,7 @@
|
|||
n))
|
||||
(defun make-one-cons () (cons 'x 'y))
|
||||
|
||||
;;; While this does not directly tests LIST-ALLOCATED-OBJECTS,
|
||||
;;; While this does not directly test LIST-ALLOCATED-OBJECTS,
|
||||
;;; it checks that L-A-O would potentially (probably) include in its
|
||||
;;; output each new object allocated, barring any intervening GC.
|
||||
;;; It is all but impossible to actually test L-A-O in an A/B scenario
|
||||
|
|
|
|||
|
|
@ -125,7 +125,7 @@
|
|||
(jmp-inst nil :read-only t)
|
||||
(pop-inst nil :read-only t))
|
||||
|
||||
(defun c-name (lispname core pp-state)
|
||||
(defun c-name (lispname core pp-state &optional (prefix ""))
|
||||
;; Get rid of junk from LAMBDAs
|
||||
(setq lispname
|
||||
(named-let recurse ((x lispname))
|
||||
|
|
@ -185,7 +185,7 @@
|
|||
:case :downcase :gensym nil
|
||||
:right-margin 10000)))
|
||||
'list))))
|
||||
(let ((string (coerce characters 'string)))
|
||||
(let ((string (concatenate 'string prefix characters)))
|
||||
;; If the string appears in the linker symbols, then string-upcase it
|
||||
;; so that it looks like a conventional Lisp symbol.
|
||||
(cond ((find-if (lambda (x) (string= string (if (consp x) (car x) x)))
|
||||
|
|
@ -245,7 +245,7 @@
|
|||
(packages (core-packages core))
|
||||
(core-nil (core-nil-object core)))
|
||||
(named-let recurse ((depth 0) (x name))
|
||||
(unless (= (logand (get-lisp-obj-address x) 3) 3)
|
||||
(unless (is-lisp-pointer (get-lisp-obj-address x))
|
||||
(return-from recurse x)) ; immediate object
|
||||
(when (eq x core-nil)
|
||||
(return-from recurse nil))
|
||||
|
|
@ -780,9 +780,9 @@
|
|||
(* (code-header-words code) n-word-bytes))
|
||||
collect (sap-ref-8 text-sap i)))))
|
||||
|
||||
(defconstant +gf-name-slot+ 5)
|
||||
|
||||
;;; Convert immobile varyobj space to an assembly file in OUTPUT.
|
||||
;;; TODO: relocate fdefns and instances of standard-generic-function
|
||||
;;; into the space that is dumped into an ELF section.
|
||||
(defun write-assembler-text
|
||||
(spaces output
|
||||
&optional emit-sizes (emit-cfi t)
|
||||
|
|
@ -796,6 +796,9 @@
|
|||
(sb-pretty::make-pprint-dispatch-table)))
|
||||
(prev-namestring "")
|
||||
(n-linker-relocs 0)
|
||||
(seen-fdefns nil)
|
||||
(seen-trampolines nil)
|
||||
(seen-gfs nil)
|
||||
end-loc)
|
||||
(set-pprint-dispatch 'string
|
||||
;; Write strings without string quotes
|
||||
|
|
@ -881,46 +884,103 @@
|
|||
(setf total-code-size size)))
|
||||
(loop
|
||||
(when (>= code-addr (bounds-high code-bounds)) (return))
|
||||
(let* ((code (make-code-obj code-addr))
|
||||
(objsize (code-component-size code)))
|
||||
(setq end-loc (+ code-addr objsize))
|
||||
(incf total-code-size objsize)
|
||||
(cond
|
||||
((< (code-header-words code) 4) ; filler object
|
||||
;; ** THIS CASE IS UNTESTED **
|
||||
;; Shouldn't occur unless defrag was not performed
|
||||
(format output "#x~x:~% .quad 0x~X, 0x~X~% .fill ~D~%"
|
||||
code-addr
|
||||
simple-array-unsigned-byte-8-widetag
|
||||
(ash (- objsize (* 2 n-word-bytes))
|
||||
n-fixnum-tag-bits)
|
||||
(- objsize (* 2 n-word-bytes))))
|
||||
((%instancep (%code-debug-info code)) ; assume it's a COMPILED-DEBUG-INFO
|
||||
(aver (plusp (code-n-entries code)))
|
||||
(let* ((source
|
||||
(sb-c::compiled-debug-info-source
|
||||
(truly-the sb-c::compiled-debug-info
|
||||
(translate (%code-debug-info code) spaces))))
|
||||
(namestring
|
||||
(sb-c::debug-source-namestring
|
||||
(truly-the sb-c::debug-source (translate source spaces)))))
|
||||
(setq namestring (if (eq namestring (core-nil-object core))
|
||||
"sbcl.core"
|
||||
(translate namestring spaces)))
|
||||
(unless (string= namestring prev-namestring)
|
||||
(format output " .file \"~a\"~%" namestring)
|
||||
(setq prev-namestring namestring)))
|
||||
(setf (core-fixup-addrs core)
|
||||
(mapcar (lambda (x)
|
||||
(+ code-addr (ash (code-header-words code) word-shift) x))
|
||||
(code-fixup-locs code spaces)))
|
||||
(let ((code-physaddr (logandc2 (get-lisp-obj-address code) lowtag-mask)))
|
||||
(format output "#x~x:~%" code-addr)
|
||||
(dumpwords code-physaddr (code-header-words code) output #() code-addr)
|
||||
(emit-funs code code-addr core pp-state #'dumpwords output emit-cfi)))
|
||||
(t
|
||||
(error "Strange code component: ~S" code)))
|
||||
(incf code-addr objsize))))
|
||||
(ecase (%widetag-of (sap-ref-word (int-sap (translate-ptr code-addr spaces)) 0))
|
||||
(#.code-header-widetag
|
||||
(let* ((code (make-code-obj code-addr))
|
||||
(objsize (code-component-size code)))
|
||||
(setq end-loc (+ code-addr objsize))
|
||||
(incf total-code-size objsize)
|
||||
(cond
|
||||
((< (code-header-words code) 4) ; filler object
|
||||
(let ((nbytes (code-component-size code)))
|
||||
(format output " .quad 0x~x, 0x~x~% .fill 0x~x~%# ~x:~%"
|
||||
code-header-widetag (ash nbytes n-fixnum-tag-bits)
|
||||
(- nbytes (* 2 n-word-bytes))
|
||||
(+ code-addr nbytes))))
|
||||
((%instancep (%code-debug-info code)) ; assume it's a COMPILED-DEBUG-INFO
|
||||
(aver (plusp (code-n-entries code)))
|
||||
(let* ((source
|
||||
(sb-c::compiled-debug-info-source
|
||||
(truly-the sb-c::compiled-debug-info
|
||||
(translate (%code-debug-info code) spaces))))
|
||||
(namestring
|
||||
(sb-c::debug-source-namestring
|
||||
(truly-the sb-c::debug-source (translate source spaces)))))
|
||||
(setq namestring (if (eq namestring (core-nil-object core))
|
||||
"sbcl.core"
|
||||
(translate namestring spaces)))
|
||||
(unless (string= namestring prev-namestring)
|
||||
(format output " .file \"~a\"~%" namestring)
|
||||
(setq prev-namestring namestring)))
|
||||
(setf (core-fixup-addrs core)
|
||||
(mapcar (lambda (x)
|
||||
(+ code-addr (ash (code-header-words code) word-shift) x))
|
||||
(code-fixup-locs code spaces)))
|
||||
(let ((code-physaddr (logandc2 (get-lisp-obj-address code) lowtag-mask)))
|
||||
(format output "#x~x:~%" code-addr)
|
||||
(dumpwords code-physaddr (code-header-words code) output #() code-addr)
|
||||
(emit-funs code code-addr core pp-state #'dumpwords output emit-cfi)))
|
||||
((functionp (%code-debug-info code))
|
||||
(unless seen-trampolines
|
||||
(setq seen-trampolines t)
|
||||
(format output "lisp_trampolines:~%"))
|
||||
(let* ((sap (int-sap (translate-ptr code-addr spaces)))
|
||||
(tramp-fun (sap-ref-word sap (ash 2 word-shift))))
|
||||
(aver (not (in-bounds-p tramp-fun code-bounds)))
|
||||
(format output " .quad ~{0x~x~^,~}~%"
|
||||
(loop for i from 0 by n-word-bytes repeat 6
|
||||
collect (sap-ref-word sap i)))))
|
||||
(t
|
||||
(error "Strange code component: ~S" code)))
|
||||
(incf code-addr objsize)))
|
||||
(#.fdefn-widetag
|
||||
(unless seen-fdefns
|
||||
(format output "~%# FDEFNs~%")
|
||||
(setq seen-fdefns t))
|
||||
(let* ((ptr (translate-ptr code-addr spaces))
|
||||
(fdefn (%make-lisp-obj (logior ptr other-pointer-lowtag)))
|
||||
(name (fun-name-from-core (fdefn-name fdefn) core))
|
||||
(fun (get-lisp-obj-address (fdefn-fun fdefn)))
|
||||
(code-space-p (in-bounds-p fun code-bounds))
|
||||
(raw-fun (sap-ref-word (int-sap ptr)
|
||||
(ash fdefn-raw-addr-slot word-shift)))
|
||||
(c-name (c-name name core pp-state "f_")))
|
||||
(format output "~a: # ~x~%~@[ .size ~:*~a, ~d~%~]"
|
||||
(c-symbol-quote c-name)
|
||||
(logior code-addr other-pointer-lowtag)
|
||||
(if emit-sizes 32))
|
||||
(format output " .quad 0x~x, 0x~x, ~:[~;__lisp_code_start+~]0x~x, 0x~x~%"
|
||||
(sap-ref-word (int-sap ptr) 0)
|
||||
(sap-ref-word (int-sap ptr) 8)
|
||||
code-space-p (if code-space-p (- fun (bounds-low code-bounds)) fun)
|
||||
raw-fun)
|
||||
(incf code-addr (* 4 n-word-bytes))))
|
||||
(#.funcallable-instance-widetag
|
||||
(unless seen-gfs
|
||||
(setq seen-gfs t)
|
||||
(format output " .size lisp_trampolines, .-lisp_trampolines~%"))
|
||||
(let* ((sap (int-sap (translate-ptr code-addr spaces)))
|
||||
(fin-fun (sap-ref-word sap (ash 2 word-shift)))
|
||||
(code-space-p (in-bounds-p fin-fun code-bounds))
|
||||
(slots (translate (sap-ref-lispobj sap (ash 3 word-shift)) spaces))
|
||||
(name (and (> (length (the simple-vector slots)) +gf-name-slot+)
|
||||
(svref slots +gf-name-slot+)))
|
||||
(c-name
|
||||
(c-name
|
||||
(if (or (not name)
|
||||
(eql (get-lisp-obj-address name) sb-vm:unbound-marker-widetag))
|
||||
"unnamed"
|
||||
(fun-name-from-core name core))
|
||||
core pp-state "gf_")))
|
||||
(format output "~a:~%~@[ .size ~:*~a, ~d~%~]"
|
||||
(c-symbol-quote c-name) (if emit-sizes 48))
|
||||
(format output " .quad 0x~x, .+24, ~:[~;__lisp_code_start+~]0x~x~{, 0x~x~}~%"
|
||||
(sap-ref-word sap 0)
|
||||
code-space-p
|
||||
(if code-space-p (- fin-fun (bounds-low code-bounds)) fin-fun)
|
||||
(loop for i from (ash 3 word-shift) by n-word-bytes repeat 3
|
||||
collect (sap-ref-word sap i))))
|
||||
(incf code-addr (* 6 n-word-bytes))))))
|
||||
|
||||
;; coreparse uses the 'lisp_jit_code' symbol to set varyobj_free_pointer
|
||||
;; The intent is that compilation to memory can use this reserved area
|
||||
|
|
|
|||
Loading…
Reference in a new issue