steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

generational gc and compiler relocation fixes

cvs
Slava Pestov 2005-05-13 22:27:18 +00:00
parent 41b5a344b8
commit 3b5855a195
17 changed files with 133 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
TODO.FACTOR.txt
View File

@ -6,6 +6,10 @@
<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html
<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup
- simplifier:
- dead loads not optimized out
- kill tag-fixnum/untag-fixnum
- \ foo where foo is parsing is not printed readably
- faster layout
- tiled window manager
- c primitive arrays: or just specialized arrays
@ -17,6 +21,8 @@
- sleep word
- update docs
- redo new compiler backend for PowerPC
- type predicates: : foo? type 7 eq? ;
- remove 'not' word, and move t?/f? to kernel
- plugin: supportsBackspace
- if external factor is down, don't add tons of random shit to the

6
library/compiler/compiler.factor
View File

@ -13,7 +13,7 @@ kernel lists namespaces prettyprint stdio words ;
: compiling ( word -- word parameter )
check-architecture
"Compiling " write dup . flush
"Compiling " write dup word. terpri flush
dup word-def ;
GENERIC: (compile) ( word -- )
@ -43,7 +43,7 @@ M: compound (compile) ( word -- )
"compile" get [ word compile ] when ; parsing
: cannot-compile ( word error -- )
"Cannot compile " write swap . print-error ;
"Cannot compile " write swap word. terpri print-error ;
: try-compile ( word -- )
[ compile ] [ [ cannot-compile ] when* ] catch ;
@ -52,7 +52,7 @@ M: compound (compile) ( word -- )
: decompile ( word -- )
dup compiled? [
"Decompiling " write dup . flush
"Decompiling " write dup word. terpri flush
[ word-primitive ] keep set-word-primitive
] [
drop

6
library/compiler/ppc/alien.factor
View File

@ -5,7 +5,7 @@ USING: alien compiler inference kernel kernel-internals lists
math memory namespaces words ;
\ alien-invoke [
uncons load-library 2dup rel-dlsym-16/16 dlsym compile-call-far
uncons load-library 2dup 1 rel-dlsym dlsym compile-call-far
] "generator" set-word-prop
: stack-size 8 + 16 align ;
@ -16,7 +16,7 @@ math memory namespaces words ;
] "generator" set-word-prop
#unbox [
uncons f 2dup rel-dlsym-16/16 dlsym compile-call-far
uncons f 2dup 1 rel-dlsym dlsym compile-call-far
3 1 rot stack@ STW
] "generator" set-word-prop
@ -25,7 +25,7 @@ math memory namespaces words ;
] "generator" set-word-prop
#box [
f 2dup rel-dlsym-16/16 dlsym compile-call-far
f 2dup 1 rel-dlsym dlsym compile-call-far
] "generator" set-word-prop
#cleanup [

8
library/compiler/ppc/generator.factor
View File

@ -46,14 +46,14 @@ words ;
: compile-call-label ( label -- )
dup primitive? [
dup rel-primitive-16/16 word-xt compile-call-far
dup 1 rel-primitive word-xt compile-call-far
] [
0 BL relative-24
] ifte ;
#call-label [
! Hack: length of instruction sequence that follows
rel-address-16/16 compiled-offset 20 + 18 LOAD32
0 1 rel-address compiled-offset 20 + 18 LOAD32
1 1 -16 STWU
18 1 20 STW
0 B relative-24
@ -66,7 +66,7 @@ words ;
: compile-jump-label ( label -- )
dup primitive? [
dup rel-primitive-16/16 word-xt compile-jump-far
dup 1 rel-primitive word-xt compile-jump-far
] [
0 B relative-24
] ifte ;
@ -94,7 +94,7 @@ words ;
18 18 1 SRAWI
! The value 24 is a magic number. It is the length of the
! instruction sequence that follows to be generated.
rel-address-16/16 compiled-offset 24 + 19 LOAD32
0 1 rel-address compiled-offset 24 + 19 LOAD32
18 18 19 ADD
18 18 0 LWZ
18 MTLR

34
library/compiler/relocate.factor
View File

@ -11,34 +11,20 @@ SYMBOL: relocation-table
: relocating compiled-offset cell - rel, ;
: rel-primitive ( word rel/abs -- )
#! If flag is true; relative.
0 1 ? rel, relocating word-primitive rel, ;
: rel-type, ( rel/abs 16/16 type -- )
swap 8 shift bitor swap 16 shift bitor rel, ;
: rel-dlsym ( name dll rel/abs -- )
#! If flag is true; relative.
2 3 ? rel, relocating cons intern-literal rel, ;
: rel-primitive ( word relative 16/16 -- )
0 rel-type, relocating word-primitive rel, ;
: rel-address ( rel/abs -- )
: rel-dlsym ( name dll rel/abs 16/16 -- )
1 rel-type, relocating cons intern-literal rel, ;
: rel-address ( rel/abs 16/16 -- )
#! Relocate address just compiled. If flag is true,
#! relative, and there is nothing to do.
[ 4 rel, relocating 0 rel, ] unless ;
over [ 2drop ] [ 2 rel-type, relocating 0 rel, ] ifte ;
: rel-word ( word rel/abs -- )
: rel-word ( word rel/abs 16/16 -- )
#! If flag is true; relative.
over primitive? [ rel-primitive ] [ nip rel-address ] ifte ;
! PowerPC relocations
: rel-primitive-16/16 ( word -- )
#! This is called before a sequence like
#! 19 LOAD32
#! 19 MTCTR
#! BCTR
5 rel, compiled-offset rel, word-primitive rel, ;
: rel-dlsym-16/16 ( name dll -- )
6 rel, compiled-offset rel, cons intern-literal rel, ;
: rel-address-16/16 ( -- )
7 rel, compiled-offset rel, 0 rel, ;

4
library/compiler/x86/generator.factor
View File

@ -15,7 +15,7 @@ M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
M: %prologue generate-node drop ;
: compile-c-call ( symbol dll -- )
2dup dlsym CALL t rel-dlsym ;
2dup dlsym CALL 1 0 rel-dlsym ;
M: %call generate-node ( vop -- )
vop-label dup postpone-word CALL ;
@ -58,7 +58,7 @@ M: %dispatch generate-node ( vop -- )
! Multiply by 4 to get a jump table offset
dup 2 SHL
! Add to jump table base
dup HEX: ffff ADD just-compiled >r f rel-address
dup HEX: ffff ADD just-compiled >r 0 0 rel-address
! Jump to jump table entry
unit JMP
! Align for better performance

4
library/compiler/x86/stack.factor
View File

@ -7,7 +7,7 @@ memory sequences words ;
: rel-cs ( -- )
#! Add an entry to the relocation table for the 32-bit
#! immediate just compiled.
"cs" f f rel-dlsym ;
"cs" f 0 0 rel-dlsym ;
: CS ( -- [ address ] ) "cs" f dlsym unit ;
: CS> ( register -- ) CS MOV rel-cs ;
@ -34,7 +34,7 @@ M: %immediate-d generate-node ( vop -- )
vop-literal [ ESI ] swap address MOV ;
: load-indirect ( dest literal -- )
intern-literal unit MOV f rel-address ;
intern-literal unit MOV 0 0 rel-address ;
M: %indirect generate-node ( vop -- )
#! indirect load of a literal through a table

4
library/compiler/xt.factor
View File

@ -49,7 +49,7 @@ TUPLE: relative word where to ;
: just-compiled compiled-offset 4 - ;
C: relative ( word -- )
over t rel-word
over 1 0 rel-word
[ set-relative-word ] keep
[ just-compiled swap set-relative-where ] keep
[ compiled-offset swap set-relative-to ] keep ;
@ -71,7 +71,7 @@ C: absolute ( word -- )
[ just-compiled swap set-absolute-where ] keep ;
: absolute ( word -- )
dup f rel-word <absolute> deferred-xt ;
dup 0 0 rel-word <absolute> deferred-xt ;
: >absolute dup absolute-word compiled-xt swap absolute-where ;

2
library/generic/tuple.factor
View File

@ -16,7 +16,7 @@ hashtables errors sequences vectors ;
#! Internal allocation function. Do not call it directly,
#! since you can fool the runtime and corrupt memory by
#! specifying an incorrect size.
<tuple> [ 0 swap set-array-nth ] keep ;
<tuple> [ 2 set-slot ] keep ;
: class-tuple 2 slot ; inline

19
library/test/benchmark/fib.factor
View File

@ -4,6 +4,10 @@ USE: kernel
USE: math
USE: test
USE: math-internals
USE: namespaces
! Four fibonacci implementations, each one slower than the
! previous.
: fixnum-fib ( n -- nth fibonacci number )
dup 1 fixnum<= [
@ -36,3 +40,18 @@ TUPLE: box i ;
] ifte ; compiled
[ << box f 9227465 >> ] [ << box f 34 >> tuple-fib ] unit-test
SYMBOL: n
: namespace-fib ( n -- n )
[
n set
n get 1 <= [
1
] [
n get 1 - namespace-fib
n get 2 - namespace-fib
+
] ifte
] with-scope ; compiled
[ 9227465 ] [ 34 namespace-fib ] unit-test

4
library/test/test.factor
View File

@ -87,7 +87,7 @@ SYMBOL: failures
"buffer" ,
] when
cpu "unknown" = "compile" get and [
cpu "unknown" = not "compile" get and [
[
"io/buffer" "compiler/optimizer"
"compiler/simple"
@ -95,7 +95,7 @@ SYMBOL: failures
"compiler/generic" "compiler/bail-out"
"compiler/linearizer" "compiler/intrinsics"
] %
] unless
] when
[
"benchmark/empty-loop" "benchmark/fac"

7
native/cards.c
View File

@ -18,6 +18,8 @@ INLINE void collect_card(CARD *ptr, CELL here)
while(card_scan < card_end && card_scan < here)
card_scan = collect_next(card_scan);
cards_scanned++;
}
INLINE void collect_gen_cards(CELL gen)
@ -48,8 +50,9 @@ void unmark_cards(CELL from, CELL to)
void clear_cards(CELL from, CELL to)
{
CARD *ptr = ADDR_TO_CARD(generations[from].base);
CARD *last_card = ADDR_TO_CARD(generations[to].limit);
/* NOTE: reverse order due to heap layout. */
CARD *last_card = ADDR_TO_CARD(generations[from].limit);
CARD *ptr = ADDR_TO_CARD(generations[to].base);
for(; ptr < last_card; ptr++)
clear_card(ptr);
}

4
native/debug.c
View File

@ -274,10 +274,10 @@ void factorbug(void)
else if(strcmp(cmd,"i") == 0)
{
fprintf(stderr,"Call frame:\n");
dump_cell(callframe);
print_obj(callframe);
fprintf(stderr,"\n");
fprintf(stderr,"Executing:\n");
dump_cell(executing);
print_obj(executing);
fprintf(stderr,"\n");
}
else if(strcmp(cmd,"e") == 0)

67
native/gc.c
View File

@ -44,7 +44,7 @@ void init_arena(CELL young_size, CELL aging_size)
for(i = GC_GENERATIONS - 2; i >= 0; i--)
alloter = init_zone(&generations[i],young_size,alloter);
clear_cards(TENURED,NURSERY);
clear_cards(NURSERY,TENURED);
if(alloter != heap_start + total_size)
fatal_error("Oops",alloter);
@ -52,6 +52,8 @@ void init_arena(CELL young_size, CELL aging_size)
allot_profiling = false;
heap_scan = false;
gc_time = 0;
minor_collections = 0;
cards_scanned = 0;
}
void collect_roots(void)
@ -78,18 +80,6 @@ void collect_roots(void)
copy_handle(&userenv[i]);
}
/* follow a chain of forwarding pointers */
CELL resolve_forwarding(CELL untagged, CELL tag)
{
CELL header = get(untagged);
/* another forwarding pointer */
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
/* we've found the destination */
else
return RETAG(untagged,tag);
}
/* Given a pointer to oldspace, copy it to newspace. */
INLINE void *copy_untagged_object(void *pointer, CELL size)
{
@ -103,12 +93,7 @@ INLINE void *copy_untagged_object(void *pointer, CELL size)
INLINE CELL copy_object_impl(CELL pointer)
{
CELL newpointer;
if(pointer < collecting_generation)
critical_error("asked to copy object outside collected generation",pointer);
newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
CELL newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
object_size(pointer));
/* install forwarding pointer */
@ -117,6 +102,23 @@ INLINE CELL copy_object_impl(CELL pointer)
return newpointer;
}
/* follow a chain of forwarding pointers */
CELL resolve_forwarding(CELL untagged, CELL tag)
{
CELL header = get(untagged);
/* another forwarding pointer */
if(TAG(header) == GC_COLLECTED)
return resolve_forwarding(UNTAG(header),tag);
/* we've found the destination */
else
{
CELL pointer = RETAG(untagged,tag);
if(should_copy(untagged))
pointer = RETAG(copy_object_impl(pointer),tag);
return pointer;
}
}
/*
Given a pointer to a tagged pointer to oldspace, copy it to newspace.
If the object has already been copied, return the forwarding
@ -202,7 +204,8 @@ void reset_generations(CELL from, CELL to)
void begin_gc(CELL gen)
{
collecting_generation = generations[gen].base;
collecting_gen = gen;
collecting_gen_start = generations[gen].base;
if(gen == TENURED)
{
@ -234,7 +237,12 @@ void end_gc(CELL gen)
unmark_cards(TENURED,TENURED);
/* all generations except tenured space are
now empty */
reset_generations(TENURED - 1,NURSERY);
reset_generations(NURSERY,TENURED - 1);
fprintf(stderr,"*** Major GC (%ld minor, %ld cards)\n",
minor_collections,cards_scanned);
minor_collections = 0;
cards_scanned = 0;
}
else
{
@ -245,7 +253,9 @@ void end_gc(CELL gen)
unmark_cards(gen + 1,gen + 1);
/* all generations up to and including the one
collected are now empty */
reset_generations(gen,NURSERY);
reset_generations(NURSERY,gen);
minor_collections++;
}
}
@ -308,7 +318,18 @@ are also reachable via the GC roots. */
void maybe_garbage_collection(void)
{
if(nursery.here > nursery.alarm)
garbage_collection(NURSERY);
{
CELL gen = NURSERY;
while(gen < TENURED)
{
ZONE *z = &generations[gen + 1];
if(z->here < z->alarm)
break;
gen++;
}
garbage_collection(gen);
}
}
void primitive_gc_time(void)

16
native/gc.h
View File

@ -37,16 +37,20 @@ CELL init_zone(ZONE *z, CELL size, CELL base);
void init_arena(CELL young_size, CELL aging_size);
/* statistics */
s64 gc_time;
CELL minor_collections;
CELL cards_scanned;
/* only meaningful during a GC */
CELL collecting_generation;
CELL collecting_gen;
CELL collecting_gen_start;
/* test if the pointer is in generation being collected, or a younger one.
init_arena() arranges things so that the older generations are first,
so we have to check that the pointer occurs after the beginning of
the requested generation. */
#define COLLECTING_GEN(ptr) (collecting_generation <= ptr)
#define COLLECTING_GEN(ptr) (collecting_gen_start <= ptr)
/* #define GC_DEBUG */
@ -56,6 +60,14 @@ INLINE void gc_debug(char* msg, CELL x) {
#endif
}
INLINE bool should_copy(CELL untagged)
{
if(collecting_gen == TENURED)
return !in_zone(newspace,untagged);
else
return(in_zone(&prior,untagged) || COLLECTING_GEN(untagged));
}
CELL copy_object(CELL pointer);
#define COPY_OBJECT(lvalue) if(COLLECTING_GEN(lvalue)) lvalue = copy_object(lvalue)

11
native/relocate.c
View File

@ -40,8 +40,6 @@ INLINE CELL relocate_data_next(CELL relocating)
CELL size = CELLS;
CELL cell = get(relocating);
allot_barrier(relocating);
if(headerp(cell))
{
size = untagged_object_size(relocating);
@ -69,6 +67,7 @@ void relocate_data()
if(relocating >= tenured.here)
break;
allot_barrier(relocating);
relocating = relocate_data_next(relocating);
}
@ -93,7 +92,7 @@ CELL get_rel_symbol(F_REL* rel)
INLINE CELL compute_code_rel(F_REL *rel, CELL original)
{
switch(rel->type)
switch(REL_TYPE(rel))
{
case F_PRIMITIVE:
return primitive_to_xt(rel->argument);
@ -133,7 +132,7 @@ INLINE CELL relocate_code_next(CELL relocating)
CELL original;
CELL new_value;
if(rel->risc16_16)
if(REL_16_16(rel))
original = reloc_get_16_16(rel->offset);
else
original = get(rel->offset);
@ -143,10 +142,10 @@ INLINE CELL relocate_code_next(CELL relocating)
code_fixup(&rel->offset);
new_value = compute_code_rel(rel,original);
if(rel->relative)
if(REL_RELATIVE(rel))
new_value -= (rel->offset + CELLS);
if(rel->risc16_16)
if(REL_16_16(rel))
reloc_set_16_16(rel->offset,new_value);
else
put(rel->offset,new_value);

14
native/relocate.h
View File

@ -21,13 +21,17 @@ typedef enum {
F_CARDS
} F_RELTYPE;
/* code relocation consists of a table of entries for each fixup */
typedef struct {
u8 type;
u8 relative;
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0xff)
/* on PowerPC, some values are stored in the high 16 bits of a pair
of consecutive cells */
u8 risc16_16;
#define REL_16_16(r) ((r)->type & 0xff00)
#define REL_RELATIVE(r) ((r)->type & 0xff0000)
/* code relocation consists of a table of entries for each fixup */
typedef struct {
CELL type;
CELL offset;
CELL argument;
} F_REL;