CC = gcc
-DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
-#DEFAULT_CFLAGS = -g
-DEFAULT_LIBS = -lm
+ifdef DEBUG
+ DEFAULT_CFLAGS = -g
+ STRIP = touch
+else
+ DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
+ STRIP = strip
+endif
-STRIP = strip
-#STRIP = touch
+DEFAULT_LIBS = -lm
UNIX_OBJS = native/unix/file.o \
native/unix/signal.o \
native/ratio.o native/relocate.o \
native/run.o \
native/sbuf.o native/stack.o \
- native/string.o native/types.o native/vector.o \
+ native/string.o native/cards.o native/vector.o \
native/word.o native/compiler.o \
native/alien.o native/dll.o \
native/boolean.o \
cpu "x86" = [\r
"/library/compiler/x86/assembler.factor"\r
"/library/compiler/x86/generator.factor"\r
+ "/library/compiler/x86/slots.factor"\r
"/library/compiler/x86/stack.factor"\r
"/library/compiler/x86/fixnum.factor"\r
"/library/compiler/x86/alien.factor"\r
] ifte out-1
] "linearizer" set-word-prop
-\ set-slot intrinsic
-
-\ set-slot [
- dup typed-literal? [
- 1 %dec-d ,
- in-2
- 2 %dec-d ,
- slot@ >r 0 1 r> %fast-set-slot ,
- ] [
- drop
- in-3
- 3 %dec-d ,
- 1 %untag ,
- 0 1 2 %set-slot ,
- ] ifte
-] "linearizer" set-word-prop
+! \ set-slot intrinsic
+!
+! \ set-slot [
+! dup typed-literal? [
+! 1 %dec-d ,
+! in-2
+! 2 %dec-d ,
+! slot@ >r 0 1 r> %fast-set-slot ,
+! ] [
+! drop
+! in-3
+! 3 %dec-d ,
+! 1 %untag ,
+! 0 1 2 %set-slot ,
+! ] ifte
+! ] "linearizer" set-word-prop
\ type intrinsic
M: %untag-fixnum generate-node ( vop -- )
vop-dest v>operand 3 SHR ;
-M: %slot generate-node ( vop -- )
- #! the untagged object is in vop-dest, the tagged slot
- #! number is in vop-source.
- dest/src
- ! turn tagged fixnum slot # into an offset, multiple of 4
- dup 1 SHR
- ! compute slot address in vop-dest
- dupd ADD
- ! load slot value in vop-dest
- dup unit MOV ;
-
-M: %fast-slot generate-node ( vop -- )
- #! the tagged object is in vop-dest, the pointer offset is
- #! in vop-literal. the offset already takes the type tag
- #! into account, so its just one instruction to load.
- dup vop-literal swap vop-dest v>operand tuck >r 2list r>
- swap MOV ;
-
-M: %set-slot generate-node ( vop -- )
- #! the untagged object is in vop-dest, the new value is in
- #! vop-source, the tagged slot number is in vop-literal.
- dup vop-literal v>operand over vop-dest v>operand
- ! turn tagged fixnum slot # into an offset, multiple of 4
- over 1 SHR
- ! compute slot address in vop-dest
- dupd ADD
- ! store new slot value
- >r vop-source v>operand r> unit swap MOV ;
-
-M: %fast-set-slot generate-node ( vop -- )
- #! the tagged object is in vop-dest, the new value is in
- #! vop-source, the pointer offset is in vop-literal. the
- #! offset already takes the type tag into account, so its
- #! just one instruction to load.
- dup vop-literal over vop-dest v>operand swap 2list
- swap vop-source v>operand MOV ;
-
M: %dispatch generate-node ( vop -- )
#! Compile a piece of code that jumps to an offset in a
#! jump table indexed by the fixnum at the top of the stack.
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: compiler-backend
+USING: alien assembler compiler inference kernel
+kernel-internals lists math memory namespaces sequences words ;
+
+M: %slot generate-node ( vop -- )
+ #! the untagged object is in vop-dest, the tagged slot
+ #! number is in vop-source.
+ dest/src
+ ! turn tagged fixnum slot # into an offset, multiple of 4
+ dup 1 SHR
+ ! compute slot address in vop-dest
+ dupd ADD
+ ! load slot value in vop-dest
+ dup unit MOV ;
+
+M: %fast-slot generate-node ( vop -- )
+ #! the tagged object is in vop-dest, the pointer offset is
+ #! in vop-literal. the offset already takes the type tag
+ #! into account, so its just one instruction to load.
+ dup vop-literal swap vop-dest v>operand tuck >r 2list r>
+ swap MOV ;
+
+! : card-bits 5 ;
+!
+! : card-offset ( -- n )
+! #! We add this to an address that was shifted by card-bits
+! #! to get the address of its card.
+!
+! ;
+!
+! : write-barrier ( vreg -- )
+! #! Mark the card pointed to by vreg.
+!
+! ;
+
+M: %set-slot generate-node ( vop -- )
+ #! the untagged object is in vop-dest, the new value is in
+ #! vop-source, the tagged slot number is in vop-literal.
+ dup vop-literal v>operand over vop-dest v>operand
+ ! turn tagged fixnum slot # into an offset, multiple of 4
+ over 1 SHR
+ ! compute slot address in vop-dest
+ dupd ADD
+ ! store new slot value
+ >r vop-source v>operand r> unit swap MOV ;
+
+M: %fast-set-slot generate-node ( vop -- )
+ #! the tagged object is in vop-dest, the new value is in
+ #! vop-source, the pointer offset is in vop-literal. the
+ #! offset already takes the type tag into account, so its
+ #! just one instruction to load.
+ dup vop-literal over vop-dest v>operand swap 2list
+ swap vop-source v>operand MOV ;
"buffer" ,
] when
- cpu "unknown" = [
+ cpu "unknown" = "compile" get and [
[
"io/buffer" "compiler/optimizer"
"compiler/simple"
--- /dev/null
+#include "factor.h"
+
+/* scan all the objects in the card */
+INLINE void collect_card(CARD *ptr, CELL here)
+{
+ CARD c = *ptr;
+ CELL offset = (c & CARD_BASE_MASK);
+ CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
+ CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
+
+ if(offset == 0x7f)
+ {
+ if(c == 0xff)
+ critical_error("bad card",c);
+ else
+ return;
+ }
+
+ while(card_scan < card_end && card_scan < here)
+ card_scan = collect_next(card_scan);
+}
+
+INLINE void collect_gen_cards(CELL gen)
+{
+ CARD *ptr = ADDR_TO_CARD(generations[gen].base);
+ CELL here = generations[gen].here;
+ CARD *last_card = ADDR_TO_CARD(here);
+
+ if(generations[gen].here == generations[gen].limit)
+ last_card--;
+
+ for(; ptr <= last_card; ptr++)
+ {
+ if(card_marked(*ptr))
+ collect_card(ptr,here);
+ }
+}
+
+void unmark_cards(CELL from, CELL to)
+{
+ CARD *ptr = ADDR_TO_CARD(generations[from].base);
+ CARD *last_card = ADDR_TO_CARD(generations[to].here);
+ if(generations[to].here == generations[to].limit)
+ last_card--;
+ for(; ptr <= last_card; ptr++)
+ unmark_card(ptr);
+}
+
+void clear_cards(CELL from, CELL to)
+{
+ CARD *ptr = ADDR_TO_CARD(generations[from].base);
+ CARD *last_card = ADDR_TO_CARD(generations[to].limit);
+ for(; ptr < last_card; ptr++)
+ clear_card(ptr);
+}
+
+/* scan cards in all generations older than the one being collected */
+void collect_cards(CELL gen)
+{
+ int i;
+ for(i = gen + 1; i < GC_GENERATIONS; i++)
+ collect_gen_cards(i);
+}
--- /dev/null
+CELL heap_start;
+CELL heap_end;
+
+/* card marking write barrier. a card is a byte storing a mark flag,
+and the offset (in cells) of the first object in the card.
+
+the mark flag is set by the write barrier when an object in the
+card has a slot written to.
+
+the offset of the first object is set by the allocator.
+*/
+#define CARD_MARK_MASK 0x80
+#define CARD_BASE_MASK 0x7f
+typedef u8 CARD;
+CARD *cards;
+CARD *cards_end;
+
+/* A card is 16 bytes (128 bits), 5 address bits per card.
+it is important that 7 bits is sufficient to represent every
+offset within the card */
+#define CARD_SIZE 128
+#define CARD_BITS 7
+#define ADDR_CARD_MASK (CARD_SIZE-1)
+
+INLINE CARD card_marked(CARD c)
+{
+ return c & CARD_MARK_MASK;
+}
+
+INLINE void unmark_card(CARD *c)
+{
+ *c &= CARD_BASE_MASK;
+}
+
+INLINE void clear_card(CARD *c)
+{
+ *c = CARD_BASE_MASK; /* invalid value */
+}
+
+INLINE u8 card_base(CARD c)
+{
+ return c & CARD_BASE_MASK;
+}
+
+#define ADDR_TO_CARD(a) (CARD*)((((CELL)a-heap_start)>>CARD_BITS)+(CELL)cards)
+#define CARD_TO_ADDR(c) (CELL*)((((CELL)c-(CELL)cards)<<CARD_BITS)+heap_start)
+
+/* this is an inefficient write barrier. compiled definitions use a more
+efficient one hand-coded in assembly. the write barrier must be called
+any time we are potentially storing a pointer from an older generation
+to a younger one */
+INLINE void write_barrier(CELL address)
+{
+ CARD *c = ADDR_TO_CARD(address);
+ *c |= CARD_MARK_MASK;
+}
+
+/* we need to remember the first object allocated in the card */
+INLINE void allot_barrier(CELL address)
+{
+ CARD *ptr = ADDR_TO_CARD(address);
+ CARD c = *ptr;
+ *ptr = (card_marked(c) | MIN(card_base(c),(address & ADDR_CARD_MASK)));
+}
+
+void unmark_cards(CELL from, CELL to);
+void clear_cards(CELL from, CELL to);
+void collect_cards(CELL gen);
/* must always be 8 bits */
typedef unsigned char BYTE;
-#include "memory.h"
#include "error.h"
-#include "types.h"
+#include "cards.h"
+#include "memory.h"
#include "gc.h"
#include "boolean.h"
#include "word.h"
/* Generational copying garbage collector */
+CELL init_zone(ZONE *z, CELL size, CELL base)
+{
+ z->base = z->here = base;
+ z->limit = z->base + size;
+ z->alarm = z->base + (size * 3) / 4;
+ return z->limit;
+}
+
+/* input parameters must be 8 byte aligned */
+/* the heap layout is important:
+- two semispaces: tenured and prior
+- younger generations follow
+there are two reasons for this:
+- we can easily check if a pointer is in some generation or a younger one
+- the nursery grows into the guard page, so allot() does not have to
+check for out of memory, whereas allot_zone() (used by the GC) longjmp()s
+back to collecting a higher generation */
+void init_arena(CELL young_size, CELL aging_size)
+{
+ int i;
+ CELL alloter;
+
+ CELL total_size = (GC_GENERATIONS - 1) * young_size + 2 * aging_size;
+ CELL cards_size = total_size / CARD_SIZE;
+
+ heap_start = (CELL)alloc_guarded(total_size);
+ heap_end = heap_start + total_size;
+
+ cards = alloc_guarded(cards_size);
+ cards_end = cards + cards_size;
+
+ alloter = heap_start;
+
+ if(heap_start == 0)
+ fatal_error("Cannot allocate data heap",total_size);
+
+ alloter = init_zone(&tenured,aging_size,alloter);
+ alloter = init_zone(&prior,aging_size,alloter);
+
+ for(i = GC_GENERATIONS - 2; i >= 0; i--)
+ alloter = init_zone(&generations[i],young_size,alloter);
+
+ clear_cards(TENURED,NURSERY);
+
+ if(alloter != heap_start + total_size)
+ fatal_error("Oops",alloter);
+
+ allot_profiling = false;
+ heap_scan = false;
+ gc_time = 0;
+}
+
void collect_roots(void)
{
int i;
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)
{
{
CELL tag;
CELL header;
- CELL untagged;
gc_debug("copy object",pointer);
return pointer;
header = get(UNTAG(pointer));
- untagged = UNTAG(header);
if(TAG(header) == GC_COLLECTED)
- {
- header = get(untagged);
- while(header == GC_COLLECTED)
- {
- untagged = UNTAG(header);
- header = get(untagged);
- }
- gc_debug("forwarding",untagged);
- return RETAG(untagged,tag);
- }
+ return resolve_forwarding(UNTAG(header),tag);
else
return RETAG(copy_object_impl(pointer),tag);
}
}
}
-INLINE CELL collect_next(CELL scan)
+CELL collect_next(CELL scan)
{
CELL size;
return scan + size;
}
-/* scan all the objects in the card */
-INLINE void collect_card(CARD *ptr, CELL here)
-{
- CARD c = *ptr;
- CELL offset = (c & CARD_BASE_MASK);
- CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + offset;
- CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
- if(offset == 0x7f)
- {
- if(c == 0xff)
- critical_error("bad card",c);
- else
- return;
- }
-
- while(card_scan < card_end && card_scan < here)
- card_scan = collect_next(card_scan);
-}
-
-INLINE void collect_gen_cards(CELL gen)
-{
- CARD *ptr = ADDR_TO_CARD(generations[gen].base);
- CELL here = generations[gen].here;
- CARD *last_card = ADDR_TO_CARD(here);
-
- if(generations[gen].here == generations[gen].limit)
- last_card--;
-
- for(; ptr <= last_card; ptr++)
- {
- if(card_marked(*ptr))
- collect_card(ptr,here);
- }
-}
-
-void unmark_cards(CELL from, CELL to)
-{
- CARD *ptr = ADDR_TO_CARD(generations[from].base);
- CARD *last_card = ADDR_TO_CARD(generations[to].here);
- if(generations[to].here == generations[to].limit)
- last_card--;
- for(; ptr <= last_card; ptr++)
- unmark_card(ptr);
-}
-
-void clear_cards(CELL from, CELL to)
-{
- CARD *ptr = ADDR_TO_CARD(generations[from].base);
- CARD *last_card = ADDR_TO_CARD(generations[to].limit);
- for(; ptr < last_card; ptr++)
- clear_card(ptr);
-}
-
void reset_generations(CELL from, CELL to)
{
CELL i;
clear_cards(from,to);
}
-/* scan cards in all generations older than the one being collected */
-void collect_cards(CELL gen)
-{
- int i;
- for(i = gen + 1; i < GC_GENERATIONS; i++)
- collect_gen_cards(i);
-}
-
void begin_gc(CELL gen)
{
collecting_generation = generations[gen].base;
unmark_cards(TENURED,TENURED);
/* all generations except tenured space are
now empty */
- reset_generations(NURSERY,TENURED - 1);
+ reset_generations(TENURED - 1,NURSERY);
}
else
{
unmark_cards(gen + 1,gen + 1);
/* all generations up to and including the one
collected are now empty */
- reset_generations(NURSERY,gen);
+ reset_generations(gen,NURSERY);
}
}
CELL scan;
if(heap_scan)
- {
- fprintf(stderr,"GC disabled\n");
- fflush(stderr);
- return;
- }
-
- gc_in_progress = true;
+ critical_error("GC disabled during heap scan",gen);
/* we come back here if a generation is full */
if(setjmp(gc_jmp))
begin_gc(gen);
- printf("collecting generation %ld\n",gen);
-
/* initialize chase pointer */
scan = newspace->here;
gc_debug("gc done",gen);
- gc_in_progress = false;
gc_time += (current_millis() - start);
gc_debug("total gc time",gc_time);
void maybe_garbage_collection(void)
{
if(nursery.here > nursery.alarm)
- {
- if(tenured.here > tenured.alarm)
- {
- printf("Major GC\n");
- garbage_collection(TENURED);
- }
- else
- {
- printf("Minor GC\n");
- garbage_collection(NURSERY);
- }
- }
+ garbage_collection(NURSERY);
}
void primitive_gc_time(void)
-bool gc_in_progress;
+/* generational copying GC divides memory into zones */
+typedef struct {
+ /* start of zone */
+ CELL base;
+ /* allocation pointer */
+ CELL here;
+ /* only for nursery: when it gets this full, call GC */
+ CELL alarm;
+ /* end of zone */
+ CELL limit;
+} ZONE;
-/* GC is off during heap walking */
-bool heap_scan;
+/* total number of generations. */
+#define GC_GENERATIONS 3
+/* the 0th generation is where new objects are allocated. */
+#define NURSERY 0
+/* the oldest generation */
+#define TENURED (GC_GENERATIONS-1)
+
+ZONE generations[GC_GENERATIONS];
+
+/* used during garbage collection only */
+ZONE *newspace;
+
+#define tenured generations[TENURED]
+#define nursery generations[NURSERY]
+
+/* spare semi-space; rotates with tenured. */
+ZONE prior;
+
+INLINE bool in_zone(ZONE* z, CELL pointer)
+{
+ return pointer >= z->base && pointer < z->limit;
+}
+
+CELL init_zone(ZONE *z, CELL size, CELL base);
+
+void init_arena(CELL young_size, CELL aging_size);
s64 gc_time;
COPY_OBJECT(*handle);
}
-void clear_cards(CELL from, CELL to);
-void unmark_cards(CELL from, CELL to);
-void primitive_gc(void);
-void garbage_collection(CELL gen);
-void maybe_garbage_collection(void);
-void primitive_gc_time(void);
-
/* in case a generation fills up in the middle of a gc, we jump back
up to try collecting the next generation. */
jmp_buf gc_jmp;
+
+/* A heap walk allows useful things to be done, like finding all
+references to an object for debugging purposes. */
+CELL heap_scan_ptr;
+
+/* GC is off during heap walking */
+bool heap_scan;
+
+INLINE void *allot_zone(ZONE *z, CELL a)
+{
+ CELL h = z->here;
+ z->here = h + align8(a);
+ allot_barrier(h);
+ return (void*)h;
+}
+
+INLINE void *allot(CELL a)
+{
+ if(allot_profiling)
+ allot_profile_step(align8(a));
+ allot_barrier(nursery.here);
+ return allot_zone(&nursery,a);
+}
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+INLINE void* allot_object(CELL type, CELL length)
+{
+ CELL* object = allot(length);
+ *object = tag_header(type);
+ return object;
+}
+
+CELL collect_next(CELL scan);
+void garbage_collection(CELL gen);
+void primitive_gc(void);
+void maybe_garbage_collection(void);
+void primitive_gc_time(void);
#include "factor.h"
-CELL init_zone(ZONE *z, CELL size, CELL base)
+CELL object_size(CELL pointer)
{
- z->base = z->here = base;
- z->limit = z->base + size;
- z->alarm = z->base + (size * 3) / 4;
- return z->limit;
+ CELL size;
+
+ switch(TAG(pointer))
+ {
+ case FIXNUM_TYPE:
+ size = 0;
+ break;
+ case BIGNUM_TYPE:
+ size = untagged_object_size(UNTAG(pointer));
+ break;
+ case CONS_TYPE:
+ size = sizeof(F_CONS);
+ break;
+ case RATIO_TYPE:
+ size = sizeof(F_RATIO);
+ break;
+ case FLOAT_TYPE:
+ size = sizeof(F_FLOAT);
+ break;
+ case COMPLEX_TYPE:
+ size = sizeof(F_CONS);
+ break;
+ case OBJECT_TYPE:
+ size = untagged_object_size(UNTAG(pointer));
+ break;
+ default:
+ critical_error("Cannot determine object_size",pointer);
+ size = 0; /* Can't happen */
+ break;
+ }
+
+ return align8(size);
}
-/* input parameters must be 8 byte aligned */
-/* the heap layout is important:
-- two semispaces: tenured and prior
-- younger generations follow */
-void init_arena(CELL young_size, CELL aging_size)
+CELL untagged_object_size(CELL pointer)
{
- int i;
- CELL alloter;
-
- CELL total_size = (GC_GENERATIONS - 1) * young_size + 2 * aging_size;
- CELL cards_size = total_size / CARD_SIZE;
+ CELL size;
- heap_start = (CELL)alloc_guarded(total_size);
- heap_end = heap_start + total_size;
+ if(pointer == F)
+ return 0;
- cards = alloc_guarded(cards_size);
- cards_end = cards + cards_size;
+ switch(untag_header(get(pointer)))
+ {
+ case WORD_TYPE:
+ size = sizeof(F_WORD);
+ break;
+ case T_TYPE:
+ size = CELLS * 2;
+ break;
+ case ARRAY_TYPE:
+ case TUPLE_TYPE:
+ case BIGNUM_TYPE:
+ case BYTE_ARRAY_TYPE:
+ size = align8(sizeof(F_ARRAY) +
+ array_capacity((F_ARRAY*)(pointer)) * CELLS);
+ break;
+ case HASHTABLE_TYPE:
+ size = sizeof(F_HASHTABLE);
+ break;
+ case VECTOR_TYPE:
+ size = sizeof(F_VECTOR);
+ break;
+ case STRING_TYPE:
+ size = SSIZE(pointer);
+ break;
+ case SBUF_TYPE:
+ size = sizeof(F_SBUF);
+ break;
+ case FLOAT_TYPE:
+ size = sizeof(F_FLOAT);
+ break;
+ case DLL_TYPE:
+ size = sizeof(DLL);
+ break;
+ case ALIEN_TYPE:
+ size = sizeof(ALIEN);
+ break;
+ case DISPLACED_ALIEN_TYPE:
+ size = sizeof(DISPLACED_ALIEN);
+ break;
+ default:
+ critical_error("Cannot determine untagged_object_size",pointer);
+ size = -1;/* can't happen */
+ break;
+ }
- alloter = heap_start;
+ return align8(size);
+}
- if(heap_start == 0)
- fatal_error("Cannot allocate data heap",total_size);
+void primitive_type(void)
+{
+ drepl(tag_fixnum(type_of(dpeek())));
+}
- alloter = init_zone(&tenured,aging_size,alloter);
- alloter = init_zone(&prior,aging_size,alloter);
+#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
- for(i = GC_GENERATIONS - 2; i >= 0; i--)
- alloter = init_zone(&generations[i],young_size,alloter);
+void primitive_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ dpush(get(SLOT(obj,slot)));
+}
- clear_cards(TENURED,NURSERY);
+void primitive_set_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ CELL value = dpop();
+ put(SLOT(obj,slot),value);
+ write_barrier(obj);
+}
- if(alloter != heap_start + total_size)
- fatal_error("Oops",alloter);
+void primitive_integer_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ dpush(tag_integer(get(SLOT(obj,slot))));
+}
- allot_profiling = false;
- gc_in_progress = false;
- heap_scan = false;
- gc_time = 0;
+void primitive_set_integer_slot(void)
+{
+ F_FIXNUM slot = untag_fixnum_fast(dpop());
+ CELL obj = UNTAG(dpop());
+ F_FIXNUM value = to_fixnum(dpop());
+ put(SLOT(obj,slot),value);
}
void allot_profile_step(CELL a)
untag_word_fast(executing)->allot_count += a;
}
-void primitive_room(void)
-{
- CELL list = F;
- int gen;
- box_signed_cell(compiling.limit - compiling.here);
- box_signed_cell(compiling.limit - compiling.base);
- box_signed_cell(cards_end - cards);
- box_signed_cell(prior.limit - prior.base);
- for(gen = GC_GENERATIONS - 1; gen >= 0; gen--)
- {
- ZONE *z = &generations[gen];
- list = cons(cons(
- tag_fixnum(z->limit - z->here),
- tag_fixnum(z->limit - z->base)),
- list);
- }
- dpush(list);
-}
-
void primitive_allot_profiling(void)
{
CELL d = dpop();
drepl(tag_fixnum(object_size(dpeek())));
}
+void primitive_room(void)
+{
+ CELL list = F;
+ int gen;
+ box_signed_cell(compiling.limit - compiling.here);
+ box_signed_cell(compiling.limit - compiling.base);
+ box_signed_cell(cards_end - cards);
+ box_signed_cell(prior.limit - prior.base);
+ for(gen = GC_GENERATIONS - 1; gen >= 0; gen--)
+ {
+ ZONE *z = &generations[gen];
+ list = cons(cons(
+ tag_fixnum(z->limit - z->here),
+ tag_fixnum(z->limit - z->base)),
+ list);
+ }
+ dpush(list);
+}
+
void primitive_begin_scan(void)
{
garbage_collection(TENURED);
heap_scan_ptr = tenured.base;
- heap_scan_end = tenured.here;
heap_scan = true;
}
if(!heap_scan)
general_error(ERROR_HEAP_SCAN,F);
- if(heap_scan_ptr >= heap_scan_end)
+ if(heap_scan_ptr >= tenured.here)
{
dpush(F);
return;
*((BYTE*)where) = what;
}
-/* generational copying GC divides memory into zones */
-typedef struct {
- /* start of zone */
- CELL base;
- /* allocation pointer */
- CELL here;
- /* only for nursery: when it gets this full, call GC */
- CELL alarm;
- /* end of zone */
- CELL limit;
-} ZONE;
-
-INLINE bool in_zone(ZONE* z, CELL pointer)
+INLINE CELL align8(CELL a)
{
- return pointer >= z->base && pointer < z->limit;
+ return ((a & 7) == 0) ? a : ((a + 8) & ~7);
}
-/* total number of generations. */
-#define GC_GENERATIONS 3
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-/* the oldest generation */
-#define TENURED (GC_GENERATIONS-1)
-
-ZONE generations[GC_GENERATIONS];
-
-/* used during garbage collection only */
-ZONE *newspace;
+#define TAG_MASK 7
+#define TAG_BITS 3
+#define TAG(cell) ((CELL)(cell) & TAG_MASK)
+#define RETAG(cell,tag) ((CELL)(cell) | (tag))
+#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
-#define tenured generations[TENURED]
-#define nursery generations[NURSERY]
+/*** Tags ***/
+#define FIXNUM_TYPE 0
+#define BIGNUM_TYPE 1
+#define CONS_TYPE 2
+#define OBJECT_TYPE 3
+#define RATIO_TYPE 4
+#define FLOAT_TYPE 5
+#define COMPLEX_TYPE 6
+#define HEADER_TYPE 7 /* anything less than this is a tag */
+#define GC_COLLECTED 7 /* See gc.c */
-CELL heap_start;
-CELL heap_end;
+/*** Header types ***/
-/* spare semi-space; rotates with tenured. */
-ZONE prior;
+/* Canonical T object */
+#define T_TYPE 7
+CELL T;
-/* card marking write barrier. a card is a byte storing a mark flag,
-and the offset (in cells) of the first object in the card.
+#define ARRAY_TYPE 8
-the mark flag is set by the write barrier when an object in the
-card has a slot written to.
+/* Canonical F object */
+#define F_TYPE 9
+#define F RETAG(0,OBJECT_TYPE)
-the offset of the first object is set by the allocator.
-*/
-#define CARD_MARK_MASK 0x80
-#define CARD_BASE_MASK 0x7f
-typedef u8 CARD;
-CARD *cards;
-CARD *cards_end;
+#define HASHTABLE_TYPE 10
+#define VECTOR_TYPE 11
+#define STRING_TYPE 12
+#define SBUF_TYPE 13
+#define DLL_TYPE 15
+#define ALIEN_TYPE 16
+#define WORD_TYPE 17
+#define TUPLE_TYPE 18
+#define BYTE_ARRAY_TYPE 19
+#define DISPLACED_ALIEN_TYPE 20
-/* A card is 16 bytes (128 bits), 5 address bits per card.
-it is important that 7 bits is sufficient to represent every
-offset within the card */
-#define CARD_SIZE 128
-#define CARD_BITS 7
-#define ADDR_CARD_MASK (CARD_SIZE-1)
+#define TYPE_COUNT 21
-INLINE CARD card_marked(CARD c)
+INLINE bool headerp(CELL cell)
{
- return c & CARD_MARK_MASK;
+ return (cell != F
+ && TAG(cell) == OBJECT_TYPE
+ && cell < RETAG(TYPE_COUNT << TAG_BITS,OBJECT_TYPE));
}
-INLINE void unmark_card(CARD *c)
+INLINE CELL tag_header(CELL cell)
{
- *c &= CARD_BASE_MASK;
+ return RETAG(cell << TAG_BITS,OBJECT_TYPE);
}
-INLINE void clear_card(CARD *c)
+INLINE CELL untag_header(CELL cell)
{
- *c = CARD_BASE_MASK; /* invalid value */
+ return cell >> TAG_BITS;
}
-INLINE u8 card_base(CARD c)
+INLINE CELL tag_object(void* cell)
{
- return c & CARD_BASE_MASK;
+ return RETAG(cell,OBJECT_TYPE);
}
-#define ADDR_TO_CARD(a) (CARD*)((((CELL)a-heap_start)>>CARD_BITS)+(CELL)cards)
-#define CARD_TO_ADDR(c) (CELL*)((((CELL)c-(CELL)cards)<<CARD_BITS)+heap_start)
-
-/* this is an inefficient write barrier. compiled definitions use a more
-efficient one hand-coded in assembly. the write barrier must be called
-any time we are potentially storing a pointer from an older generation
-to a younger one */
-INLINE void write_barrier(CELL address)
+INLINE CELL object_type(CELL tagged)
{
- CARD *c = ADDR_TO_CARD(address);
- *c |= CARD_MARK_MASK;
+ if(tagged == F)
+ return F_TYPE;
+ else
+ return untag_header(get(UNTAG(tagged)));
}
-/* we need to remember the first object allocated in the card */
-INLINE void allot_barrier(CELL address)
+INLINE void type_check(CELL type, CELL tagged)
{
- CARD *ptr = ADDR_TO_CARD(address);
- CARD c = *ptr;
- *ptr = (card_marked(c) | MIN(card_base(c),(address & ADDR_CARD_MASK)));
-}
-
-bool allot_profiling;
+ if(type < HEADER_TYPE)
+ {
+ if(TAG(tagged) == type)
+ return;
+ }
+ else if(TAG(tagged) == OBJECT_TYPE
+ && object_type(tagged) == type)
+ {
+ return;
+ }
-/* set up guard pages to check for under/overflow.
-size must be a multiple of the page size */
-void* alloc_guarded(CELL size);
-
-CELL init_zone(ZONE *z, CELL size, CELL base);
-void init_arena(CELL young_size, CELL aging_size);
-void flip_zones();
+ type_error(type,tagged);
+}
void allot_profile_step(CELL a);
-INLINE CELL align8(CELL a)
-{
- return ((a & 7) == 0) ? a : ((a + 8) & ~7);
-}
-
-INLINE void *allot_zone(ZONE *z, CELL a)
-{
- CELL h = z->here;
- z->here = h + align8(a);
- allot_barrier(h);
- return (void*)h;
-}
+bool allot_profiling;
-INLINE void *allot(CELL a)
+INLINE CELL type_of(CELL tagged)
{
- if(allot_profiling)
- allot_profile_step(align8(a));
- allot_barrier(nursery.here);
- return allot_zone(&nursery,a);
+ CELL tag = TAG(tagged);
+ if(tag == OBJECT_TYPE)
+ return object_type(tagged);
+ else
+ return tag;
}
-bool in_zone(ZONE* z, CELL pointer);
-
-void primitive_room(void);
+CELL untagged_object_size(CELL pointer);
+CELL object_size(CELL pointer);
void primitive_allot_profiling(void);
+void primitive_room(void);
+void primitive_type(void);
+void primitive_slot(void);
+void primitive_set_slot(void);
+void primitive_integer_slot(void);
+void primitive_set_integer_slot(void);
void primitive_address(void);
void primitive_size(void);
-
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-CELL heap_scan_ptr;
-
-/* End of heap when walk was started; prevents infinite loop if
-walk consing */
-CELL heap_scan_end;
-
void primitive_begin_scan(void);
void primitive_next_object(void);
void primitive_end_scan(void);
+
+/* set up guard pages to check for under/overflow.
+size must be a multiple of the page size */
+void* alloc_guarded(CELL size);
return ((CELL)cards - heap_start);
default:
critical_error("Unsupported rel",rel->type);
- break;
+ return -1;
}
}
#define OUT_ENV 14
#define GEN_ENV 15 /* set to GC_GENERATIONS constant */
+/* TAGGED user environment data; see getenv/setenv prims */
+CELL userenv[USER_ENV];
+
/* Profiling timer */
#ifndef WIN32
struct itimerval prof_timer;
sigjmp_buf toplevel;
#endif
-/* TAGGED user environment data; see getenv/setenv prims */
-CELL userenv[USER_ENV];
-
/* Call stack depth to start profile counter from */
/* This ensures that words in the user's interpreter do not count */
CELL profile_depth;
+++ /dev/null
-#include "factor.h"
-
-CELL object_size(CELL pointer)
-{
- CELL size;
-
- switch(TAG(pointer))
- {
- case FIXNUM_TYPE:
- size = 0;
- break;
- case BIGNUM_TYPE:
- size = untagged_object_size(UNTAG(pointer));
- break;
- case CONS_TYPE:
- size = sizeof(F_CONS);
- break;
- case RATIO_TYPE:
- size = sizeof(F_RATIO);
- break;
- case FLOAT_TYPE:
- size = sizeof(F_FLOAT);
- break;
- case COMPLEX_TYPE:
- size = sizeof(F_CONS);
- break;
- case OBJECT_TYPE:
- size = untagged_object_size(UNTAG(pointer));
- break;
- default:
- critical_error("Cannot determine size",pointer);
- size = 0; /* Can't happen */
- break;
- }
-
- return align8(size);
-}
-
-CELL untagged_object_size(CELL pointer)
-{
- CELL size;
-
- if(pointer == F)
- return 0;
-
- switch(untag_header(get(pointer)))
- {
- case WORD_TYPE:
- size = sizeof(F_WORD);
- break;
- case T_TYPE:
- size = CELLS * 2;
- break;
- case ARRAY_TYPE:
- case TUPLE_TYPE:
- case BIGNUM_TYPE:
- case BYTE_ARRAY_TYPE:
- size = align8(sizeof(F_ARRAY) +
- array_capacity((F_ARRAY*)(pointer)) * CELLS);
- break;
- case HASHTABLE_TYPE:
- size = sizeof(F_HASHTABLE);
- break;
- case VECTOR_TYPE:
- size = sizeof(F_VECTOR);
- break;
- case STRING_TYPE:
- size = SSIZE(pointer);
- break;
- case SBUF_TYPE:
- size = sizeof(F_SBUF);
- break;
- case FLOAT_TYPE:
- size = sizeof(F_FLOAT);
- break;
- case DLL_TYPE:
- size = sizeof(DLL);
- break;
- case ALIEN_TYPE:
- size = sizeof(ALIEN);
- break;
- case DISPLACED_ALIEN_TYPE:
- size = sizeof(DISPLACED_ALIEN);
- break;
- default:
- critical_error("Cannot determine size",pointer);
- size = -1;/* can't happen */
- break;
- }
-
- return align8(size);
-}
-
-void primitive_type(void)
-{
- drepl(tag_fixnum(type_of(dpeek())));
-}
-
-#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
-
-void primitive_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- dpush(get(SLOT(obj,slot)));
-}
-
-void primitive_set_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- CELL value = dpop();
- put(SLOT(obj,slot),value);
- write_barrier(obj);
-}
-
-void primitive_integer_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- dpush(tag_integer(get(SLOT(obj,slot))));
-}
-
-void primitive_set_integer_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = UNTAG(dpop());
- F_FIXNUM value = to_fixnum(dpop());
- put(SLOT(obj,slot),value);
-}
+++ /dev/null
-#define TAG_MASK 7
-#define TAG_BITS 3
-#define TAG(cell) ((CELL)(cell) & TAG_MASK)
-#define RETAG(cell,tag) ((CELL)(cell) | (tag))
-#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
-
-/*** Tags ***/
-#define FIXNUM_TYPE 0
-#define BIGNUM_TYPE 1
-#define CONS_TYPE 2
-#define OBJECT_TYPE 3
-#define RATIO_TYPE 4
-#define FLOAT_TYPE 5
-#define COMPLEX_TYPE 6
-#define HEADER_TYPE 7 /* anything less than this is a tag */
-#define GC_COLLECTED 7 /* See gc.c */
-
-/*** Header types ***/
-
-/* Canonical T object */
-#define T_TYPE 7
-CELL T;
-
-#define ARRAY_TYPE 8
-
-/* Canonical F object */
-#define F_TYPE 9
-#define F RETAG(0,OBJECT_TYPE)
-
-#define HASHTABLE_TYPE 10
-#define VECTOR_TYPE 11
-#define STRING_TYPE 12
-#define SBUF_TYPE 13
-#define DLL_TYPE 15
-#define ALIEN_TYPE 16
-#define WORD_TYPE 17
-#define TUPLE_TYPE 18
-#define BYTE_ARRAY_TYPE 19
-#define DISPLACED_ALIEN_TYPE 20
-
-#define TYPE_COUNT 21
-
-INLINE bool headerp(CELL cell)
-{
- return (cell != F
- && TAG(cell) == OBJECT_TYPE
- && cell < RETAG(TYPE_COUNT << TAG_BITS,OBJECT_TYPE));
-}
-
-INLINE CELL tag_header(CELL cell)
-{
- return RETAG(cell << TAG_BITS,OBJECT_TYPE);
-}
-
-INLINE CELL untag_header(CELL cell)
-{
- return cell >> TAG_BITS;
-}
-
-INLINE CELL tag_object(void* cell)
-{
- return RETAG(cell,OBJECT_TYPE);
-}
-
-INLINE CELL object_type(CELL tagged)
-{
- if(tagged == F)
- return F_TYPE;
- else
- return untag_header(get(UNTAG(tagged)));
-}
-
-INLINE void type_check(CELL type, CELL tagged)
-{
- if(type < HEADER_TYPE)
- {
- if(TAG(tagged) == type)
- return;
- }
- else if(TAG(tagged) == OBJECT_TYPE
- && object_type(tagged) == type)
- {
- return;
- }
-
- type_error(type,tagged);
-}
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-INLINE void* allot_object(CELL type, CELL length)
-{
- CELL* object = allot(length);
- *object = tag_header(type);
- return object;
-}
-
-CELL untagged_object_size(CELL pointer);
-CELL object_size(CELL pointer);
-void primitive_type(void);
-
-INLINE CELL type_of(CELL tagged)
-{
- CELL tag = TAG(tagged);
- if(tag == OBJECT_TYPE)
- return object_type(tagged);
- else
- return tag;
-}
-
-void primitive_slot(void);
-void primitive_set_slot(void);
-void primitive_integer_slot(void);
-void primitive_set_integer_slot(void);
projects / factor.git / commitdiff