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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2009-03-20 09:34:39 -05:00
parent 3b1d088abd b6e5bac483
commit ea614e6a5f
26 changed files with 233 additions and 220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/codegen/codegen.factor
View File

@ -53,7 +53,7 @@ SYMBOL: labels
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
compiled-stack-traces? compiling-word get f ? add-literal drop ;
compiled-stack-traces? compiling-word get f ? add-literal ;
: generate ( mr -- asm )
[

32
basis/compiler/codegen/fixup/fixup.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
@ -28,51 +28,47 @@ M: label-fixup fixup*
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
3array label-table get push ;
TUPLE: rel-fixup arg class type ;
TUPLE: rel-fixup class type ;
: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: rel-fixup ( class type -- ) \ rel-fixup boa , ;
: push-4 ( value vector -- )
[ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
swap set-alien-unsigned-4 ;
M: rel-fixup fixup*
[ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
[ relocation-table get push-4 ] bi@ ;
[ type>> ]
[ class>> ]
[ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
{ 0 24 28 } bitfield
relocation-table get push-4 ;
M: integer fixup* , ;
: indq ( elt seq -- n ) [ eq? ] with find drop ;
: adjoin* ( obj table -- n )
2dup indq [ 2nip ] [ dup length [ push ] dip ] if* ;
SYMBOL: literal-table
: add-literal ( obj -- n ) literal-table get adjoin* ;
: add-literal ( obj -- ) literal-table get push ;
: add-dlsym-literals ( symbol dll -- )
[ string>symbol ] dip 2array literal-table get push-all ;
[ string>symbol add-literal ] [ add-literal ] bi* ;
: rel-dlsym ( name dll class -- )
[ literal-table get length [ add-dlsym-literals ] dip ] dip
rt-dlsym rel-fixup ;
[ add-dlsym-literals ] dip rt-dlsym rel-fixup ;
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
: rel-primitive ( word class -- )
[ def>> first ] dip rt-primitive rel-fixup ;
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
: rel-immediate ( literal class -- )
[ add-literal ] dip rt-immediate rel-fixup ;
: rel-this ( class -- )
0 swap rt-label rel-fixup ;
rt-this rel-fixup ;
: rel-here ( offset class -- )
rt-here rel-fixup ;
[ add-literal ] dip rt-here rel-fixup ;
: init-fixup ( -- )
BV{ } clone relocation-table set

4
basis/compiler/constants/constants.factor
View File

@ -23,7 +23,7 @@ CONSTANT: deck-bits 18
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
! Relocation classes
CONSTANT: rc-absolute-cell 0
@ -42,7 +42,7 @@ CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
CONSTANT: rt-here 4
CONSTANT: rt-label 5
CONSTANT: rt-this 5
CONSTANT: rt-immediate 6
CONSTANT: rt-stack-chain 7

2
basis/cpu/ppc/bootstrap.factor
View File

@ -41,7 +41,7 @@ big-endian on
stack-frame 6 LI
6 1 next-save STW
0 1 lr-save stack-frame + STW
] rc-absolute-ppc-2/2 rt-label 1 jit-prolog jit-define
] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
[
0 6 LOAD32

2
basis/cpu/x86/bootstrap.factor
View File

@ -32,7 +32,7 @@ big-endian off
temp0 PUSH
! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB
] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
[
! load literal

14
basis/http/server/server.factor
View File

@ -45,10 +45,13 @@ ERROR: no-boundary ;
";" split1 nip
"=" split1 nip [ no-boundary ] unless* ;
SYMBOL: upload-limit
: read-multipart-data ( request -- mime-parts )
[ "content-type" header ]
[ "content-length" header string>number ] bi
unlimit-input
unlimited-input
upload-limit get stream-throws limit-input
stream-eofs limit-input
binary decode-input
parse-multipart-form-data parse-multipart ;
@ -252,10 +255,13 @@ LOG: httpd-benchmark DEBUG
TUPLE: http-server < threaded-server ;
SYMBOL: request-limit
64 1024 * request-limit set-global
M: http-server handle-client*
drop
[
64 1024 * stream-throws limit-input
drop [
request-limit get stream-throws limit-input
?refresh-all
[ read-request ] ?benchmark
[ do-request ] ?benchmark

4
basis/io/encodings/iana/iana.factor
View File

@ -10,10 +10,10 @@ SYMBOL: e>n-table
SYMBOL: aliases
PRIVATE>
: name>encoding ( name -- encoding/f )
: name>encoding ( name -- encoding )
n>e-table get-global at ;
: encoding>name ( encoding -- name/f )
: encoding>name ( encoding -- name )
e>n-table get-global at ;
<PRIVATE

18
basis/io/streams/limited/limited-docs.factor
View File

@ -5,14 +5,14 @@ IN: io.streams.limited
HELP: <limited-stream>
{ $values
{ "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
{ "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
{ "stream'" "an input stream" }
}
{ $description "Constructs a new " { $link limited-stream } " from an existing stream. User code should use " { $link limit } " or " { $link limit-input } "." } ;
HELP: limit
{ $values
{ "stream" "an input stream" } { "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
{ "stream" "an input stream" } { "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
{ "stream'" "a stream" }
}
{ $description "Changes a decoder's stream to be a limited stream, or wraps " { $snippet "stream" } " in a " { $link limited-stream } "." }
@ -36,7 +36,7 @@ HELP: limit
}
} ;
HELP: unlimit
HELP: unlimited
{ $values
{ "stream" "an input stream" }
{ "stream'" "a stream" }
@ -51,22 +51,22 @@ HELP: limited-stream
HELP: limit-input
{ $values
{ "limit" integer } { "mode" "a " { $link limited-stream } " mode singleton" }
{ "limit" integer } { "mode" { $link stream-throws } " or " { $link stream-eofs } }
}
{ $description "Wraps the current " { $link input-stream } " in a " { $link limited-stream } "." } ;
HELP: unlimit-input
HELP: unlimited-input
{ $description "Returns the underlying stream of the limited-stream stored in " { $link input-stream } "." } ;
HELP: stream-eofs
{ $values
{ "value" "a " { $link limited-stream } " mode singleton" }
{ "value" { $link stream-throws } " or " { $link stream-eofs } }
}
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will return " { $link f } " upon exhaustion." } ;
HELP: stream-throws
{ $values
{ "value" "a " { $link limited-stream } " mode singleton" }
{ "value" { $link stream-throws } " or " { $link stream-eofs } }
}
{ $description "If the " { $slot "mode" } " of a limited stream is set to this singleton, the stream will throw " { $link limit-exceeded } " upon exhaustion." } ;
@ -79,9 +79,9 @@ ARTICLE: "io.streams.limited" "Limited input streams"
"Wrap the current " { $link input-stream } " in a limited stream:"
{ $subsection limit-input }
"Unlimits a limited stream:"
{ $subsection unlimit }
{ $subsection unlimited }
"Unlimits the current " { $link input-stream } ":"
{ $subsection unlimit-input }
{ $subsection unlimited-input }
"Make a limited stream throw an exception on exhaustion:"
{ $subsection stream-throws }
"Make a limited stream return " { $link f } " on exhaustion:"

6
basis/io/streams/limited/limited-tests.factor
View File

@ -57,13 +57,13 @@ IN: io.streams.limited.tests
[ t ]
[
"abc" <string-reader> 3 stream-eofs limit unlimit
"abc" <string-reader> 3 stream-eofs limit unlimited
"abc" <string-reader> =
] unit-test
[ t ]
[
"abc" <string-reader> 3 stream-eofs limit unlimit
"abc" <string-reader> 3 stream-eofs limit unlimited
"abc" <string-reader> =
] unit-test
@ -71,7 +71,7 @@ IN: io.streams.limited.tests
[
[
"resource:license.txt" utf8 <file-reader> &dispose
3 stream-eofs limit unlimit
3 stream-eofs limit unlimited
"resource:license.txt" utf8 <file-reader> &dispose
[ decoder? ] both?
] with-destructors

10
basis/io/streams/limited/limited.factor
View File

@ -24,20 +24,20 @@ M: decoder limit ( stream limit mode -- stream' )
M: object limit ( stream limit mode -- stream' )
<limited-stream> ;
GENERIC: unlimit ( stream -- stream' )
GENERIC: unlimited ( stream -- stream' )
M: decoder unlimit ( stream -- stream' )
M: decoder unlimited ( stream -- stream' )
[ stream>> ] change-stream ;
M: object unlimit ( stream -- stream' )
M: object unlimited ( stream -- stream' )
stream>> stream>> ;
: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
: unlimit-input ( -- ) input-stream [ unlimit ] change ;
: unlimited-input ( -- ) input-stream [ unlimited ] change ;
: with-unlimited-stream ( stream quot -- )
[ clone unlimit ] dip call ; inline
[ clone unlimited ] dip call ; inline
: with-limited-stream ( stream limit mode quot -- )
[ limit ] dip call ; inline

6
basis/tools/profiler/profiler-tests.factor
View File

@ -25,7 +25,7 @@ words ;
: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ;
: foobar ;
: foobar ( -- ) ;
[
[ ] [ callback-test indirect-test ] unit-test
@ -34,9 +34,9 @@ words ;
[ 1 ] [ \ foobar counter>> ] unit-test
: fooblah { } [ ] each ;
: fooblah ( -- ) { } [ ] like call ;
: foobaz fooblah fooblah ;
: foobaz ( -- ) fooblah fooblah ;
[ foobaz ] profile

2
extra/project-euler/050/050.factor
View File

@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel locals math math.primes sequences ;
USING: arrays kernel locals math math.primes sequences project-euler.common ;
IN: project-euler.050
! http://projecteuler.net/index.php?section=problems&id=50

2
vm/callstack.c
View File

@ -97,7 +97,7 @@ F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
CELL frame_type(F_STACK_FRAME *frame)
{
return frame_code(frame)->type;
return frame_code(frame)->block.type;
}
CELL frame_executing(F_STACK_FRAME *frame)

105
vm/code_block.c
View File

@ -1,9 +1,8 @@
#include "master.h"
void flush_icache_for(F_CODE_BLOCK *compiled)
void flush_icache_for(F_CODE_BLOCK *block)
{
CELL start = (CELL)(compiled + 1);
flush_icache(start,compiled->code_length);
flush_icache((CELL)block,block->block.size);
}
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
@ -12,12 +11,34 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
CELL index = 1;
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
while(rel < rel_end)
{
iter(rel,compiled);
iter(*rel,index,compiled);
switch(REL_TYPE(*rel))
{
case RT_PRIMITIVE:
case RT_XT:
case RT_IMMEDIATE:
case RT_HERE:
index++;
break;
case RT_DLSYM:
index += 2;
break;
case RT_THIS:
case RT_STACK_CHAIN:
break;
default:
critical_error("Bad rel type",*rel);
return; /* Can't happen */
}
rel++;
}
}
@ -86,13 +107,13 @@ void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_valu
}
}
void update_literal_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value = array_nth(literals,REL_ARGUMENT(rel));
F_FIXNUM absolute_value = array_nth(literals,index);
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
}
}
@ -108,12 +129,12 @@ void update_literal_references(F_CODE_BLOCK *compiled)
aging and nursery collections */
void copy_literal_references(F_CODE_BLOCK *compiled)
{
if(collecting_gen >= compiled->last_scan)
if(collecting_gen >= compiled->block.last_scan)
{
if(collecting_accumulation_gen_p())
compiled->last_scan = collecting_gen;
compiled->block.last_scan = collecting_gen;
else
compiled->last_scan = collecting_gen + 1;
compiled->block.last_scan = collecting_gen + 1;
/* initialize chase pointer */
CELL scan = newspace->here;
@ -137,13 +158,13 @@ CELL object_xt(CELL obj)
return (CELL)untag_quotation(obj)->xt;
}
void update_word_references_step(F_REL *rel, F_CODE_BLOCK *compiled)
void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
if(REL_TYPE(rel) == RT_XT)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
CELL xt = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
CELL xt = object_xt(array_nth(literals,index));
store_address_in_code_block(REL_CLASS(rel),offset,xt);
}
}
@ -154,7 +175,7 @@ to update references to other words, without worrying about literals
or dlsyms. */
void update_word_references(F_CODE_BLOCK *compiled)
{
if(compiled->needs_fixup)
if(compiled->block.needs_fixup)
relocate_code_block(compiled);
else
{
@ -170,7 +191,7 @@ is added to the heap. */
collections */
void mark_code_block(F_CODE_BLOCK *compiled)
{
mark_block(compiled_to_block(compiled));
mark_block(&compiled->block);
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
@ -229,11 +250,10 @@ void undefined_symbol(void)
}
/* Look up an external library symbol referenced by a compiled code block */
void *get_rel_symbol(F_REL *rel, F_ARRAY *literals)
void *get_rel_symbol(F_ARRAY *literals, CELL index)
{
CELL arg = REL_ARGUMENT(rel);
CELL symbol = array_nth(literals,arg);
CELL library = array_nth(literals,arg + 1);
CELL symbol = array_nth(literals,index);
CELL library = array_nth(literals,index + 1);
F_DLL *dll = (library == F ? NULL : untag_dll(library));
@ -266,37 +286,37 @@ void *get_rel_symbol(F_REL *rel, F_ARRAY *literals)
}
/* Compute an address to store at a relocation */
void relocate_code_block_step(F_REL *rel, F_CODE_BLOCK *compiled)
void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
{
CELL offset = rel->offset + (CELL)(compiled + 1);
CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
F_ARRAY *literals = untag_object(compiled->literals);
F_FIXNUM absolute_value;
switch(REL_TYPE(rel))
{
case RT_PRIMITIVE:
absolute_value = (CELL)primitives[REL_ARGUMENT(rel)];
absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))];
break;
case RT_DLSYM:
absolute_value = (CELL)get_rel_symbol(rel,literals);
absolute_value = (CELL)get_rel_symbol(literals,index);
break;
case RT_IMMEDIATE:
absolute_value = array_nth(literals,REL_ARGUMENT(rel));
absolute_value = array_nth(literals,index);
break;
case RT_XT:
absolute_value = object_xt(array_nth(literals,REL_ARGUMENT(rel)));
absolute_value = object_xt(array_nth(literals,index));
break;
case RT_HERE:
absolute_value = rel->offset + (CELL)(compiled + 1) + (short)REL_ARGUMENT(rel);
absolute_value = offset + (short)to_fixnum(array_nth(literals,index));
break;
case RT_LABEL:
absolute_value = (CELL)(compiled + 1) + REL_ARGUMENT(rel);
case RT_THIS:
absolute_value = (CELL)(compiled + 1);
break;
case RT_STACK_CHAIN:
absolute_value = (CELL)&stack_chain;
break;
default:
critical_error("Bad rel type",rel->type);
critical_error("Bad rel type",rel);
return; /* Can't happen */
}
@ -306,8 +326,8 @@ void relocate_code_block_step(F_REL *rel, F_CODE_BLOCK *compiled)
/* Perform all fixups on a code block */
void relocate_code_block(F_CODE_BLOCK *compiled)
{
compiled->last_scan = NURSERY;
compiled->needs_fixup = false;
compiled->block.last_scan = NURSERY;
compiled->block.needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
}
@ -361,18 +381,18 @@ CELL compiled_code_format(void)
}
/* Might GC */
void *allot_code_block(CELL size)
F_CODE_BLOCK *allot_code_block(CELL size)
{
void *start = heap_allot(&code_heap,size);
F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
/* If allocation failed, do a code GC */
if(start == NULL)
if(block == NULL)
{
gc();
start = heap_allot(&code_heap,size);
block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
/* Insufficient room even after code GC, give up */
if(start == NULL)
if(block == NULL)
{
CELL used, total_free, max_free;
heap_usage(&code_heap,&used,&total_free,&max_free);
@ -385,11 +405,11 @@ void *allot_code_block(CELL size)
}
}
return start;
return (F_CODE_BLOCK *)block;
}
/* Might GC */
F_CODE_BLOCK *add_compiled_block(
F_CODE_BLOCK *add_code_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,
@ -404,7 +424,7 @@ F_CODE_BLOCK *add_compiled_block(
REGISTER_UNTAGGED(code);
REGISTER_UNTAGGED(labels);
F_CODE_BLOCK *compiled = allot_code_block(sizeof(F_CODE_BLOCK) + code_length);
F_CODE_BLOCK *compiled = allot_code_block(code_length);
UNREGISTER_UNTAGGED(labels);
UNREGISTER_UNTAGGED(code);
@ -412,10 +432,9 @@ F_CODE_BLOCK *add_compiled_block(
UNREGISTER_ROOT(literals);
/* compiled header */
compiled->type = type;
compiled->last_scan = NURSERY;
compiled->needs_fixup = true;
compiled->code_length = code_length;
compiled->block.type = type;
compiled->block.last_scan = NURSERY;
compiled->block.needs_fixup = true;
compiled->literals = literals;
compiled->relocation = relocation;

24
vm/code_block.h
View File

@ -9,8 +9,8 @@ typedef enum {
RT_XT,
/* current offset */
RT_HERE,
/* a local label */
RT_LABEL,
/* current code block */
RT_THIS,
/* immediate literal */
RT_IMMEDIATE,
/* address of stack_chain var */
@ -43,21 +43,15 @@ typedef enum {
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
/* the rel type is built like a cell to avoid endian-specific code in
the compiler */
#define REL_TYPE(r) ((r)->type & 0x000000ff)
#define REL_CLASS(r) (((r)->type & 0x0000ff00) >> 8)
#define REL_ARGUMENT(r) (((r)->type & 0xffff0000) >> 16)
/* code relocation consists of a table of entries for each fixup */
typedef struct {
unsigned int type;
unsigned int offset;
} F_REL;
/* code relocation table consists of a table of entries for each fixup */
typedef u32 F_REL;
#define REL_TYPE(r) (((r) & 0xf0000000) >> 28)
#define REL_CLASS(r) (((r) & 0x0f000000) >> 24)
#define REL_OFFSET(r) ((r) & 0x00ffffff)
void flush_icache_for(F_CODE_BLOCK *compiled);
typedef void (*RELOCATION_ITERATOR)(F_REL *rel, F_CODE_BLOCK *compiled);
typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled);
void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
@ -83,7 +77,7 @@ CELL compiled_code_format(void);
bool stack_traces_p(void);
F_CODE_BLOCK *add_compiled_block(
F_CODE_BLOCK *add_code_block(
CELL type,
F_ARRAY *code,
F_ARRAY *labels,

46
vm/code_gc.c
View File

@ -13,7 +13,7 @@ void new_heap(F_HEAP *heap, CELL size)
/* If there is no previous block, next_free becomes the head of the free list,
else its linked in */
INLINE void update_free_list(F_HEAP *heap, F_BLOCK *prev, F_BLOCK *next_free)
INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free)
{
if(prev)
prev->next_free = next_free;
@ -28,18 +28,18 @@ compiling.limit. */
void build_free_list(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
F_BLOCK *prev_free = NULL;
F_FREE_BLOCK *prev_free = NULL;
F_BLOCK *scan = first_block(heap);
F_BLOCK *end = (F_BLOCK *)(heap->segment->start + size);
F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
/* Add all free blocks to the free list */
while(scan && scan < end)
while(scan && scan < (F_BLOCK *)end)
{
switch(scan->status)
{
case B_FREE:
update_free_list(heap,prev_free,scan);
prev_free = scan;
update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan);
prev_free = (F_FREE_BLOCK *)scan;
break;
case B_ALLOCATED:
break;
@ -56,9 +56,9 @@ void build_free_list(F_HEAP *heap, CELL size)
branch is only taken after loading a new image, not after code GC */
if((CELL)(end + 1) <= heap->segment->end)
{
end->status = B_FREE;
end->block.status = B_FREE;
end->block.size = heap->segment->end - (CELL)end;
end->next_free = NULL;
end->size = heap->segment->end - (CELL)end;
/* add final free block */
update_free_list(heap,prev_free,end);
@ -80,21 +80,19 @@ void build_free_list(F_HEAP *heap, CELL size)
}
/* Allocate a block of memory from the mark and sweep GC heap */
void *heap_allot(F_HEAP *heap, CELL size)
F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
{
F_BLOCK *prev = NULL;
F_BLOCK *scan = heap->free_list;
F_FREE_BLOCK *prev = NULL;
F_FREE_BLOCK *scan = heap->free_list;
size = (size + 31) & ~31;
while(scan)
{
CELL this_size = scan->size - sizeof(F_BLOCK);
if(scan->status != B_FREE)
if(scan->block.status != B_FREE)
critical_error("Invalid block in free list",(CELL)scan);
if(this_size < size)
if(scan->block.size < size)
{
prev = scan;
scan = scan->next_free;
@ -102,9 +100,9 @@ void *heap_allot(F_HEAP *heap, CELL size)
}
/* we found a candidate block */
F_BLOCK *next_free;
F_FREE_BLOCK *next_free;
if(this_size - size <= sizeof(F_BLOCK))
if(scan->block.size - size <= sizeof(F_BLOCK) * 2)
{
/* too small to be split */
next_free = scan->next_free;
@ -112,12 +110,11 @@ void *heap_allot(F_HEAP *heap, CELL size)
else
{
/* split the block in two */
CELL new_size = size + sizeof(F_BLOCK);
F_BLOCK *split = (F_BLOCK *)((CELL)scan + new_size);
split->status = B_FREE;
split->size = scan->size - new_size;
F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size);
split->block.status = B_FREE;
split->block.size = scan->block.size - size;
split->next_free = scan->next_free;
scan->size = new_size;
scan->block.size = size;
next_free = split;
}
@ -125,9 +122,8 @@ void *heap_allot(F_HEAP *heap, CELL size)
update_free_list(heap,prev,next_free);
/* this is our new block */
scan->status = B_ALLOCATED;
return scan + 1;
scan->block.status = B_ALLOCATED;
return &scan->block;
}
return NULL;

25
vm/code_gc.h
View File

@ -1,32 +1,11 @@
typedef enum
{
B_FREE,
B_ALLOCATED,
B_MARKED
} F_BLOCK_STATUS;
typedef struct _F_BLOCK
{
F_BLOCK_STATUS status;
/* In bytes, includes this header */
CELL size;
/* Filled in on image load */
struct _F_BLOCK *next_free;
/* Used during compaction */
struct _F_BLOCK *forwarding;
} F_BLOCK;
typedef struct {
F_SEGMENT *segment;
F_BLOCK *free_list;
F_FREE_BLOCK *free_list;
} F_HEAP;
void new_heap(F_HEAP *heap, CELL size);
void build_free_list(F_HEAP *heap, CELL size);
void *heap_allot(F_HEAP *heap, CELL size);
F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
void mark_block(F_BLOCK *block);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);

8
vm/code_heap.c
View File

@ -14,7 +14,7 @@ bool in_code_heap_p(CELL ptr)
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
{
if(compiled->type != WORD_TYPE)
if(compiled->block.type != WORD_TYPE)
critical_error("bad param to set_word_xt",(CELL)compiled);
word->code = compiled;
@ -40,7 +40,7 @@ void iterate_code_heap(CODE_HEAP_ITERATOR iter)
while(scan)
{
if(scan->status != B_FREE)
iter(block_to_compiled(scan));
iter((F_CODE_BLOCK *)scan);
scan = next_block(&code_heap,scan);
}
}
@ -103,7 +103,7 @@ void primitive_modify_code_heap(void)
REGISTER_UNTAGGED(alist);
REGISTER_UNTAGGED(word);
F_CODE_BLOCK *compiled = add_compiled_block(
F_CODE_BLOCK *compiled = add_code_block(
WORD_TYPE,
code,
labels,
@ -137,7 +137,7 @@ void primitive_code_room(void)
F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
{
return block_to_compiled(compiled_to_block(compiled)->forwarding);
return (F_CODE_BLOCK *)compiled->block.forwarding;
}
void forward_frame_xt(F_STACK_FRAME *frame)

10
vm/code_heap.h
View File

@ -1,16 +1,6 @@
/* compiled code */
F_HEAP code_heap;
INLINE F_BLOCK *compiled_to_block(F_CODE_BLOCK *compiled)
{
return (F_BLOCK *)compiled - 1;
}
INLINE F_CODE_BLOCK *block_to_compiled(F_BLOCK *block)
{
return (F_CODE_BLOCK *)(block + 1);
}
void init_code_heap(CELL size);
bool in_code_heap_p(CELL ptr);

2
vm/data_gc.h
View File

@ -30,7 +30,7 @@ u64 decks_scanned;
CELL code_heap_scans;
/* What generation was being collected when copy_code_heap_roots() was last
called? Until the next call to add_compiled_block(), future
called? Until the next call to add_code_block(), future
collections of younger generations don't have to touch the code
heap. */
CELL last_code_heap_scan;

4
vm/debug.c
View File

@ -324,11 +324,11 @@ void dump_code_heap(void)
status = "free";
break;
case B_ALLOCATED:
size += object_size(block_to_compiled(scan)->relocation);
size += object_size(((F_CODE_BLOCK *)scan)->relocation);
status = "allocated";
break;
case B_MARKED:
size += object_size(block_to_compiled(scan)->relocation);
size += object_size(((F_CODE_BLOCK *)scan)->relocation);
status = "marked";
break;
default:

30
vm/layouts.h
View File

@ -102,12 +102,38 @@ typedef struct {
} F_STRING;
/* The compiled code heap is structured into blocks. */
typedef struct
typedef enum
{
B_FREE,
B_ALLOCATED,
B_MARKED
} F_BLOCK_STATUS;
typedef struct _F_BLOCK
{
char status; /* free or allocated? */
char type; /* this is WORD_TYPE or QUOTATION_TYPE */
char last_scan; /* the youngest generation in which this block's literals may live */
char needs_fixup; /* is this a new block that needs full fixup? */
CELL code_length; /* # bytes */
/* In bytes, includes this header */
CELL size;
/* Used during compaction */
struct _F_BLOCK *forwarding;
} F_BLOCK;
typedef struct _F_FREE_BLOCK
{
F_BLOCK block;
/* Filled in on image load */
struct _F_FREE_BLOCK *next_free;
} F_FREE_BLOCK;
typedef struct
{
F_BLOCK block;
CELL literals; /* # bytes */
CELL relocation; /* tagged pointer to byte-array or f */
} F_CODE_BLOCK;

12
vm/profiler.c
View File

@ -3,7 +3,7 @@
/* Allocates memory */
F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
{
CELL literals = allot_array_1(tag_object(word));
CELL literals = allot_array_2(tag_object(word),tag_object(word));
REGISTER_ROOT(literals);
F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]);
@ -11,17 +11,17 @@ F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
CELL code = array_nth(quadruple,0);
REGISTER_ROOT(code);
F_REL rel;
rel.type = to_fixnum(array_nth(quadruple,2)) | (to_fixnum(array_nth(quadruple,1)) << 8);
rel.offset = to_fixnum(array_nth(quadruple,3)) * compiled_code_format();
F_REL rel = (to_fixnum(array_nth(quadruple,1)) << 24)
| (to_fixnum(array_nth(quadruple,2)) << 28)
| (to_fixnum(array_nth(quadruple,3)) * compiled_code_format());
F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
memcpy((void *)BREF(relocation,0),&rel,sizeof(F_REL));
memcpy(relocation + 1,&rel,sizeof(F_REL));
UNREGISTER_ROOT(code);
UNREGISTER_ROOT(literals);
return add_compiled_block(
return add_code_block(
WORD_TYPE,
untag_object(code),
NULL, /* no labels */

68
vm/quotations.c
View File

@ -94,37 +94,30 @@ F_ARRAY *code_to_emit(CELL code)
return untag_object(array_nth(untag_object(code),0));
}
F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length,
CELL rel_argument, bool *rel_p)
F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
{
F_ARRAY *quadruple = untag_object(code);
CELL rel_class = array_nth(quadruple,1);
CELL rel_type = array_nth(quadruple,2);
CELL offset = array_nth(quadruple,3);
F_REL rel;
if(rel_class == F)
{
*rel_p = false;
rel.type = 0;
rel.offset = 0;
return 0;
}
else
{
*rel_p = true;
rel.type = to_fixnum(rel_type)
| (to_fixnum(rel_class) << 8)
| (rel_argument << 16);
rel.offset = (code_length + to_fixnum(offset)) * code_format;
return (to_fixnum(rel_type) << 28)
| (to_fixnum(rel_class) << 24)
| ((code_length + to_fixnum(offset)) * code_format);
}
return rel;
}
#define EMIT(name,rel_argument) { \
#define EMIT(name) { \
bool rel_p; \
F_REL rel = rel_to_emit(name,code_format,code_count,rel_argument,&rel_p); \
F_REL rel = rel_to_emit(name,code_format,code_count,&rel_p); \
if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
}
@ -157,8 +150,8 @@ bool jit_stack_frame_p(F_ARRAY *array)
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
{
if(code->type != QUOTATION_TYPE)
critical_error("bad param to set_quot_xt",(CELL)code);
if(code->block.type != QUOTATION_TYPE)
critical_error("Bad param to set_quot_xt",(CELL)code);
quot->code = code;
quot->xt = (XT)(code + 1);
@ -192,7 +185,7 @@ void jit_compile(CELL quot, bool relocate)
bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame)
EMIT(userenv[JIT_PROLOG],0);
EMIT(userenv[JIT_PROLOG]);
CELL i;
CELL length = array_capacity(untag_object(array));
@ -217,35 +210,36 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY_ADD(literals,T);
}
EMIT(word->subprimitive,literals_count - 1);
EMIT(word->subprimitive);
}
else
{
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ARRAY_ADD(literals,obj);
if(i == length - 1)
{
if(stack_frame)
EMIT(userenv[JIT_EPILOG],0);
EMIT(userenv[JIT_EPILOG]);
EMIT(userenv[JIT_WORD_JUMP],literals_count - 1);
EMIT(userenv[JIT_WORD_JUMP]);
tail_call = true;
}
else
EMIT(userenv[JIT_WORD_CALL],literals_count - 1);
EMIT(userenv[JIT_WORD_CALL]);
}
break;
case WRAPPER_TYPE:
wrapper = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,wrapper->object);
EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1);
EMIT(userenv[JIT_PUSH_IMMEDIATE]);
break;
case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i))
{
EMIT(userenv[JIT_SAVE_STACK],0);
EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
EMIT(userenv[JIT_SAVE_STACK]);
GROWABLE_ARRAY_ADD(literals,obj);
EMIT(userenv[JIT_PRIMITIVE]);
i++;
@ -256,15 +250,15 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_if_p(untag_object(array),i))
{
if(stack_frame)
EMIT(userenv[JIT_EPILOG],0);
EMIT(userenv[JIT_EPILOG]);
jit_compile(array_nth(untag_object(array),i),relocate);
jit_compile(array_nth(untag_object(array),i + 1),relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(userenv[JIT_IF_1],literals_count - 1);
EMIT(userenv[JIT_IF_1]);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
EMIT(userenv[JIT_IF_2],literals_count - 1);
EMIT(userenv[JIT_IF_2]);
i += 2;
@ -276,7 +270,7 @@ void jit_compile(CELL quot, bool relocate)
jit_compile(obj,relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(userenv[JIT_DIP],literals_count - 1);
EMIT(userenv[JIT_DIP]);
i++;
break;
@ -286,7 +280,7 @@ void jit_compile(CELL quot, bool relocate)
jit_compile(obj,relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(userenv[JIT_2DIP],literals_count - 1);
EMIT(userenv[JIT_2DIP]);
i++;
break;
@ -296,7 +290,7 @@ void jit_compile(CELL quot, bool relocate)
jit_compile(obj,relocate);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(userenv[JIT_3DIP],literals_count - 1);
EMIT(userenv[JIT_3DIP]);
i++;
break;
@ -305,10 +299,10 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_dispatch_p(untag_object(array),i))
{
if(stack_frame)
EMIT(userenv[JIT_EPILOG],0);
EMIT(userenv[JIT_EPILOG]);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(userenv[JIT_DISPATCH],literals_count - 1);
EMIT(userenv[JIT_DISPATCH]);
i++;
@ -322,7 +316,7 @@ void jit_compile(CELL quot, bool relocate)
}
default:
GROWABLE_ARRAY_ADD(literals,obj);
EMIT(userenv[JIT_PUSH_IMMEDIATE],literals_count - 1);
EMIT(userenv[JIT_PUSH_IMMEDIATE]);
break;
}
}
@ -330,16 +324,16 @@ void jit_compile(CELL quot, bool relocate)
if(!tail_call)
{
if(stack_frame)
EMIT(userenv[JIT_EPILOG],0);
EMIT(userenv[JIT_EPILOG]);
EMIT(userenv[JIT_RETURN],0);
EMIT(userenv[JIT_RETURN]);
}
GROWABLE_ARRAY_TRIM(code);
GROWABLE_ARRAY_TRIM(literals);
GROWABLE_BYTE_ARRAY_TRIM(relocation);
F_CODE_BLOCK *compiled = add_compiled_block(
F_CODE_BLOCK *compiled = add_code_block(
QUOTATION_TYPE,
untag_object(code),
NULL,

14
vm/types.c
View File

@ -81,7 +81,7 @@ void primitive_word_xt(void)
F_WORD *word = untag_word(dpop());
F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK) + code->code_length));
dpush(allot_cell((CELL)code + code->block.size));
}
void primitive_wrapper(void)
@ -139,6 +139,18 @@ CELL allot_array_1(CELL obj)
return tag_object(a);
}
CELL allot_array_2(CELL v1, CELL v2)
{
REGISTER_ROOT(v1);
REGISTER_ROOT(v2);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
UNREGISTER_ROOT(v2);
UNREGISTER_ROOT(v1);
set_array_nth(a,0,v1);
set_array_nth(a,1,v2);
return tag_object(a);
}
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
{
REGISTER_ROOT(v1);

1
vm/types.h
View File

@ -109,6 +109,7 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
F_BYTE_ARRAY *allot_byte_array(CELL size);
CELL allot_array_1(CELL obj);
CELL allot_array_2(CELL v1, CELL v2);
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
void primitive_array(void);