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

starting generational GC

cvs
Slava Pestov 2005-05-11 02:30:58 +00:00
parent e1b6d9affa
commit 16c95ca373
21 changed files with 381 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Makefile
View File

@ -1,16 +1,22 @@
CC = gcc
DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
#DEFAULT_CFLAGS = -g $(SITE_CFLAGS)
#DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
DEFAULT_CFLAGS = -g
DEFAULT_LIBS = -lm
STRIP = strip
#STRIP = strip
STRIP = touch
UNIX_OBJS = native/unix/file.o native/unix/signal.o \
native/unix/ffi.o native/unix/run.o
UNIX_OBJS = native/unix/file.o \
native/unix/signal.o \
native/unix/ffi.o \
native/unix/run.o \
native/unix/memory.o
WIN32_OBJS = native/win32/ffi.o native/win32/file.o \
WIN32_OBJS = native/win32/ffi.o \
native/win32/file.o \
native/win32/misc.o \
native/win32/run.o
native/win32/run.o \
native/win32/memory.o
ifdef WIN32
PLAF_OBJS = $(WIN32_OBJS)

25
TODO.FACTOR.txt
View File

@ -1,6 +1,18 @@
- faster layout
- tiled window manager
- c primitive arrays: or just specialized arrays
float, complex, byte, char, cell...
- generational gc
- add a socket timeout
- virtual hosts
- keep alive
- sleep word
- update docs
- redo new compiler backend for PowerPC
- plugin: supportsBackspace
- if external factor is down, don't add tons of random shit to the
dictionary
- faster layout
- SDL_Rect** type
- get all-tests to run with -no-compile
- fix i/o on generic x86/ppc unix
@ -8,6 +20,7 @@
- 2map slow with lists
- nappend: instead of using push, enlarge the sequence with set-length
then add set the elements with set-nth
- faster sequence operations
- generic each some? all? memq? all=? index? subseq? map
- index and index* are very slow with lists
- unsafe-sbuf>string
@ -15,22 +28,16 @@
- GENERIC: map
- list impl same as now
- code walker & exceptions
- generational gc
- if two tasks write to a unix stream, the buffer can overflow
- rename prettyprint to pprint
- reader syntax for arrays, byte arrays, displaced aliens
- add a socket timeout
- virtual hosts
- keep alive
- dipping seq-2nmap, seq-2each
- array sort
- tiled window manager
- redo new compiler backend for PowerPC
- weird bug uncovered during bootstrap stress-test
- images saved from plugin do not work
- making an image from plugin hangs
- generic skip
- inference needs to be more robust with heavily recursive code
- investigate orphans
+ plugin:
@ -61,6 +68,8 @@
+ compiler:
- [ EAX 0 ] --> [ EAX ]
- intrinsic char-slot set-char-slot integer-slot set-integer-slot
- optimize the generic word prologue
- [ [ dup call ] dup call ] infer hangs
- more accurate types for various words

10
factor/FactorWord.java
View File

@ -107,6 +107,14 @@ public class FactorWord extends FactorArtifact implements FactorExternalizable,
//{{{ compareTo() method
public int compareTo(Object o)
{
return name.compareTo(((FactorWord)o).name);
int c = name.compareTo(((FactorWord)o).name);
if(c == 0)
{
return String.valueOf(vocabulary)
.compareTo(String.valueOf(
((FactorWord)o).vocabulary));
}
else
return c;
} //}}}
}

21
library/bootstrap/image.factor
View File

@ -65,12 +65,20 @@ SYMBOL: boot-quot
( relocation base at end of header ) base emit
( bootstrap quotation set later ) 0 emit
( global namespace set later ) 0 emit
( pointer to t object ) 0 emit
( pointer to bignum 0 ) 0 emit
( pointer to bignum 1 ) 0 emit
( pointer to bignum -1 ) 0 emit
( size of heap set later ) 0 emit ;
: boot-quot-offset 3 ;
: global-offset 4 ;
: heap-size-offset 5 ;
: header-size 6 ;
: t-offset 5 ;
: 0-offset 6 ;
: 1-offset 7 ;
: -1-offset 8 ;
: heap-size-offset 9 ;
: header-size 10 ;
GENERIC: ' ( obj -- ptr )
#! Write an object to the image.
@ -117,7 +125,8 @@ M: bignum ' ( bignum -- tagged )
! Padded with fixnums for 8-byte alignment
: t,
object-tag here-as "t" set
object-tag here-as
dup t-offset fixup "t" set
t-type >header emit
0 ' emit ;
@ -126,9 +135,9 @@ M: f ' ( obj -- ptr )
#! f is #define F RETAG(0,OBJECT_TYPE)
drop object-tag ;
: 0, 0 >bignum ' drop ;
: 1, 1 >bignum ' drop ;
: -1, -1 >bignum ' drop ;
: 0, 0 >bignum ' 0-offset fixup ;
: 1, 1 >bignum ' 1-offset fixup ;
: -1, -1 >bignum ' -1-offset fixup ;
( Beginning of the image )
! The image begins with the header, then T,

2
library/test/test.factor
View File

@ -11,7 +11,7 @@ M: assert error.
"Got: " write assert-got . ;
: assert= ( a b -- )
2dup = [ <assert> throw ] unless ;
2dup = [ 2drop ] [ <assert> throw ] ifte ;
: print-test ( input output -- )
"--> " write 2list . flush ;

7
native/bignum.c
View File

@ -207,13 +207,6 @@ void primitive_bignum_not(void)
untag_bignum_fast(dpeek()))));
}
void copy_bignum_constants(void)
{
COPY_OBJECT(bignum_zero);
COPY_OBJECT(bignum_pos_one);
COPY_OBJECT(bignum_neg_one);
}
void box_signed_cell(F_FIXNUM integer)
{
dpush(tag_integer(integer));

1
native/bignum.h
View File

@ -32,7 +32,6 @@ void primitive_bignum_lesseq(void);
void primitive_bignum_greater(void);
void primitive_bignum_greatereq(void);
void primitive_bignum_not(void);
void copy_bignum_constants(void);
INLINE CELL tag_integer(F_FIXNUM x)
{

5
native/compiler.c
View File

@ -2,7 +2,10 @@
void init_compiler(CELL size)
{
init_zone(&compiling,size);
compiling.base = compiling.here = (CELL)alloc_guarded(size);
if(compiling.base == 0)
fatal_error("Cannot allocate code heap",size);
compiling.limit = compiling.base + size;
last_flush = compiling.base;
}

18
native/factor.c
View File

@ -1,11 +1,12 @@
#include "factor.h"
void init_factor(char* image, CELL ds_size, CELL cs_size,
CELL data_size, CELL code_size, CELL literal_size)
CELL young_size, CELL aging_size,
CELL code_size, CELL literal_size)
{
srand((unsigned)time(NULL)); /* initialize random number generator */
init_ffi();
init_arena(data_size);
init_arena(young_size,aging_size);
init_compiler(code_size);
load_image(image,literal_size);
init_stacks(ds_size,cs_size);
@ -32,7 +33,8 @@ int main(int argc, char** argv)
{
CELL ds_size = 2048;
CELL cs_size = 2048;
CELL data_size = 16;
CELL young_size = 4;
CELL aging_size = 8;
CELL code_size = 2;
CELL literal_size = 64;
CELL args;
@ -44,7 +46,9 @@ int main(int argc, char** argv)
printf("Runtime options -- n is a number:\n");
printf(" +Dn Data stack size, kilobytes\n");
printf(" +Cn Call stack size, kilobytes\n");
printf(" +Mn Data heap size, megabytes\n");
printf(" +Yn Size of %d youngest generations, megabytes\n",
GC_GENERATIONS-1);
printf(" +An Size of tenured and semi-spaces, megabytes\n");
printf(" +Xn Code heap size, megabytes\n");
printf(" +Ln Literal table size, kilobytes. Only for bootstrapping\n");
printf("Other options are handled by the Factor library.\n");
@ -57,7 +61,8 @@ int main(int argc, char** argv)
{
if(factor_arg(argv[i],"+D%d",&ds_size)) continue;
if(factor_arg(argv[i],"+C%d",&cs_size)) continue;
if(factor_arg(argv[i],"+M%d",&data_size)) continue;
if(factor_arg(argv[i],"+Y%d",&young_size)) continue;
if(factor_arg(argv[i],"+A%d",&aging_size)) continue;
if(factor_arg(argv[i],"+X%d",&code_size)) continue;
if(factor_arg(argv[i],"+L%d",&literal_size)) continue;
@ -71,7 +76,8 @@ int main(int argc, char** argv)
init_factor(argv[1],
ds_size * 1024,
cs_size * 1024,
data_size * 1024 * 1024,
young_size * 1024 * 1024,
aging_size * 1024 * 1024,
code_size * 1024 * 1024,
literal_size * 1024);

57
native/gc.c
View File

@ -1,26 +1,23 @@
#include "factor.h"
/* Stop-and-copy garbage collection using Cheney's algorithm. */
/* #define GC_DEBUG */
INLINE void gc_debug(char* msg, CELL x) {
#ifdef GC_DEBUG
printf("%s %d\n",msg,x);
#endif
}
/* Generational copying garbage collector */
void collect_roots(void)
{
int i;
CELL ptr;
/*T must be the first in the heap */
gc_debug("root: t",T);
COPY_OBJECT(T);
/* the bignum 0 1 -1 constants must be the next three */
copy_bignum_constants();
gc_debug("root: bignum_zero",bignum_zero);
COPY_OBJECT(bignum_zero);
gc_debug("root: bignum_pos_one",bignum_pos_one);
COPY_OBJECT(bignum_pos_one);
gc_debug("root: bignum_neg_one",bignum_neg_one);
COPY_OBJECT(bignum_neg_one);
gc_debug("root: callframe",callframe);
COPY_OBJECT(callframe);
gc_debug("root: executing",executing);
COPY_OBJECT(executing);
for(ptr = ds_bot; ptr <= ds; ptr += CELLS)
@ -33,6 +30,32 @@ void collect_roots(void)
copy_handle(&userenv[i]);
}
void clear_cards(void)
{
BYTE *ptr;
for(ptr = cards; ptr < cards_end; ptr++)
clear_card(ptr);
}
void collect_cards(void)
{
BYTE *ptr;
for(ptr = cards; ptr < cards_end; ptr++)
{
CARD c = *ptr;
if(card_marked(*ptr))
{
CELL offset = (c & CARD_BASE_MASK);
if(offset == 0x7f)
critical_error("bad card",c);
CELL ea = (CELL)CARD_TO_ADDR(c) + offset;
printf("write barrier hit %d\n",offset);
printf("object header: %x\n",get(ea));
clear_card(ptr);
}
}
}
/*
Given a pointer to a tagged pointer to oldspace, copy it to newspace.
If the object has already been copied, return the forwarding
@ -43,11 +66,6 @@ CELL copy_object_impl(CELL pointer)
{
CELL newpointer;
#ifdef GC_DEBUG
if(in_zone(&active,pointer))
critical_error("copy_object given newspace ptr",pointer);
#endif
gc_debug("copy_object",pointer);
newpointer = (CELL)copy_untagged_object((void*)UNTAG(pointer),
object_size(pointer));
@ -120,7 +138,10 @@ void primitive_gc(void)
flip_zones();
scan = active.base;
collect_roots();
collect_cards();
/* collect literal objects referenced from compiled code */
collect_literals();

15
native/gc.h
View File

@ -16,12 +16,22 @@ INLINE void* copy_untagged_object(void* pointer, CELL size)
CELL copy_object_impl(CELL pointer);
/* #define GC_DEBUG */
INLINE void gc_debug(char* msg, CELL x) {
#ifdef GC_DEBUG
printf("%s %d\n",msg,x);
#endif
}
INLINE CELL copy_object(CELL pointer)
{
CELL tag;
CELL header;
CELL untagged;
gc_debug("copy object",pointer);
if(pointer == F)
return F;
@ -33,7 +43,10 @@ INLINE CELL copy_object(CELL pointer)
header = get(UNTAG(pointer));
untagged = UNTAG(header);
if(TAG(header) != FIXNUM_TYPE && in_zone(&active,untagged))
{
gc_debug("forwarding",untagged);
return RETAG(untagged,tag);
}
else
return RETAG(copy_object_impl(pointer),tag);
}
@ -46,6 +59,8 @@ INLINE void copy_handle(CELL* handle)
}
void collect_roots(void);
void collect_cards(void);
void clear_cards(void);
void primitive_gc(void);
void maybe_garbage_collection(void);
void primitive_gc_time(void);

25
native/image.c
View File

@ -1,5 +1,21 @@
#include "factor.h"
void init_objects(HEADER *h)
{
int i;
for(i = 0; i < USER_ENV; i++)
userenv[i] = F;
profile_depth = 0;
executing = F;
userenv[GLOBAL_ENV] = h->global;
userenv[BOOT_ENV] = h->boot;
T = h->t;
bignum_zero = h->bignum_zero;
bignum_pos_one = h->bignum_pos_one;
bignum_neg_one = h->bignum_neg_one;
}
void load_image(char* filename, int literal_table)
{
FILE* file;
@ -67,10 +83,7 @@ void load_image(char* filename, int literal_table)
printf(" relocating...");
fflush(stdout);
clear_environment();
userenv[GLOBAL_ENV] = h.global;
userenv[BOOT_ENV] = h.boot;
init_objects(&h);
relocate_data();
relocate_code();
@ -97,6 +110,10 @@ bool save_image(char* filename)
h.boot = userenv[BOOT_ENV];
h.size = active.here - active.base;
h.global = userenv[GLOBAL_ENV];
h.t = T;
h.bignum_zero = bignum_zero;
h.bignum_pos_one = bignum_pos_one;
h.bignum_neg_one = bignum_neg_one;
fwrite(&h,sizeof(HEADER),1,file);
ext_h.size = compiling.here - compiling.base;

9
native/image.h
View File

@ -12,6 +12,14 @@ typedef struct {
CELL boot;
/* tagged pointer to global namespace */
CELL global;
/* tagged pointer to t singleton */
CELL t;
/* tagged pointer to bignum 0 */
CELL bignum_zero;
/* tagged pointer to bignum 1 */
CELL bignum_pos_one;
/* tagged pointer to bignum -1 */
CELL bignum_neg_one;
/* size of heap */
CELL size;
} HEADER;
@ -28,6 +36,7 @@ typedef struct EXT_HEADER {
CELL literal_max;
} HEADER_2;
void init_objects(HEADER *h);
void load_image(char* file, int literal_size);
bool save_image(char* file);
void primitive_save_image(void);

92
native/memory.c
View File

@ -1,64 +1,65 @@
#include "factor.h"
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
#ifdef WIN32
void *alloc_guarded(CELL size)
void dump_generations(void)
{
SYSTEM_INFO si;
char *mem;
DWORD ignore;
GetSystemInfo(&si);
mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (CELL)mem);
if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (CELL)mem);
return mem + si.dwPageSize;
int i;
for(i = 0; i < GC_GENERATIONS; i++)
{
fprintf(stderr,"Generation %d: base=%d, size=%d, here=%d\n",
i,
generations[i].base,
generations[i].limit - generations[i].base,
generations[i].here);
}
#else
void* alloc_guarded(CELL size)
{
int pagesize = getpagesize();
char* array = mmap((void*)0,pagesize + size + pagesize,
PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_ANON | MAP_PRIVATE,-1,0);
fprintf(stderr,"Semispace: base=%d, size=%d, here=%d\n",
prior.base,
prior.limit - prior.base,
prior.here);
if(mprotect(array,pagesize,PROT_NONE) == -1)
fatal_error("Cannot allocate low guard page",(CELL)array);
if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
fatal_error("Cannot allocate high guard page",(CELL)array);
/* return bottom of actual array */
return array + pagesize;
fprintf(stderr,"Cards: base=%d, size=%d\n",cards,cards_end - cards);
}
#endif
void init_zone(ZONE* z, CELL size)
CELL init_zone(ZONE *z, CELL size, CELL base)
{
z->base = z->here = align8((CELL)alloc_guarded(size));
if(z->base == 0)
fatal_error("Cannot allocate zone",size);
z->base = z->here = base;
z->limit = z->base + size;
z->alarm = z->base + (size * 3) / 4;
z->base = align8(z->base);
return z->limit;
}
void init_arena(CELL size)
/* input parameters must be 8 byte aligned */
void init_arena(CELL young_size, CELL aging_size)
{
init_zone(&active,size);
init_zone(&prior,size);
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);
cards = alloc_guarded(cards_size);
cards_end = cards + cards_size;
clear_cards();
int i;
CELL alloter = heap_start;
if(heap_start == 0)
fatal_error("Cannot allocate data heap",total_size);
alloter = init_zone(&generations[TENURED],aging_size,alloter);
alloter = init_zone(&prior,aging_size,alloter);
for(i = 0; i < GC_GENERATIONS - 1; i++)
alloter = init_zone(&generations[i],young_size,alloter);
if(alloter != heap_start + total_size)
fatal_error("Oops",alloter);
allot_profiling = false;
gc_in_progress = false;
heap_scan = false;
gc_time = 0;
dump_generations();
}
void allot_profile_step(CELL a)
@ -90,11 +91,6 @@ void flip_zones()
active.here = active.base;
}
bool in_zone(ZONE* z, CELL pointer)
{
return pointer >= z->base && pointer < z->limit;
}
void primitive_room(void)
{
box_signed_cell(compiling.limit - compiling.here);

159
native/memory.h
View File

@ -1,36 +1,5 @@
typedef struct {
CELL base;
CELL here;
CELL alarm;
CELL limit;
} ZONE;
ZONE active;
ZONE prior;
bool allot_profiling;
void* alloc_guarded(CELL size);
void init_zone(ZONE* zone, CELL size);
void init_arena(CELL size);
void flip_zones();
void allot_profile_step(CELL a);
INLINE CELL align8(CELL a)
{
return ((a & 7) == 0) ? a : ((a + 8) & ~7);
}
INLINE void* allot(CELL a)
{
CELL h = active.here;
active.here += align8(a);
if(allot_profiling)
allot_profile_step(align8(a));
return (void*)h;
}
/* macros for reading/writing memory, useful when working around
C's type system */
INLINE CELL get(CELL where)
{
return *((CELL*)where);
@ -61,6 +30,130 @@ INLINE void bput(CELL where, BYTE what)
*((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)
{
return pointer >= z->base && pointer < z->limit;
}
/* 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];
CELL heap_start;
#define active generations[TENURED]
/* spare semi-space; rotates with generations[TENURED]. */
ZONE prior;
/* 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 16
#define CARD_BITS 4
#define CARD_MASK CARD_SIZE-1
INLINE CARD card_marked(CARD c)
{
return c & CARD_MARK_MASK;
}
INLINE void clear_card(CARD *c)
{
*c = CARD_BASE_MASK;
}
INLINE u8 card_base(CARD c)
{
return c & CARD_BASE_MASK;
}
INLINE void rebase_card(CARD *c, u8 base)
{
*c = base;
}
#define ADDR_TO_CARD(a) (CARD*)(((a-heap_start)>>CARD_BITS)+(CELL)cards)
#define CARD_TO_ADDR(c) (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 *c = ADDR_TO_CARD(address);
/* we need to remember the first object allocated in the
card */
rebase_card(c,MIN(card_base(*c),address & CARD_MASK));
}
bool allot_profiling;
/* set up guard pages to check for under/overflow.
size must be a multiple of the page size */
void* alloc_guarded(CELL size);
void dump_generations(void);
CELL init_zone(ZONE *z, CELL size, CELL base);
void init_arena(CELL young_size, CELL aging_size);
void flip_zones();
void allot_profile_step(CELL a);
INLINE CELL align8(CELL a)
{
return ((a & 7) == 0) ? a : ((a + 8) & ~7);
}
INLINE void* allot(CELL a)
{
CELL h = active.here;
allot_barrier(h);
active.here += align8(a);
if(allot_profiling)
allot_profile_step(align8(a));
return (void*)h;
}
bool in_zone(ZONE* z, CELL pointer);
void primitive_room(void);

26
native/relocate.c
View File

@ -2,6 +2,8 @@
void relocate_object(CELL relocating)
{
allot_barrier(relocating);
switch(untag_header(get(relocating)))
{
case WORD_TYPE:
@ -51,28 +53,20 @@ INLINE CELL relocate_data_next(CELL relocating)
return relocating + size;
}
INLINE CELL init_object(CELL relocating, CELL* handle, CELL type)
{
if(untag_header(get(relocating)) != type)
fatal_error("init_object() failed",get(relocating));
*handle = tag_object((CELL*)relocating);
return relocate_data_next(relocating);
}
void relocate_data()
{
CELL relocating = active.base;
data_fixup(&userenv[BOOT_ENV]);
data_fixup(&userenv[GLOBAL_ENV]);
/* The first object in the image must always T */
relocating = init_object(relocating,&T,T_TYPE);
/* The next three must be bignum 0, 1, -1 */
relocating = init_object(relocating,&bignum_zero,BIGNUM_TYPE);
relocating = init_object(relocating,&bignum_pos_one,BIGNUM_TYPE);
relocating = init_object(relocating,&bignum_neg_one,BIGNUM_TYPE);
printf("%d\n",T);
printf("%d\n",bignum_zero);
printf("%d\n",bignum_pos_one);
printf("%d\n",bignum_neg_one);
data_fixup(&T);
data_fixup(&bignum_zero);
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
for(;;)
{

9
native/run.c
View File

@ -1,14 +1,5 @@
#include "factor.h"
void clear_environment(void)
{
int i;
for(i = 0; i < USER_ENV; i++)
userenv[i] = F;
profile_depth = 0;
executing = F;
}
INLINE void execute(F_WORD* word)
{
((XT)(word->xt))(word);

2
native/run.h
View File

@ -85,8 +85,6 @@ INLINE void call(CELL quot)
callframe = quot;
}
void clear_environment(void);
void run(void);
void platform_run(void);
void undefined(F_WORD* word);

11
native/types.c
View File

@ -96,34 +96,35 @@ void primitive_type(void)
drepl(tag_fixnum(type_of(dpeek())));
}
#define SLOT(obj,slot) UNTAG(obj) + slot * CELLS
#define SLOT(obj,slot) ((obj) + (slot) * CELLS)
void primitive_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
CELL obj = UNTAG(dpop());
dpush(get(SLOT(obj,slot)));
}
void primitive_set_slot(void)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = 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 = 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 = dpop();
CELL obj = UNTAG(dpop());
F_FIXNUM value = to_fixnum(dpop());
put(SLOT(obj,slot),value);
}

19
native/unix/memory.c Normal file
View File

@ -0,0 +1,19 @@
#include "../factor.h"
void *alloc_guarded(CELL size)
{
int pagesize = getpagesize();
char* array = mmap((void*)0,pagesize + size + pagesize,
PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_ANON | MAP_PRIVATE,-1,0);
if(mprotect(array,pagesize,PROT_NONE) == -1)
fatal_error("Cannot allocate low guard page",(CELL)array);
if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
fatal_error("Cannot allocate high guard page",(CELL)array);
/* return bottom of actual array */
return array + pagesize;
}

19
native/win32/memory.c Normal file
View File

@ -0,0 +1,19 @@
#include "../factor.h"
void *alloc_guarded(CELL size)
{
SYSTEM_INFO si;
char *mem;
DWORD ignore;
GetSystemInfo(&si);
mem = (char *)VirtualAlloc(NULL, si.dwPageSize*2 + size, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
if (!VirtualProtect(mem, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate low guard page", (CELL)mem);
if (!VirtualProtect(mem+size+si.dwPageSize, si.dwPageSize, PAGE_NOACCESS, &ignore))
fatal_error("Cannot allocate high guard page", (CELL)mem);
return mem + si.dwPageSize;
}