[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-618-g02c624f
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-618-g02c624f |
|
Date: |
Sun, 26 Jan 2014 19:56:06 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=02c624fc09079491660317977a5f202ecc2b1fc8
The branch, master has been updated
via 02c624fc09079491660317977a5f202ecc2b1fc8 (commit)
from b3f1bb5d31a85447c4e7f6084a4f8d7ea374bdbe (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 02c624fc09079491660317977a5f202ecc2b1fc8
Author: Andy Wingo <address@hidden>
Date: Sun Jan 26 20:55:04 2014 +0100
More precise stack marking via .guile.frame-maps section
* 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.
-----------------------------------------------------------------------
Summary of changes:
libguile/loader.c | 140 +++++++++++++++++++++++++-----
libguile/loader.h | 5 +-
libguile/vm.c | 35 +++++++-
module/language/cps/compile-bytecode.scm | 2 +
module/language/cps/slot-allocation.scm | 58 +++++++-----
module/system/vm/assembler.scm | 118 +++++++++++++++++++++-----
module/system/vm/elf.scm | 7 +-
7 files changed, 291 insertions(+), 74 deletions(-)
diff --git a/libguile/loader.c b/libguile/loader.c
index ce56991..83c5bb5 100644
--- a/libguile/loader.c
+++ b/libguile/loader.c
@@ -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,37 +640,49 @@ 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);
@@ -666,6 +690,22 @@ scm_find_mapped_elf_image (SCM ip)
}
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)
{
SCM result = SCM_EOL;
@@ -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)
diff --git a/libguile/loader.h b/libguile/loader.h
index 194faff..6fd9502 100644
--- a/libguile/loader.h
+++ b/libguile/loader.h
@@ -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);
diff --git a/libguile/vm.c b/libguile/vm.c
index 5a69589..43ade82 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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;
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index e5c6ef8..adc5159 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -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)
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 946257b..a4e5129 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -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)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index e8eba30..e040314 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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)))))
@@ -1194,6 +1208,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))))
diff --git a/module/system/vm/elf.scm b/module/system/vm/elf.scm
index 2fe99ba..ec89d4f 100644
--- a/module/system/vm/elf.scm
+++ b/module/system/vm/elf.scm
@@ -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
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-618-g02c624f,
Andy Wingo <=