<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
<magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
\r
+- simplifier:\r
+ - dead loads not optimized out\r
+ - kill tag-fixnum/untag-fixnum\r
+- \ foo where foo is parsing is not printed readably\r
- faster layout\r
- tiled window manager\r
- c primitive arrays: or just specialized arrays\r
- sleep word\r
- update docs\r
- redo new compiler backend for PowerPC\r
+- type predicates: : foo? type 7 eq? ;\r
+- remove 'not' word, and move t?/f? to kernel\r
\r
- plugin: supportsBackspace\r
- if external factor is down, don't add tons of random shit to the \r
: compiling ( word -- word parameter )
check-architecture
- "Compiling " write dup . flush
+ "Compiling " write dup word. terpri flush
dup word-def ;
GENERIC: (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 ;
: decompile ( word -- )
dup compiled? [
- "Decompiling " write dup . flush
+ "Decompiling " write dup word. terpri flush
[ word-primitive ] keep set-word-primitive
] [
drop
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 ;
] "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
] "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 [
: 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
: 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 ;
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
: 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, ;
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 ;
! 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
: 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 ;
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
: 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 ;
[ 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 ;
#! 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
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<= [
] 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
"buffer" ,
] when
- cpu "unknown" = "compile" get and [
+ cpu "unknown" = not "compile" get and [
[
"io/buffer" "compiler/optimizer"
"compiler/simple"
"compiler/generic" "compiler/bail-out"
"compiler/linearizer" "compiler/intrinsics"
] %
- ] unless
+ ] when
[
"benchmark/empty-loop" "benchmark/fac"
while(card_scan < card_end && card_scan < here)
card_scan = collect_next(card_scan);
+
+ cards_scanned++;
}
INLINE void collect_gen_cards(CELL gen)
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);
}
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)
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);
allot_profiling = false;
heap_scan = false;
gc_time = 0;
+ minor_collections = 0;
+ cards_scanned = 0;
}
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)
{
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 */
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
void begin_gc(CELL gen)
{
- collecting_generation = generations[gen].base;
+ collecting_gen = gen;
+ collecting_gen_start = generations[gen].base;
if(gen == TENURED)
{
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
{
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++;
}
}
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)
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 */
#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)
CELL size = CELLS;
CELL cell = get(relocating);
- allot_barrier(relocating);
-
if(headerp(cell))
{
size = untagged_object_size(relocating);
if(relocating >= tenured.here)
break;
+ allot_barrier(relocating);
relocating = relocate_data_next(relocating);
}
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);
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);
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);
F_CARDS
} F_RELTYPE;
+/* 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 */
+#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 {
- u8 type;
- u8 relative;
- /* on PowerPC, some values are stored in the high 16 bits of a pair
- of consecutive cells */
- u8 risc16_16;
+ CELL type;
CELL offset;
CELL argument;
} F_REL;
projects / factor.git / commitdiff