mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

More precise stack marking via .guile.frame-maps section

Browse source 
* module/language/cps/slot-allocation.scm (lookup-dead-slot-map)
  (allocate-slots): For each non-tail call in a function, compute the
  set of slots that are dead after the function has begun the call.

* module/language/cps/compile-bytecode.scm (compile-fun): Emit the
  `dead-slot-map' macro instruction for non-tail calls.

* module/system/vm/assembler.scm (<asm>): Add `dead-slot-maps' member.
  (dead-slot-map): New macro-instruction.
  (link-frame-maps, link-dynamic-section, link-objects): Write dead
  slots information into .guile.frame-maps sections of ELF files.
* module/system/vm/elf.scm (DT_GUILE_FRAME_MAPS): New definition.

* libguile/loader.h:
* libguile/loader.c (DT_GUILE_FRAME_MAPS, process_dynamic_segment):
  (load_thunk_from_memory, register_elf): Arrange to parse
  DT_GUILE_FRAME_MAPS out of the dynamic section.
  (find_mapped_elf_image_unlocked, find_mapped_elf_image): New helpers.
  (scm_find_mapped_elf_image): Refactor.
  (scm_find_dead_slot_map_unlocked): New interface.

* libguile/vm.c (scm_i_vm_mark_stack): Mark the hottest frame
  conservatively, as before.  Otherwise use the dead slots map, if
  available, to avoid marking data that isn't live.
This commit is contained in:
Andy Wingo 2014-01-26 20:55:04 +01:00
parent b3f1bb5d31
commit 02c624fc09
7 changed files with 291 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

140
libguile/loader.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012
* 2013 Free Software Foundation, Inc.
* 2013, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -34,6 +34,7 @@
#include <assert.h>
#include <alignof.h>
#include <byteswap.h>
#include <verify.h>
#include <full-read.h>
@ -69,6 +70,7 @@
roots */
#define DT_GUILE_ENTRY 0x37146002 /* Address of entry thunk */
#define DT_GUILE_VM_VERSION 0x37146003 /* Bytecode version */
#define DT_GUILE_FRAME_MAPS 0x37146004 /* Frame maps */
#define DT_HIGUILE 0x37146fff /* End of Guile-specific */
#ifdef WORDS_BIGENDIAN
@ -77,7 +79,7 @@
#define ELFDATA ELFDATA2LSB
#endif
static void register_elf (char *data, size_t len);
static void register_elf (char *data, size_t len, char *frame_maps);
enum bytecode_kind
{
@ -244,12 +246,12 @@ segment_flags_to_prot (Elf_Word flags)
static char*
process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
SCM *init_out, SCM *entry_out)
SCM *init_out, SCM *entry_out, char **frame_maps_out)
{
char *dyn_addr = base + dyn_phdr->p_vaddr;
Elf_Dyn *dyn = (Elf_Dyn *) dyn_addr;
size_t i, dyn_size = dyn_phdr->p_memsz / sizeof (Elf_Dyn);
char *init = 0, *gc_root = 0, *entry = 0;
char *init = 0, *gc_root = 0, *entry = 0, *frame_maps = 0;
scm_t_ptrdiff gc_root_size = 0;
enum bytecode_kind bytecode_kind = BYTECODE_KIND_NONE;
@ -303,6 +305,11 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
}
break;
}
case DT_GUILE_FRAME_MAPS:
if (frame_maps)
return "duplicate DT_GUILE_FRAME_MAPS";
frame_maps = base + dyn[i].d_un.d_val;
break;
}
}
@ -327,6 +334,8 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
*init_out = init ? pointer_to_procedure (bytecode_kind, init) : SCM_BOOL_F;
*entry_out = pointer_to_procedure (bytecode_kind, entry);
*frame_maps_out = frame_maps;
return NULL;
}
@ -343,6 +352,7 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
int i;
int dynamic_segment = -1;
SCM init = SCM_BOOL_F, entry = SCM_BOOL_F;
char *frame_maps = 0;
if (len < sizeof *header)
ABORT ("object file too small");
@ -427,13 +437,13 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only)
}
if ((err_msg = process_dynamic_segment (data, &ph[dynamic_segment],
&init, &entry)))
&init, &entry, &frame_maps)))
goto cleanup;
if (scm_is_true (init))
scm_call_0 (init);
register_elf (data, len);
register_elf (data, len, frame_maps);
/* Finally! Return the thunk. */
return entry;
@ -568,6 +578,7 @@ struct mapped_elf_image
{
char *start;
char *end;
char *frame_maps;
};
static struct mapped_elf_image *mapped_elf_images = NULL;
@ -594,7 +605,7 @@ find_mapped_elf_insertion_index (char *ptr)
}
static void
register_elf (char *data, size_t len)
register_elf (char *data, size_t len, char *frame_maps)
{
scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
{
@ -619,6 +630,7 @@ register_elf (char *data, size_t len)
{
mapped_elf_images[n].start = prev[n].start;
mapped_elf_images[n].end = prev[n].end;
mapped_elf_images[n].frame_maps = prev[n].frame_maps;
}
}
@ -628,43 +640,71 @@ register_elf (char *data, size_t len)
for (end = mapped_elf_images_count; n < end; end--)
{
mapped_elf_images[end].start = mapped_elf_images[end - 1].start;
mapped_elf_images[end].end = mapped_elf_images[end - 1].end;
const struct mapped_elf_image *prev = &mapped_elf_images[end - 1];
mapped_elf_images[end].start = prev->start;
mapped_elf_images[end].end = prev->end;
mapped_elf_images[end].frame_maps = prev->frame_maps;
}
mapped_elf_images_count++;
mapped_elf_images[n].start = data;
mapped_elf_images[n].end = data + len;
mapped_elf_images[n].frame_maps = frame_maps;
}
}
scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
}
static SCM
scm_find_mapped_elf_image (SCM ip)
static struct mapped_elf_image *
find_mapped_elf_image_unlocked (char *ptr)
{
char *ptr = (char *) scm_to_uintptr_t (ip);
SCM result;
size_t n = find_mapped_elf_insertion_index ((char *) ptr);
if (n < mapped_elf_images_count
&& mapped_elf_images[n].start <= ptr
&& ptr < mapped_elf_images[n].end)
return &mapped_elf_images[n];
return NULL;
}
static int
find_mapped_elf_image (char *ptr, struct mapped_elf_image *image)
{
int result;
scm_i_pthread_mutex_lock (&scm_i_misc_mutex);
{
size_t n = find_mapped_elf_insertion_index ((char *) ptr);
if (n < mapped_elf_images_count
&& mapped_elf_images[n].start <= ptr
&& ptr < mapped_elf_images[n].end)
struct mapped_elf_image *img = find_mapped_elf_image_unlocked (ptr);
if (img)
{
signed char *data = (signed char *) mapped_elf_images[n].start;
size_t len = mapped_elf_images[n].end - mapped_elf_images[n].start;
result = scm_c_take_gc_bytevector (data, len, SCM_BOOL_F);
memcpy (image, img, sizeof (*image));
result = 1;
}
else
result = SCM_BOOL_F;
result = 0;
}
scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);
return result;
}
static SCM
scm_find_mapped_elf_image (SCM ip)
{
struct mapped_elf_image image;
if (find_mapped_elf_image ((char *) scm_to_uintptr_t (ip), &image))
{
signed char *data = (signed char *) image.start;
size_t len = image.end - image.start;
return scm_c_take_gc_bytevector (data, len, SCM_BOOL_F);
}
return SCM_BOOL_F;
}
static SCM
scm_all_mapped_elf_images (void)
{
@ -686,6 +726,64 @@ scm_all_mapped_elf_images (void)
return result;
}
struct frame_map_prefix
{
scm_t_uint32 text_offset;
scm_t_uint32 maps_offset;
};
struct frame_map_header
{
scm_t_uint32 addr;
scm_t_uint32 map_offset;
};
verify (sizeof (struct frame_map_prefix) == 8);
verify (sizeof (struct frame_map_header) == 8);
const scm_t_uint8 *
scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip)
{
struct mapped_elf_image *image;
char *base;
struct frame_map_prefix *prefix;
struct frame_map_header *headers;
scm_t_uintptr addr = (scm_t_uintptr) ip;
size_t start, end;
image = find_mapped_elf_image_unlocked ((char *) ip);
if (!image || !image->frame_maps)
return NULL;
base = image->frame_maps;
prefix = (struct frame_map_prefix *) base;
headers = (struct frame_map_header *) (base + sizeof (*prefix));
if (addr < ((scm_t_uintptr) image->start) + prefix->text_offset)
return NULL;
addr -= ((scm_t_uintptr) image->start) + prefix->text_offset;
start = 0;
end = (prefix->maps_offset - sizeof (*prefix)) / sizeof (*headers);
if (end == 0 || addr > headers[end - 1].addr)
return NULL;
while (start < end)
{
size_t n = start + (end - start) / 2;
if (addr == headers[n].addr)
return (const scm_t_uint8*) (base + headers[n].map_offset);
else if (addr < headers[n].addr)
end = n;
else
start = n + 1;
}
return NULL;
}
void
scm_bootstrap_loader (void)

5
libguile/loader.h
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -24,6 +24,9 @@
SCM_API SCM scm_load_thunk_from_file (SCM filename);
SCM_API SCM scm_load_thunk_from_memory (SCM bv);
SCM_INTERNAL const scm_t_uint8 *
scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip);
SCM_INTERNAL void scm_bootstrap_loader (void);
SCM_INTERNAL void scm_init_loader (void);

35
libguile/vm.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -794,6 +794,12 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
struct GC_ms_entry *mark_stack_limit)
{
SCM *sp, *fp;
/* The first frame will be marked conservatively (without a dead
slot map). This is because GC can happen at any point within the
hottest activation, due to multiple threads or per-instruction
hooks, and providing dead slot maps for all points in a program
would take a prohibitive amount of space. */
const scm_t_uint8 *dead_slots = NULL;
for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp))
{
@ -801,11 +807,32 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
{
SCM elt = *sp;
if (SCM_NIMP (elt))
mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word *) elt,
mark_stack_ptr, mark_stack_limit,
NULL);
{
if (dead_slots)
{
size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0);
if (dead_slots[slot / 8U] & (1U << (slot % 8U)))
{
/* This value may become dead as a result of GC,
so we can't just leave it on the stack. */
*sp = SCM_UNBOUND;
continue;
}
}
mark_stack_ptr = GC_MARK_AND_PUSH ((GC_word *) elt,
mark_stack_ptr,
mark_stack_limit,
NULL);
}
}
sp = SCM_FRAME_PREVIOUS_SP (fp);
/* Inner frames may have a dead slots map for precise marking.
Note that there may be other reasons to not have a dead slots
map, e.g. if all of the frame's slots below the callee frame
are live. */
dead_slots =
scm_find_dead_slot_map_unlocked (SCM_FRAME_RETURN_ADDRESS (fp));
}
return mark_stack_ptr;

2
module/language/cps/compile-bytecode.scm
View file

@ -452,6 +452,8 @@
(lookup-parallel-moves label allocation))
(for-each maybe-load-constant arg-slots (cons proc args))
(emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot
(lookup-dead-slot-map label allocation))
(cond
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
(match (lookup-parallel-moves k allocation)

58
module/language/cps/slot-allocation.scm
View file

@ -36,7 +36,8 @@
lookup-maybe-constant-value
lookup-nlocals
lookup-call-proc-slot
lookup-parallel-moves))
lookup-parallel-moves
lookup-dead-slot-map))
(define-record-type $allocation
(make-allocation dfa slots
@ -68,32 +69,34 @@
;; record the way that functions are passed values, and how their
;; return values are rebound to local variables.
;;
;; A call allocation contains two pieces of information: the call's
;; /proc slot/, and a set of /parallel moves/. The proc slot
;; indicates the slot of a procedure in a procedure call, or where the
;; procedure would be in a multiple-value return. The parallel moves
;; shuffle locals into position for a call, or shuffle returned values
;; back into place. Though they use the same slot, moves for a call
;; are called "call moves", and moves to handle a return are "return
;; moves".
;; A call allocation contains three pieces of information: the call's
;; /proc slot/, a set of /parallel moves/, and a /dead slot map/. The
;; proc slot indicates the slot of a procedure in a procedure call, or
;; where the procedure would be in a multiple-value return. The
;; parallel moves shuffle locals into position for a call, or shuffle
;; returned values back into place. Though they use the same slot,
;; moves for a call are called "call moves", and moves to handle a
;; return are "return moves". The dead slot map indicates, for a
;; call, what slots should be ignored by GC when marking the frame.
;;
;; $kreceive continuations record a proc slot and a set of return moves
;; to adapt multiple values from the stack to local variables.
;;
;; Tail calls record arg moves, but no proc slot.
;;
;; Non-tail calls record arg moves and a call slot. Multiple-valued
;; returns will have an associated $kreceive continuation, which records
;; the same proc slot, but has return moves.
;; Non-tail calls record arg moves, a call slot, and a dead slot map.
;; Multiple-valued returns will have an associated $kreceive
;; continuation, which records the same proc slot, but has return
;; moves and no dead slot map.
;;
;; $prompt handlers are $kreceive continuations like any other.
;;
;; $values expressions with more than 1 value record moves but have no
;; proc slot.
;; proc slot or dead slot map.
;;
;; A set of moves is expressed as an ordered list of (SRC . DST)
;; moves, where SRC and DST are slots. This may involve a temporary
;; variable.
;; variable. A dead slot map is a bitfield, as an integer.
;;
(call-allocations allocation-call-allocations)
@ -102,10 +105,11 @@
(nlocals allocation-nlocals))
(define-record-type $call-allocation
(make-call-allocation proc-slot moves)
(make-call-allocation proc-slot moves dead-slot-map)
call-allocation?
(proc-slot call-allocation-proc-slot)
(moves call-allocation-moves))
(moves call-allocation-moves)
(dead-slot-map call-allocation-dead-slot-map))
(define (find-first-zero n)
;; Naive implementation.
@ -162,6 +166,10 @@
(or (call-allocation-moves (lookup-call-allocation k allocation))
(error "Call has no use parallel moves slot" k)))
(define (lookup-dead-slot-map k allocation)
(or (call-allocation-dead-slot-map (lookup-call-allocation k allocation))
(error "Call has no dead slot map" k)))
(define (lookup-nlocals k allocation)
(or (hashq-ref (allocation-nlocals allocation) k)
(error "Not a clause continuation" k)))
@ -485,7 +493,7 @@ are comparable with eqv?. A tmp slot may be used."
(compute-tmp-slot pre-live tail-slots))))
(bump-nlocals! tail-nlocals)
(hashq-set! call-allocations label
(make-call-allocation #f moves))))
(make-call-allocation #f moves #f))))
(($ $kreceive arity kargs)
(let* ((proc-slot (compute-call-proc-slot post-live))
(call-slots (map (cut + proc-slot <>) (iota (length uses))))
@ -516,12 +524,14 @@ are comparable with eqv?. A tmp slot may be used."
(result-moves (parallel-move value-slots
result-slots
(compute-tmp-slot result-live
value-slots))))
value-slots)))
(dead-slot-map (logand (1- (ash 1 (- proc-slot 2)))
(lognot post-live))))
(bump-nlocals! (+ proc-slot (length uses)))
(hashq-set! call-allocations label
(make-call-allocation proc-slot arg-moves))
(make-call-allocation proc-slot arg-moves dead-slot-map))
(hashq-set! call-allocations k
(make-call-allocation proc-slot result-moves))))
(make-call-allocation proc-slot result-moves #f))))
(_
(let* ((proc-slot (compute-call-proc-slot post-live))
@ -533,7 +543,7 @@ are comparable with eqv?. A tmp slot may be used."
call-slots))))
(bump-nlocals! (+ proc-slot (length uses)))
(hashq-set! call-allocations label
(make-call-allocation proc-slot arg-moves))))))
(make-call-allocation proc-slot arg-moves #f))))))
(define (allocate-values label k uses pre-live post-live)
(match (vector-ref contv (cfa-k-idx cfa k))
@ -545,7 +555,7 @@ are comparable with eqv?. A tmp slot may be used."
(compute-tmp-slot pre-live dst-slots))))
(bump-nlocals! tail-nlocals)
(hashq-set! call-allocations label
(make-call-allocation #f moves))))
(make-call-allocation #f moves #f))))
(($ $kargs (_) (_))
;; When there is only one value in play, we allow the dst to be
;; hinted (see scan-for-hints). If the src doesn't have a
@ -566,7 +576,7 @@ are comparable with eqv?. A tmp slot may be used."
(compute-tmp-slot (logior pre-live result-live)
'()))))
(hashq-set! call-allocations label
(make-call-allocation #f moves))))
(make-call-allocation #f moves #f))))
(($ $kif) #f)))
(define (allocate-prompt label k handler nargs)
@ -590,7 +600,7 @@ are comparable with eqv?. A tmp slot may be used."
value-slots))))
(bump-nlocals! (+ proc-slot 1 (length result-vars)))
(hashq-set! call-allocations handler
(make-call-allocation proc-slot moves))))))
(make-call-allocation proc-slot moves #f))))))
(define (allocate-defs! n live)
(fold (cut allocate! <> #f <>) live (vector-ref defv n)))

118
module/system/vm/assembler.scm
View file

@ -1,6 +1,6 @@
;;; Guile bytecode assembler
;;; Copyright (C) 2001, 2009, 2010, 2012, 2013 Free Software Foundation, Inc.
;;; Copyright (C) 2001, 2009, 2010, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -189,7 +189,8 @@
word-size endianness
constants inits
shstrtab next-section-number
meta sources)
meta sources
dead-slot-maps)
asm?
;; We write bytecode into what is logically a growable vector,
@ -265,7 +266,14 @@
;; is relative to the beginning of the text section, and SOURCE is in
;; the same format that source-properties returns.
;;
(sources asm-sources set-asm-sources!))
(sources asm-sources set-asm-sources!)
;; A list of (pos . dead-slot-map) pairs, indicating dead slot maps.
;; POS is relative to the beginning of the text section.
;; DEAD-SLOT-MAP is a bitfield of slots that are dead at call sites,
;; as an integer.
;;
(dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
(define-inlinable (fresh-block)
(make-u32vector *block-size*))
@ -280,7 +288,7 @@ target."
word-size endianness
vlist-null '()
(make-string-table) 1
'() '()))
'() '() '()))
(define (intern-section-name! asm string)
"Add a string to the section name table (shstrtab)."
@ -828,6 +836,12 @@ returned instead."
(cell-label (intern-cache-cell asm key sym)))
(emit-module-box asm dst cell-label mod-name-label sym-label bound?)))
(define-macro-assembler (dead-slot-map asm proc-slot dead-slot-map)
(unless (zero? dead-slot-map)
(set-asm-dead-slot-maps! asm
(cons
(cons* (asm-start asm) proc-slot dead-slot-map)
(asm-dead-slot-maps asm)))))
@ -1193,6 +1207,67 @@ needed."
;;;
;;; Create the frame maps. These maps are used by GC to identify dead
;;; slots in pending call frames, to avoid marking them. We only do
;;; this when frame makes a non-tail call, as that is the common case.
;;; Only the topmost frame will see a GC at any other point, but we mark
;;; top frames conservatively as serializing live slot maps at every
;;; instruction would take up too much space in the object file.
;;;
;; The .guile.frame-maps section starts with two packed u32 values: one
;; indicating the offset of the first byte of the .rtl-text section, and
;; another indicating the relative offset in bytes of the slots data.
(define frame-maps-prefix-len 8)
;; Each header is 8 bytes: 4 for the offset from .rtl_text, and 4 for
;; the offset of the slot map from the beginning of the
;; .guile.frame-maps section. The length of a frame map depends on the
;; frame size at the call site, and is not encoded into this section as
;; it is available at run-time.
(define frame-map-header-len 8)
(define (link-frame-maps asm)
(define (map-byte-length proc-slot)
(ceiling-quotient (- proc-slot 2) 8))
(define (make-frame-maps maps count map-len)
(let* ((endianness (asm-endianness asm))
(header-pos frame-maps-prefix-len)
(map-pos (+ header-pos (* count frame-map-header-len)))
(bv (make-bytevector (+ map-pos map-len) 0)))
(bytevector-u32-set! bv 4 map-pos endianness)
(let lp ((maps maps) (header-pos header-pos) (map-pos map-pos))
(match maps
(()
(make-object asm '.guile.frame-maps bv
(list (make-linker-reloc 'abs32/1 0 0 '.rtl-text))
'() #:type SHT_PROGBITS #:flags SHF_ALLOC))
(((pos proc-slot . map) . maps)
(bytevector-u32-set! bv header-pos (* pos 4) endianness)
(bytevector-u32-set! bv (+ header-pos 4) map-pos endianness)
(let write-bytes ((map-pos map-pos)
(map map)
(byte-length (map-byte-length proc-slot)))
(if (zero? byte-length)
(lp maps (+ header-pos frame-map-header-len) map-pos)
(begin
(bytevector-u8-set! bv map-pos (logand map #xff))
(write-bytes (1+ map-pos) (ash map -8)
(1- byte-length))))))))))
(match (asm-dead-slot-maps asm)
(() #f)
(in
(let lp ((in in) (out '()) (count 0) (map-len 0))
(match in
(() (make-frame-maps out count map-len))
(((and head (pos proc-slot . map)) . in)
(lp in (cons head out)
(1+ count)
(+ (map-byte-length proc-slot) map-len))))))))
;;;
;;; Linking other sections of the ELF file, like the dynamic segment,
;;; the symbol table, etc.
@ -1202,14 +1277,18 @@ needed."
(define *bytecode-major-version* #x0202)
(define *bytecode-minor-version* 3)
(define (link-dynamic-section asm text rw rw-init)
(define (link-dynamic-section asm text rw rw-init frame-maps)
"Link the dynamic section for an ELF image with bytecode @var{text},
given the writable data section @var{rw} needing fixup from the
procedure with label @var{rw-init}. @var{rw-init} may be false. If
@var{rw} is true, it will be added to the GC roots at runtime."
(define-syntax-rule (emit-dynamic-section word-size %set-uword! reloc-type)
(let* ((endianness (asm-endianness asm))
(bv (make-bytevector (* word-size (if rw (if rw-init 12 10) 6)) 0))
(words 6)
(words (if rw (+ words 4) words))
(words (if rw-init (+ words 2) words))
(words (if frame-maps (+ words 2) words))
(bv (make-bytevector (* word-size words) 0))
(set-uword!
(lambda (i uword)
(%set-uword! bv (* i word-size) uword endianness)))
@ -1225,25 +1304,20 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
*bytecode-minor-version*))
(set-uword! 2 DT_GUILE_ENTRY)
(set-label! 3 '.rtl-text)
(cond
(rw
(when rw
;; Add roots to GC.
(set-uword! 4 DT_GUILE_GC_ROOT)
(set-label! 5 '.data)
(set-uword! 6 DT_GUILE_GC_ROOT_SZ)
(set-uword! 7 (bytevector-length (linker-object-bv rw)))
(cond
(rw-init
(when rw-init
(set-uword! 8 DT_INIT) ; constants
(set-label! 9 rw-init)
(set-uword! 10 DT_NULL)
(set-uword! 11 0))
(else
(set-uword! 8 DT_NULL)
(set-uword! 9 0))))
(else
(set-uword! 4 DT_NULL)
(set-uword! 5 0)))
(set-label! 9 rw-init)))
(when frame-maps
(set-uword! (- words 4) DT_GUILE_FRAME_MAPS)
(set-label! (- words 3) '.guile.frame-maps))
(set-uword! (- words 2) DT_NULL)
(set-uword! (- words 1) 0)
(make-object asm '.dynamic bv relocs '()
#:type SHT_DYNAMIC #:flags SHF_ALLOC)))
(case (asm-word-size asm)
@ -1969,7 +2043,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
;; Link text object after constants, so that the
;; constants initializer gets included.
((text) (link-text-object asm))
((dt) (link-dynamic-section asm text rw rw-init))
((frame-maps) (link-frame-maps asm))
((dt) (link-dynamic-section asm text rw rw-init frame-maps))
((symtab strtab) (link-symtab (linker-object-section text) asm))
((arities arities-strtab) (link-arities asm))
((docstrs docstrs-strtab) (link-docstrs asm))
@ -1978,7 +2053,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If
;; sections adds entries to the string table.
((shstrtab) (link-shstrtab asm)))
(filter identity
(list text ro rw dt symtab strtab arities arities-strtab
(list text ro frame-maps rw dt symtab strtab
arities arities-strtab
docstrs docstrs-strtab procprops
dinfo dabbrev dstrtab dloc dline
shstrtab))))

7
module/system/vm/elf.scm
View file

@ -1,6 +1,6 @@
;;; Guile ELF reader and writer
;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -105,8 +105,8 @@
DT_FINI_ARRAYSZ DT_RUNPATH DT_FLAGS DT_ENCODING
DT_PREINIT_ARRAY DT_PREINIT_ARRAYSZ DT_NUM DT_LOGUILE
DT_GUILE_GC_ROOT DT_GUILE_GC_ROOT_SZ DT_GUILE_ENTRY
DT_GUILE_VM_VERSION DT_HIGUILE DT_LOOS DT_HIOS DT_LOPROC
DT_HIPROC
DT_GUILE_VM_VERSION DT_GUILE_FRAME_MAPS DT_HIGUILE
DT_LOOS DT_HIOS DT_LOPROC DT_HIPROC
string-table-ref
@ -781,6 +781,7 @@
(define DT_GUILE_GC_ROOT_SZ #x37146001) ; Size in machine words of GC roots
(define DT_GUILE_ENTRY #x37146002) ; Address of entry thunk
(define DT_GUILE_VM_VERSION #x37146003) ; Bytecode version
(define DT_GUILE_FRAME_MAPS #x37146004) ; Offset of .guile.frame-maps
(define DT_HIGUILE #x37146fff) ; End of Guile-specific
(define DT_LOOS #x6000000d) ; Start of OS-specific
(define DT_HIOS #x6ffff000) ; End of OS-specific