mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
VM support for raw slots
* libguile/loader.c (scm_find_slot_map_unlocked): Rename from scm_find_dead_slot_map_unlocked. * libguile/vm.c (struct slot_map_cache_entry, struct slot_map_cache) (find_slot_map): Rename, changing "dead_slot" to "slot". (enum slot_desc): New type. (scm_i_vm_mark_stack): Interpret slot maps as having two bits per slot, allowing us to indicate that a slot is live but not a pointer. * module/language/cps/compile-bytecode.scm (compile-function): Adapt to emit-slot-map name change. * module/system/vm/assembler.scm (<asm>): Rename dead-slot-maps field to slot-maps. (emit-slot-map): Rename from emit-dead-slot-map. (link-frame-maps): 2 bits per slot. * module/language/cps/slot-allocation.scm (lookup-slot-map): Rename from lookup-dead-slot-map. (compute-var-representations): New function. (allocate-slots): Adapt to encode two-bit slot representations.
This commit is contained in:
Andy Wingo
parent
dd77a818ba
commit
e7660a607c
7 changed files with 139 additions and 64 deletions
|
|
@ -427,6 +427,10 @@ A table mapping addresses in the @code{.rtl-text} to procedure names.
|
|||
@itemx .guile.docstrs
|
||||
@itemx .guile.docstrs.strtab
|
||||
Side tables of procedure properties, arities, and docstrings.
|
||||
@item .guile.docstrs.strtab
|
||||
Side table of frame maps, describing the set of live slots for ever
|
||||
return point in the program text, and whether those slots are pointers
|
||||
are not. Used by the garbage collector.
|
||||
@item .debug_info
|
||||
@itemx .debug_abbrev
|
||||
@itemx .debug_str
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
/* Copyright (C) 2001, 2009, 2010, 2011, 2012
|
||||
* 2013, 2014 Free Software Foundation, Inc.
|
||||
* 2013, 2014, 2015 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
|
||||
|
|
@ -748,7 +748,7 @@ 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)
|
||||
scm_find_slot_map_unlocked (const scm_t_uint32 *ip)
|
||||
{
|
||||
struct mapped_elf_image *image;
|
||||
char *base;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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
|
||||
|
|
@ -25,7 +25,7 @@ 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_find_slot_map_unlocked (const scm_t_uint32 *ip);
|
||||
|
||||
SCM_INTERNAL void scm_bootstrap_loader (void);
|
||||
SCM_INTERNAL void scm_init_loader (void);
|
||||
|
|
|
|||
|
|
@ -895,31 +895,31 @@ return_unused_stack_to_os (struct scm_vm *vp)
|
|||
#endif
|
||||
}
|
||||
|
||||
#define DEAD_SLOT_MAP_CACHE_SIZE 32U
|
||||
struct dead_slot_map_cache_entry
|
||||
#define SLOT_MAP_CACHE_SIZE 32U
|
||||
struct slot_map_cache_entry
|
||||
{
|
||||
scm_t_uint32 *ip;
|
||||
const scm_t_uint8 *map;
|
||||
};
|
||||
|
||||
struct dead_slot_map_cache
|
||||
struct slot_map_cache
|
||||
{
|
||||
struct dead_slot_map_cache_entry entries[DEAD_SLOT_MAP_CACHE_SIZE];
|
||||
struct slot_map_cache_entry entries[SLOT_MAP_CACHE_SIZE];
|
||||
};
|
||||
|
||||
static const scm_t_uint8 *
|
||||
find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache)
|
||||
find_slot_map (scm_t_uint32 *ip, struct slot_map_cache *cache)
|
||||
{
|
||||
/* The lower two bits should be zero. FIXME: Use a better hash
|
||||
function; we don't expose scm_raw_hashq currently. */
|
||||
size_t slot = (((scm_t_uintptr) ip) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE;
|
||||
size_t slot = (((scm_t_uintptr) ip) >> 2) % SLOT_MAP_CACHE_SIZE;
|
||||
const scm_t_uint8 *map;
|
||||
|
||||
if (cache->entries[slot].ip == ip)
|
||||
map = cache->entries[slot].map;
|
||||
else
|
||||
{
|
||||
map = scm_find_dead_slot_map_unlocked (ip);
|
||||
map = scm_find_slot_map_unlocked (ip);
|
||||
cache->entries[slot].ip = ip;
|
||||
cache->entries[slot].map = map;
|
||||
}
|
||||
|
|
@ -927,21 +927,29 @@ find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache)
|
|||
return map;
|
||||
}
|
||||
|
||||
enum slot_desc
|
||||
{
|
||||
SLOT_DESC_DEAD = 0,
|
||||
SLOT_DESC_LIVE_RAW = 1,
|
||||
SLOT_DESC_LIVE_SCM = 2,
|
||||
SLOT_DESC_UNUSED = 3
|
||||
};
|
||||
|
||||
/* Mark the active VM stack region. */
|
||||
struct GC_ms_entry *
|
||||
scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
|
||||
struct GC_ms_entry *mark_stack_limit)
|
||||
{
|
||||
union scm_vm_stack_element *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;
|
||||
/* The first frame will be marked conservatively (without a 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 slot maps for all points in a program would take a
|
||||
prohibitive amount of space. */
|
||||
const scm_t_uint8 *slot_map = NULL;
|
||||
void *upper = (void *) GC_greatest_plausible_heap_addr;
|
||||
void *lower = (void *) GC_least_plausible_heap_addr;
|
||||
struct dead_slot_map_cache cache;
|
||||
struct slot_map_cache cache;
|
||||
|
||||
memset (&cache, 0, sizeof (cache));
|
||||
|
||||
|
|
@ -953,24 +961,29 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
|
|||
size_t slot = nlocals - 1;
|
||||
for (slot = nlocals - 1; sp < fp; sp++, slot--)
|
||||
{
|
||||
enum slot_desc desc = SLOT_DESC_LIVE_SCM;
|
||||
|
||||
if (slot_map)
|
||||
desc = (slot_map[slot / 4U] >> ((slot % 4U) * 2)) & 3U;
|
||||
|
||||
switch (desc)
|
||||
{
|
||||
case SLOT_DESC_LIVE_RAW:
|
||||
break;
|
||||
case SLOT_DESC_UNUSED:
|
||||
case SLOT_DESC_LIVE_SCM:
|
||||
if (SCM_NIMP (sp->as_scm) &&
|
||||
sp->as_ptr >= lower && sp->as_ptr <= upper)
|
||||
{
|
||||
if (dead_slots)
|
||||
{
|
||||
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->as_scm = SCM_UNSPECIFIED;
|
||||
continue;
|
||||
}
|
||||
}
|
||||
|
||||
mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
|
||||
mark_stack_ptr,
|
||||
mark_stack_limit,
|
||||
NULL);
|
||||
break;
|
||||
case SLOT_DESC_DEAD:
|
||||
/* This value may become dead as a result of GC,
|
||||
so we can't just leave it on the stack. */
|
||||
sp->as_scm = SCM_UNSPECIFIED;
|
||||
break;
|
||||
}
|
||||
}
|
||||
sp = SCM_FRAME_PREVIOUS_SP (fp);
|
||||
|
|
@ -978,7 +991,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr,
|
|||
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 = find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache);
|
||||
slot_map = find_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache);
|
||||
}
|
||||
|
||||
return_unused_stack_to_os (vp);
|
||||
|
|
|
|||
|
|
@ -379,8 +379,7 @@
|
|||
((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
|
||||
(lookup-parallel-moves label allocation))
|
||||
(emit-call asm proc-slot nargs)
|
||||
(emit-dead-slot-map asm proc-slot
|
||||
(lookup-dead-slot-map label allocation))
|
||||
(emit-slot-map asm proc-slot (lookup-slot-map label allocation))
|
||||
(cond
|
||||
((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var))
|
||||
(match (lookup-parallel-moves k allocation)
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@
|
|||
lookup-nlocals
|
||||
lookup-call-proc-slot
|
||||
lookup-parallel-moves
|
||||
lookup-dead-slot-map))
|
||||
lookup-slot-map))
|
||||
|
||||
(define-record-type $allocation
|
||||
(make-allocation slots constant-values call-allocs shuffles frame-sizes)
|
||||
|
|
@ -84,10 +84,10 @@
|
|||
(frame-sizes allocation-frame-sizes))
|
||||
|
||||
(define-record-type $call-alloc
|
||||
(make-call-alloc proc-slot dead-slot-map)
|
||||
(make-call-alloc proc-slot slot-map)
|
||||
call-alloc?
|
||||
(proc-slot call-alloc-proc-slot)
|
||||
(dead-slot-map call-alloc-dead-slot-map))
|
||||
(slot-map call-alloc-slot-map))
|
||||
|
||||
(define (lookup-maybe-slot var allocation)
|
||||
(intmap-ref (allocation-slots allocation) var (lambda (_) #f)))
|
||||
|
|
@ -121,9 +121,9 @@
|
|||
(define (lookup-parallel-moves k allocation)
|
||||
(intmap-ref (allocation-shuffles allocation) k))
|
||||
|
||||
(define (lookup-dead-slot-map k allocation)
|
||||
(or (call-alloc-dead-slot-map (lookup-call-alloc k allocation))
|
||||
(error "Call has no dead slot map" k)))
|
||||
(define (lookup-slot-map k allocation)
|
||||
(or (call-alloc-slot-map (lookup-call-alloc k allocation))
|
||||
(error "Call has no slot map" k)))
|
||||
|
||||
(define (lookup-nlocals k allocation)
|
||||
(intmap-ref (allocation-frame-sizes allocation) k))
|
||||
|
|
@ -764,8 +764,52 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(persistent-intmap
|
||||
(intmap-fold-right allocate-lazy cps slots)))
|
||||
|
||||
(define (compute-var-representations cps)
|
||||
(define (get-defs k)
|
||||
(match (intmap-ref cps k)
|
||||
(($ $kargs names vars) vars)
|
||||
(_ '())))
|
||||
(intmap-fold
|
||||
(lambda (label cont representations)
|
||||
(match cont
|
||||
(($ $kargs _ _ ($ $continue k _ exp))
|
||||
(match (get-defs k)
|
||||
(() representations)
|
||||
((var)
|
||||
(match exp
|
||||
(($ $values (arg))
|
||||
(intmap-add representations var
|
||||
(intmap-ref representations arg)))
|
||||
;; FIXME: Placeholder for as-yet-unwritten primitive
|
||||
;; operations that define unboxed f64 values.
|
||||
(($ $primcall 'scm->f64)
|
||||
(intmap-add representations var 'f64))
|
||||
(_
|
||||
(intmap-add representations var 'scm))))
|
||||
(vars
|
||||
(match exp
|
||||
(($ $values args)
|
||||
(fold (lambda (arg var representations)
|
||||
(intmap-add representations var
|
||||
(intmap-ref representations arg)))
|
||||
representations args vars))))))
|
||||
(($ $kfun src meta self)
|
||||
(intmap-add representations self 'scm))
|
||||
(($ $kclause arity body alt)
|
||||
(fold1 (lambda (var representations)
|
||||
(intmap-add representations var 'scm))
|
||||
(get-defs body) representations))
|
||||
(($ $kreceive arity kargs)
|
||||
(fold1 (lambda (var representations)
|
||||
(intmap-add representations var 'scm))
|
||||
(get-defs kargs) representations))
|
||||
(($ $ktail) representations)))
|
||||
cps
|
||||
empty-intmap))
|
||||
|
||||
(define (allocate-slots cps)
|
||||
(let*-values (((defs uses) (compute-defs-and-uses cps))
|
||||
((representations) (compute-var-representations cps))
|
||||
((live-in live-out) (compute-live-variables cps defs uses))
|
||||
((constants) (compute-constant-values cps))
|
||||
((needs-slot) (compute-needs-slot cps defs uses))
|
||||
|
|
@ -809,6 +853,23 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(define (compute-live-out-slots slots label)
|
||||
(compute-live-slots* slots label live-out))
|
||||
|
||||
(define slot-desc-dead 0)
|
||||
(define slot-desc-live-raw 1)
|
||||
(define slot-desc-live-scm 2)
|
||||
(define slot-desc-unused 3)
|
||||
|
||||
(define (compute-slot-map slots live-vars nslots)
|
||||
(intset-fold
|
||||
(lambda (var slot-map)
|
||||
(match (get-slot slots var)
|
||||
(#f slot-map)
|
||||
(slot
|
||||
(let ((desc (match (intmap-ref representations var)
|
||||
('f64 slot-desc-live-raw)
|
||||
('scm slot-desc-live-scm))))
|
||||
(logior slot-map (ash desc (* 2 slot)))))))
|
||||
live-vars 0))
|
||||
|
||||
(define (allocate var hint slots live)
|
||||
(cond
|
||||
((not (intset-ref needs-slot var))
|
||||
|
|
@ -874,9 +935,9 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(let ((result-slots (integers (+ proc-slot 2)
|
||||
(length results))))
|
||||
(allocate* results result-slots slots post-live)))))
|
||||
((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
|
||||
(lognot post-live)))
|
||||
((call) (make-call-alloc proc-slot dead-slot-map)))
|
||||
((slot-map) (compute-slot-map slots (intmap-ref live-out label)
|
||||
(- proc-slot 2)))
|
||||
((call) (make-call-alloc proc-slot slot-map)))
|
||||
(values slots
|
||||
(intmap-add! call-allocs label call))))))
|
||||
|
||||
|
|
@ -909,8 +970,8 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
(let*-values
|
||||
(((handler-live) (compute-live-in-slots slots handler))
|
||||
((proc-slot) (compute-prompt-handler-proc-slot handler-live))
|
||||
((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2)))
|
||||
(lognot handler-live)))
|
||||
((slot-map) (compute-slot-map slots (intmap-ref live-in handler)
|
||||
(- proc-slot 2)))
|
||||
((result-vars) (match (get-cont kargs)
|
||||
(($ $kargs names vars) vars)))
|
||||
((value-slots) (integers (1+ proc-slot) (length result-vars)))
|
||||
|
|
@ -918,7 +979,7 @@ are comparable with eqv?. A tmp slot may be used."
|
|||
slots handler-live)))
|
||||
(values slots
|
||||
(intmap-add! call-allocs label
|
||||
(make-call-alloc proc-slot dead-slot-map)))))))
|
||||
(make-call-alloc proc-slot slot-map)))))))
|
||||
|
||||
(define (allocate-cont label cont slots call-allocs)
|
||||
(match cont
|
||||
|
|
|
|||
|
|
@ -326,7 +326,7 @@
|
|||
constants inits
|
||||
shstrtab next-section-number
|
||||
meta sources
|
||||
dead-slot-maps)
|
||||
slot-maps)
|
||||
asm?
|
||||
|
||||
;; We write bytecode into what is logically a growable vector,
|
||||
|
|
@ -404,12 +404,11 @@
|
|||
;;
|
||||
(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.
|
||||
;; A list of (pos . slot-map) pairs, indicating slot maps. POS is
|
||||
;; relative to the beginning of the text section. SLOT-MAP is a
|
||||
;; bitfield describing the stack at call sites, as an integer.
|
||||
;;
|
||||
(dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!))
|
||||
(slot-maps asm-slot-maps set-asm-slot-maps!))
|
||||
|
||||
(define-inline (fresh-block)
|
||||
(make-u32vector *block-size*))
|
||||
|
|
@ -1187,12 +1186,11 @@ 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)))))
|
||||
(define-macro-assembler (slot-map asm proc-slot slot-map)
|
||||
(unless (zero? slot-map)
|
||||
(set-asm-slot-maps! asm (cons
|
||||
(cons* (asm-start asm) proc-slot slot-map)
|
||||
(asm-slot-maps asm)))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -1605,7 +1603,7 @@ needed."
|
|||
|
||||
(define (link-frame-maps asm)
|
||||
(define (map-byte-length proc-slot)
|
||||
(ceiling-quotient (- proc-slot 2) 8))
|
||||
(ceiling-quotient (* 2 (- proc-slot 2)) 8))
|
||||
(define (make-frame-maps maps count map-len)
|
||||
(let* ((endianness (asm-endianness asm))
|
||||
(header-pos frame-maps-prefix-len)
|
||||
|
|
@ -1630,7 +1628,7 @@ needed."
|
|||
(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)
|
||||
(match (asm-slot-maps asm)
|
||||
(() #f)
|
||||
(in
|
||||
(let lp ((in in) (out '()) (count 0) (map-len 0))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue