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

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

db4
Joe Groff 2009-05-08 13:13:00 -07:00
parent 9992817c65 5c2a734a54
commit cc05a90900
36 changed files with 309 additions and 270 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/cpu/ppc/ppc.factor
View File

@ -652,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
13 3 MR ;
15 3 MR ;
M: ppc %alien-indirect ( -- )
13 MTLR BLRL ;
15 MTLR BLRL ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
@ -713,3 +713,4 @@ USE: vocabs.loader
} cond
"complex-double" c-type t >>return-in-registers? drop
"bool" c-type 4 >>size 4 >>align drop

4
basis/io/backend/windows/privileges/privileges-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: io.backend.windows.privileges.tests
USING: io.backend.windows.privileges tools.test ;
[ [ ] with-privileges ] must-infer

9
basis/io/backend/windows/privileges/privileges.factor Normal file → Executable file
View File

@ -1,12 +1,13 @@
USING: io.backend kernel continuations sequences
system vocabs.loader combinators ;
system vocabs.loader combinators fry ;
IN: io.backend.windows.privileges
HOOK: set-privilege io-backend ( name ? -- ) inline
HOOK: set-privilege io-backend ( name ? -- )
: with-privileges ( seq quot -- )
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
[ '[ _ [ t set-privilege ] each @ ] ]
[ drop '[ _ [ f set-privilege ] each ] ]
2bi [ ] cleanup ; inline
{
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }

3
basis/io/files/unique/unique.factor
View File

@ -35,6 +35,9 @@ SYMBOL: unique-retries
: random-name ( -- string )
unique-length get [ random-ch ] "" replicate-as ;
: retry ( quot: ( -- ? ) n -- )
swap [ drop ] prepose attempt-all ; inline
: (make-unique-file) ( path prefix suffix -- path )
'[
_ _ _ random-name glue append-path

12
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
ascii [ input-stream get contents ] with-process-reader
ascii [ contents ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
ascii <process-reader> lines first
ascii <process-reader> stream-lines first
] with-directory
] unit-test
@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"A" swap at
@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =

4
basis/math/miller-rabin/miller-rabin.factor
View File

@ -5,8 +5,6 @@ random sequences sets combinators.short-circuit math.bitwise
math math.order ;
IN: math.miller-rabin
<PRIVATE
: >odd ( n -- int ) 0 set-bit ; foldable
: >even ( n -- int ) 0 clear-bit ; foldable
@ -15,7 +13,7 @@ IN: math.miller-rabin
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
TUPLE: positive-even-expected n ;
<PRIVATE
:: (miller-rabin) ( n trials -- ? )
n 1 - :> n-1

25
basis/tools/deploy/shaker/shaker.factor
View File

@ -23,7 +23,13 @@ IN: tools.deploy.shaker
: strip-init-hooks ( -- )
"Stripping startup hooks" show
{ "cpu.x86" "command-line" "libc" "system" "environment" }
{
"command-line"
"cpu.x86"
"environment"
"libc"
"alien.strings"
}
[ init-hooks get delete-at ] each
deploy-threads? get [
"threads" init-hooks get delete-at
@ -36,8 +42,12 @@ IN: tools.deploy.shaker
"io.backend" init-hooks get delete-at
] when
strip-dictionary? [
"compiler.units" init-hooks get delete-at
"vocabs.cache" init-hooks get delete-at
{
"compiler.units"
"vocabs"
"vocabs.cache"
"source-files.errors"
} [ init-hooks get delete-at ] each
] when ;
: strip-debugger ( -- )
@ -260,21 +270,20 @@ IN: tools.deploy.shaker
compiler.errors:compiler-errors
definition-observers
interactive-vocabs
layouts:num-tags
layouts:num-types
layouts:tag-mask
layouts:tag-numbers
layouts:type-numbers
lexer-factory
print-use-hook
root-cache
source-files.errors:error-types
source-files.errors:error-observers
vocabs:dictionary
vocabs:load-vocab-hook
vocabs:vocab-observers
word
parser-notes
} %
{ } { "layouts" } strip-vocab-globals %
{ } { "math.partial-dispatch" } strip-vocab-globals %
{ } { "peg" } strip-vocab-globals %

16
core/continuations/continuations-docs.factor
View File

@ -79,7 +79,6 @@ $nl
{ $subsection continue-with }
"Continuations as control-flow:"
{ $subsection attempt-all }
{ $subsection retry }
{ $subsection with-return }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
@ -232,21 +231,6 @@ HELP: attempt-all
}
} ;
HELP: retry
{ $values
{ "quot" quotation } { "n" integer }
}
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
{ $examples
"Try to get a 0 as a random number:"
{ $unchecked-example "USING: continuations math prettyprint random ;"
"[ 5 random 0 = ] 5 retry"
"t"
}
} ;
{ attempt-all retry } related-words
HELP: return
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;

2
core/continuations/continuations.factor
View File

@ -155,8 +155,6 @@ ERROR: attempt-all-error ;
] { } make peek swap [ rethrow ] when
] if ; inline
: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
TUPLE: condition error restarts continuation ;
C: <condition> condition ( error restarts cc -- condition )

16
extra/hello-world/deploy.factor
View File

@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
{ deploy-name "Hello world (console)" }
{ deploy-c-types? f }
{ deploy-word-props? f }
{ deploy-ui? f }
{ deploy-reflection 1 }
{ deploy-compiler? f }
{ deploy-unicode? f }
{ deploy-ui? f }
{ deploy-compiler? t }
{ deploy-name "Hello world (console)" }
{ deploy-io 2 }
{ deploy-word-defs? f }
{ deploy-threads? f }
{ "stop-after-last-window?" t }
{ deploy-reflection 1 }
{ deploy-math? f }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
}

2
extra/images/viewer/viewer.factor
View File

@ -25,7 +25,7 @@ M: image <image-gadget>
M: string <image-gadget> load-image <image-gadget> ;
M: pathname <image-gadget> load-image <image-gadget> ;
M: pathname <image-gadget> string>> load-image <image-gadget> ;
: image-window ( object -- ) <image-gadget> "Image" open-window ;

11
extra/mason/build/build.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel calendar io.directories io.encodings.utf8
io.files io.launcher mason.child mason.cleanup mason.common
mason.help mason.release mason.report mason.email mason.notify
namespaces prettyprint ;
io.files io.launcher namespaces prettyprint mason.child mason.cleanup
mason.common mason.help mason.release mason.report mason.email
mason.notify ;
IN: mason.build
QUALIFIED: continuations
@ -19,7 +19,10 @@ QUALIFIED: continuations
: begin-build ( -- )
"factor" [ git-id ] with-directory
[ "git-id" to-file ] [ notify-begin-build ] bi ;
[ "git-id" to-file ]
[ current-git-id set ]
[ notify-begin-build ]
tri ;
: build ( -- )
create-build-dir

13
extra/mason/common/common.factor
View File

@ -4,9 +4,12 @@ USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
calendar.format arrays mason.config locals system debugger ;
calendar.format arrays mason.config locals system debugger fry
continuations ;
IN: mason.common
SYMBOL: current-git-id
ERROR: output-process-error output process ;
M: output-process-error error.
@ -35,15 +38,19 @@ M: unix really-delete-tree delete-tree ;
<process>
swap >>command
15 minutes >>timeout
+closed+ >>stdin
try-output-process ;
: retry ( n quot -- )
'[ drop @ f ] attempt-all drop ; inline
:: upload-safely ( local username host remote -- )
[let* | temp [ remote ".incomplete" append ]
scp-remote [ { username "@" host ":" temp } concat ]
scp [ scp-command get ]
ssh [ ssh-command get ] |
{ scp local scp-remote } short-running-process
{ ssh host "-l" username "mv" temp remote } short-running-process
5 [ { scp local scp-remote } short-running-process ] retry
5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
] ;
: eval-file ( file -- obj )

3
extra/mason/email/email-tests.factor
View File

@ -1,10 +1,11 @@
IN: mason.email.tests
USING: mason.email mason.common mason.config namespaces tools.test ;
[ "mason on linux-x86-64: error" ] [
[ "mason on linux-x86-64: 12345 -- error" ] [
[
"linux" target-os set
"x86.64" target-cpu set
"12345" current-git-id set
status-error subject prefix-subject
] with-scope
] unit-test

8
extra/mason/email/email.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors combinators make smtp debugger
prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
mason.common mason.platform mason.config ;
prettyprint sequences io io.streams.string io.encodings.utf8 io.files
io.sockets mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
@ -18,11 +18,11 @@ IN: mason.email
send-email ;
: subject ( status -- str )
{
[ current-git-id get 7 short head " -- " ] dip {
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
} case ;
} case 3append ;
: email-report ( report status -- )
[ "text/html" ] dip subject email-status ;

10
extra/mason/release/branch/branch.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.directories io.files io.launcher kernel make
mason.common mason.config mason.platform namespaces prettyprint
sequences ;
namespaces prettyprint sequences mason.common mason.config
mason.platform ;
IN: mason.release.branch
: branch-name ( -- string ) "clean-" platform append ;
@ -21,7 +21,7 @@ IN: mason.release.branch
] { } make ;
: push-to-clean-branch ( -- )
push-to-clean-branch-cmd short-running-process ;
5 [ push-to-clean-branch-cmd short-running-process ] retry ;
: upload-clean-image-cmd ( -- args )
[
@ -36,7 +36,7 @@ IN: mason.release.branch
] { } make ;
: upload-clean-image ( -- )
upload-clean-image-cmd short-running-process ;
5 [ upload-clean-image-cmd short-running-process ] retry ;
: (update-clean-branch) ( -- )
"factor" [

2
extra/mason/report/report.factor
View File

@ -12,7 +12,7 @@ IN: mason.report
target-cpu get
host-name
build-dir
"git-id" eval-file
current-git-id get
[XML
<h1>Build report for <->/<-></h1>
<table>

3
extra/webapps/wee-url/wee-url.factor
View File

@ -26,6 +26,9 @@ short-url "SHORT_URLS" {
: random-url ( -- string )
1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
: retry ( quot: ( -- ? ) n -- )
swap [ drop ] prepose attempt-all ; inline
: insert-short-url ( short-url -- short-url )
'[ _ dup random-url >>short insert-tuple ] 10 retry ;

18
vm/callstack.cpp
View File

@ -24,10 +24,7 @@ void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
{
cell top = (cell)FIRST_STACK_FRAME(stack);
cell bottom = top + untag_fixnum(stack->length);
iterate_callstack(top,bottom,iterator);
iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
}
callstack *allot_callstack(cell size)
@ -75,7 +72,7 @@ PRIMITIVE(callstack)
size = 0;
callstack *stack = allot_callstack(size);
memcpy(FIRST_STACK_FRAME(stack),top,size);
memcpy(stack->top(),top,size);
dpush(tag<callstack>(stack));
}
@ -84,7 +81,7 @@ PRIMITIVE(set_callstack)
callstack *stack = untag_check<callstack>(dpop());
set_callstack(stack_chain->callstack_bottom,
FIRST_STACK_FRAME(stack),
stack->top(),
untag_fixnum(stack->length),
memcpy);
@ -173,12 +170,11 @@ PRIMITIVE(callstack_to_array)
dpush(tag<array>(frames));
}
stack_frame *innermost_stack_frame(callstack *callstack)
stack_frame *innermost_stack_frame(callstack *stack)
{
stack_frame *top = FIRST_STACK_FRAME(callstack);
cell bottom = (cell)top + untag_fixnum(callstack->length);
stack_frame *frame = (stack_frame *)bottom - 1;
stack_frame *top = stack->top();
stack_frame *bottom = stack->bottom();
stack_frame *frame = bottom - 1;
while(frame >= top && frame_successor(frame) >= top)
frame = frame_successor(frame);

2
vm/callstack.hpp
View File

@ -6,8 +6,6 @@ inline static cell callstack_size(cell size)
return sizeof(callstack) + size;
}
#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1)
typedef void (*CALLSTACK_ITER)(stack_frame *frame);
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);

53
vm/code_block.cpp
View File

@ -3,6 +3,21 @@
namespace factor
{
static relocation_type relocation_type_of(relocation_entry r)
{
return (relocation_type)((r & 0xf0000000) >> 28);
}
static relocation_class relocation_class_of(relocation_entry r)
{
return (relocation_class)((r & 0x0f000000) >> 24);
}
static cell relocation_offset_of(relocation_entry r)
{
return (r & 0x00ffffff);
}
void flush_icache_for(code_block *block)
{
flush_icache((cell)block,block->size);
@ -125,11 +140,11 @@ void *get_rel_symbol(array *literals, cell index)
cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = untag<array>(compiled->literals);
cell offset = REL_OFFSET(rel) + (cell)compiled->xt();
cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
#define ARG array_nth(literals,index)
switch(REL_TYPE(rel))
switch(relocation_type_of(rel))
{
case RT_PRIMITIVE:
return (cell)primitives[untag_fixnum(ARG)];
@ -174,7 +189,7 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
{
relocation_entry rel = relocation->data<relocation_entry>()[i];
iter(rel,index,compiled);
index += number_of_parameters(REL_TYPE(rel));
index += number_of_parameters(relocation_type_of(rel));
}
}
}
@ -217,25 +232,25 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
store_address_2_2((cell *)offset,absolute_value);
break;
case RC_ABSOLUTE_PPC_2:
store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
store_address_masked((cell *)offset,absolute_value,rel_absolute_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_2:
store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
store_address_masked((cell *)offset,relative_value,rel_relative_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_3:
store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
store_address_masked((cell *)offset,relative_value,rel_relative_ppc_3_mask,0);
break;
case RC_RELATIVE_ARM_3:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
REL_RELATIVE_ARM_3_MASK,2);
rel_relative_arm_3_mask,2);
break;
case RC_INDIRECT_ARM:
store_address_masked((cell *)offset,relative_value - sizeof(cell),
REL_INDIRECT_ARM_MASK,0);
rel_indirect_arm_mask,0);
break;
case RC_INDIRECT_ARM_PC:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
REL_INDIRECT_ARM_MASK,0);
rel_indirect_arm_mask,0);
break;
default:
critical_error("Bad rel class",klass);
@ -245,12 +260,12 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
{
if(REL_TYPE(rel) == RT_IMMEDIATE)
if(relocation_type_of(rel) == RT_IMMEDIATE)
{
cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
cell offset = relocation_offset_of(rel) + (cell)(compiled + 1);
array *literals = untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index);
store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
store_address_in_code_block(relocation_class_of(rel),offset,absolute_value);
}
}
@ -297,14 +312,14 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp
tagged<byte_array>(compiled->relocation).untag_check();
#endif
store_address_in_code_block(REL_CLASS(rel),
REL_OFFSET(rel) + (cell)compiled->xt(),
store_address_in_code_block(relocation_class_of(rel),
relocation_offset_of(rel) + (cell)compiled->xt(),
compute_relocation(rel,index,compiled));
}
void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
relocation_type type = REL_TYPE(rel);
relocation_type type = relocation_type_of(rel);
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
relocate_code_block_step(rel,index,compiled);
}
@ -369,7 +384,7 @@ void mark_stack_frame_step(stack_frame *frame)
/* Mark code blocks executing in currently active stack frames. */
void mark_active_blocks(context *stacks)
{
if(collecting_gen == TENURED)
if(collecting_gen == data->tenured())
{
cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom;
@ -410,7 +425,7 @@ void mark_object_code_block(object *object)
/* Perform all fixups on a code block */
void relocate_code_block(code_block *compiled)
{
compiled->last_scan = NURSERY;
compiled->last_scan = data->nursery();
compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
@ -480,7 +495,7 @@ code_block *add_code_block(
/* compiled header */
compiled->type = type;
compiled->last_scan = NURSERY;
compiled->last_scan = data->nursery();
compiled->needs_fixup = true;
compiled->relocation = relocation.value();
@ -499,7 +514,7 @@ code_block *add_code_block(
/* next time we do a minor GC, we have to scan the code heap for
literals */
last_code_heap_scan = NURSERY;
last_code_heap_scan = data->nursery();
return compiled;
}

13
vm/code_block.hpp
View File

@ -51,17 +51,14 @@ enum relocation_class {
RC_INDIRECT_ARM_PC
};
#define REL_ABSOLUTE_PPC_2_MASK 0xffff
#define REL_RELATIVE_PPC_2_MASK 0xfffc
#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
#define REL_INDIRECT_ARM_MASK 0xfff
#define REL_RELATIVE_ARM_3_MASK 0xffffff
static const cell rel_absolute_ppc_2_mask = 0xffff;
static const cell rel_relative_ppc_2_mask = 0xfffc;
static const cell rel_relative_ppc_3_mask = 0x3fffffc;
static const cell rel_indirect_arm_mask = 0xfff;
static const cell rel_relative_arm_3_mask = 0xffffff;
/* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry;
#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28)
#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24)
#define REL_OFFSET(r) ((r) & 0x00ffffff)
void flush_icache_for(code_block *compiled);

12
vm/code_gc.cpp
View File

@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size)
static void add_to_free_list(heap *heap, free_heap_block *block)
{
if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
if(block->size < free_list_count * block_size_increment)
{
int index = block->size / BLOCK_SIZE_INCREMENT;
int index = block->size / block_size_increment;
block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block;
}
@ -45,7 +45,7 @@ void build_free_list(heap *heap, cell size)
clear_free_list(heap);
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
heap_block *scan = first_block(heap);
free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
@ -101,9 +101,9 @@ static free_heap_block *find_free_block(heap *heap, cell size)
{
cell attempt = size;
while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
while(attempt < free_list_count * block_size_increment)
{
int index = attempt / BLOCK_SIZE_INCREMENT;
int index = attempt / block_size_increment;
free_heap_block *block = heap->free.small_blocks[index];
if(block)
{
@ -156,7 +156,7 @@ static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cel
/* Allocate a block of memory from the mark and sweep GC heap */
heap_block *heap_allot(heap *heap, cell size)
{
size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
free_heap_block *block = find_free_block(heap,size);
if(block)

6
vm/code_gc.hpp
View File

@ -1,11 +1,11 @@
namespace factor
{
#define FREE_LIST_COUNT 16
#define BLOCK_SIZE_INCREMENT 32
static const cell free_list_count = 16;
static const cell block_size_increment = 32;
struct heap_free_list {
free_heap_block *small_blocks[FREE_LIST_COUNT];
free_heap_block *small_blocks[free_list_count];
free_heap_block *large_blocks;
};

6
vm/contexts.cpp
View File

@ -18,12 +18,12 @@ void reset_retainstack()
rs = rs_bot - sizeof(cell);
}
#define RESERVED (64 * sizeof(cell))
static const cell stack_reserved = (64 * sizeof(cell));
void fix_stacks()
{
if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
}
/* called before entry into foreign C code. Note that ds and rs might

2
vm/cpu-ppc.hpp
View File

@ -27,7 +27,7 @@ inline static void check_call_site(cell return_address)
#endif
}
#define B_MASK 0x3fffffc
static const cell b_mask = 0x3fffffc;
inline static void *get_call_target(cell return_address)
{

83
vm/data_gc.cpp
View File

@ -9,15 +9,15 @@ bool performing_gc;
bool performing_compaction;
cell collecting_gen;
/* if true, we collecting AGING space for the second time, so if it is still
full, we go on to collect TENURED */
/* if true, we collecting aging space for the second time, so if it is still
full, we go on to collect tenured */
bool collecting_aging_again;
/* 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;
gc_stats stats[MAX_GEN_COUNT];
gc_stats stats[max_gen_count];
u64 cards_scanned;
u64 decks_scanned;
u64 card_scan_time;
@ -36,7 +36,7 @@ data_heap *old_data_heap;
void init_data_gc()
{
performing_gc = false;
last_code_heap_scan = NURSERY;
last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
@ -66,11 +66,11 @@ static bool should_copy_p(object *untagged)
{
if(in_zone(newspace,untagged))
return false;
if(collecting_gen == TENURED)
if(collecting_gen == data->tenured())
return true;
else if(HAVE_AGING_P && collecting_gen == AGING)
return !in_zone(&data->generations[TENURED],untagged);
else if(collecting_gen == NURSERY)
else if(data->have_aging_p() && collecting_gen == data->aging())
return !in_zone(&data->generations[data->tenured()],untagged);
else if(collecting_gen == data->nursery())
return in_zone(&nursery,untagged);
else
{
@ -186,19 +186,19 @@ static void copy_gen_cards(cell gen)
/* if we are collecting the nursery, we care about old->nursery pointers
but not old->aging pointers */
if(collecting_gen == NURSERY)
if(collecting_gen == data->nursery())
{
mask = CARD_POINTS_TO_NURSERY;
mask = card_points_to_nursery;
/* after the collection, no old->nursery pointers remain
anywhere, but old->aging pointers might remain in tenured
space */
if(gen == TENURED)
unmask = CARD_POINTS_TO_NURSERY;
if(gen == data->tenured())
unmask = card_points_to_nursery;
/* after the collection, all cards in aging space can be
cleared */
else if(HAVE_AGING_P && gen == AGING)
unmask = CARD_MARK_MASK;
else if(data->have_aging_p() && gen == data->aging())
unmask = card_mark_mask;
else
{
critical_error("bug in copy_gen_cards",gen);
@ -208,20 +208,20 @@ static void copy_gen_cards(cell gen)
/* if we are collecting aging space into tenured space, we care about
all old->nursery and old->aging pointers. no old->aging pointers can
remain */
else if(HAVE_AGING_P && collecting_gen == AGING)
else if(data->have_aging_p() && collecting_gen == data->aging())
{
if(collecting_aging_again)
{
mask = CARD_POINTS_TO_AGING;
unmask = CARD_MARK_MASK;
mask = card_points_to_aging;
unmask = card_mark_mask;
}
/* after we collect aging space into the aging semispace, no
old->nursery pointers remain but tenured space might still have
pointers to aging space. */
else
{
mask = CARD_POINTS_TO_AGING;
unmask = CARD_POINTS_TO_NURSERY;
mask = card_points_to_aging;
unmask = card_points_to_nursery;
}
}
else
@ -366,8 +366,8 @@ static cell copy_next_from_aging(cell scan)
{
obj++;
cell tenured_start = data->generations[TENURED].start;
cell tenured_end = data->generations[TENURED].end;
cell tenured_start = data->generations[data->tenured()].start;
cell tenured_end = data->generations[data->tenured()].end;
cell newspace_start = newspace->start;
cell newspace_end = newspace->end;
@ -421,17 +421,17 @@ static cell copy_next_from_tenured(cell scan)
void copy_reachable_objects(cell scan, cell *end)
{
if(collecting_gen == NURSERY)
if(collecting_gen == data->nursery())
{
while(scan < *end)
scan = copy_next_from_nursery(scan);
}
else if(HAVE_AGING_P && collecting_gen == AGING)
else if(data->have_aging_p() && collecting_gen == data->aging())
{
while(scan < *end)
scan = copy_next_from_aging(scan);
}
else if(collecting_gen == TENURED)
else if(collecting_gen == data->tenured())
{
while(scan < *end)
scan = copy_next_from_tenured(scan);
@ -443,12 +443,12 @@ static void begin_gc(cell requested_bytes)
{
if(growing_data_heap)
{
if(collecting_gen != TENURED)
if(collecting_gen != data->tenured())
critical_error("Invalid parameters to begin_gc",0);
old_data_heap = data;
set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
newspace = &data->generations[TENURED];
newspace = &data->generations[data->tenured()];
}
else if(collecting_accumulation_gen_p())
{
@ -491,12 +491,12 @@ static void end_gc(cell gc_elapsed)
if(collecting_accumulation_gen_p())
{
/* all younger generations except are now empty.
if collecting_gen == NURSERY here, we only have 1 generation;
if collecting_gen == data->nursery() here, we only have 1 generation;
old-school Cheney collector */
if(collecting_gen != NURSERY)
reset_generations(NURSERY,collecting_gen - 1);
if(collecting_gen != data->nursery())
reset_generations(data->nursery(),collecting_gen - 1);
}
else if(collecting_gen == NURSERY)
else if(collecting_gen == data->nursery())
{
nursery.here = nursery.start;
}
@ -504,7 +504,7 @@ static void end_gc(cell gc_elapsed)
{
/* all generations up to and including the one
collected are now empty */
reset_generations(NURSERY,collecting_gen);
reset_generations(data->nursery(),collecting_gen);
}
collecting_aging_again = false;
@ -534,17 +534,17 @@ void garbage_collection(cell gen,
{
/* We have no older generations we can try collecting, so we
resort to growing the data heap */
if(collecting_gen == TENURED)
if(collecting_gen == data->tenured())
{
growing_data_heap = true;
/* see the comment in unmark_marked() */
unmark_marked(&code);
}
/* we try collecting AGING space twice before going on to
collect TENURED */
else if(HAVE_AGING_P
&& collecting_gen == AGING
/* we try collecting aging space twice before going on to
collect tenured */
else if(data->have_aging_p()
&& collecting_gen == data->aging()
&& !collecting_aging_again)
{
collecting_aging_again = true;
@ -575,7 +575,7 @@ void garbage_collection(cell gen,
{
code_heap_scans++;
if(collecting_gen == TENURED)
if(collecting_gen == data->tenured())
free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
else
copy_code_heap_roots();
@ -595,7 +595,7 @@ void garbage_collection(cell gen,
void gc()
{
garbage_collection(TENURED,false,0);
garbage_collection(data->tenured(),false,0);
}
PRIMITIVE(gc)
@ -610,7 +610,7 @@ PRIMITIVE(gc_stats)
cell i;
u64 total_gc_time = 0;
for(i = 0; i < MAX_GEN_COUNT; i++)
for(i = 0; i < max_gen_count; i++)
{
gc_stats *s = &stats[i];
result.add(allot_cell(s->collections));
@ -635,8 +635,7 @@ PRIMITIVE(gc_stats)
void clear_gc_stats()
{
int i;
for(i = 0; i < MAX_GEN_COUNT; i++)
for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
cards_scanned = 0;
@ -683,7 +682,7 @@ PRIMITIVE(become)
VM_C_API void minor_gc()
{
garbage_collection(NURSERY,false,0);
garbage_collection(data->nursery(),false,0);
}
}

22
vm/data_gc.hpp
View File

@ -24,10 +24,10 @@ void gc();
inline static bool collecting_accumulation_gen_p()
{
return ((HAVE_AGING_P
&& collecting_gen == AGING
return ((data->have_aging_p()
&& collecting_gen == data->aging()
&& !collecting_aging_again)
|| collecting_gen == TENURED);
|| collecting_gen == data->tenured());
}
void copy_handle(cell *handle);
@ -39,7 +39,7 @@ void garbage_collection(volatile cell gen,
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
static const cell allot_buffer_zone = 1024;
inline static object *allot_zone(zone *z, cell a)
{
@ -63,11 +63,11 @@ inline static object *allot_object(header header, cell size)
object *obj;
if(nursery.size - ALLOT_BUFFER_ZONE > size)
if(nursery.size - allot_buffer_zone > size)
{
/* If there is insufficient room, collect the nursery */
if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end)
garbage_collection(NURSERY,false,0);
if(nursery.here + allot_buffer_zone + size > nursery.end)
garbage_collection(data->nursery(),false,0);
cell h = nursery.here;
nursery.here = h + align8(size);
@ -77,20 +77,20 @@ inline static object *allot_object(header header, cell size)
tenured space */
else
{
zone *tenured = &data->generations[TENURED];
zone *tenured = &data->generations[data->tenured()];
/* If tenured space does not have enough room, collect */
if(tenured->here + size > tenured->end)
{
gc();
tenured = &data->generations[TENURED];
tenured = &data->generations[data->tenured()];
}
/* If it still won't fit, grow the heap */
if(tenured->here + size > tenured->end)
{
garbage_collection(TENURED,true,size);
tenured = &data->generations[TENURED];
garbage_collection(data->tenured(),true,size);
tenured = &data->generations[data->tenured()];
}
obj = allot_zone(tenured,size);

54
vm/data_heap.cpp
View File

@ -26,10 +26,10 @@ cell init_zone(zone *z, cell size, cell start)
void init_card_decks()
{
cell start = align(data->seg->start,DECK_SIZE);
allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
cards_offset = (cell)data->cards - (start >> CARD_BITS);
decks_offset = (cell)data->decks - (start >> DECK_BITS);
cell start = align(data->seg->start,deck_size);
allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
cards_offset = (cell)data->cards - (start >> card_bits);
decks_offset = (cell)data->decks - (start >> deck_bits);
}
data_heap *alloc_data_heap(cell gens,
@ -37,9 +37,9 @@ data_heap *alloc_data_heap(cell gens,
cell aging_size,
cell tenured_size)
{
young_size = align(young_size,DECK_SIZE);
aging_size = align(aging_size,DECK_SIZE);
tenured_size = align(tenured_size,DECK_SIZE);
young_size = align(young_size,deck_size);
aging_size = align(aging_size,deck_size);
tenured_size = align(tenured_size,deck_size);
data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
data->young_size = young_size;
@ -58,42 +58,42 @@ data_heap *alloc_data_heap(cell gens,
return NULL; /* can't happen */
}
total_size += DECK_SIZE;
total_size += deck_size;
data->seg = alloc_segment(total_size);
data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
cell cards_size = total_size >> CARD_BITS;
cell cards_size = total_size >> card_bits;
data->allot_markers = (cell *)safe_malloc(cards_size);
data->allot_markers_end = data->allot_markers + cards_size;
data->cards = (cell *)safe_malloc(cards_size);
data->cards_end = data->cards + cards_size;
cell decks_size = total_size >> DECK_BITS;
cell decks_size = total_size >> deck_bits;
data->decks = (cell *)safe_malloc(decks_size);
data->decks_end = data->decks + decks_size;
cell alloter = align(data->seg->start,DECK_SIZE);
cell alloter = align(data->seg->start,deck_size);
alloter = init_zone(&data->generations[TENURED],tenured_size,alloter);
alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter);
alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter);
alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
if(data->gen_count == 3)
{
alloter = init_zone(&data->generations[AGING],aging_size,alloter);
alloter = init_zone(&data->semispaces[AGING],aging_size,alloter);
alloter = init_zone(&data->generations[data->aging()],aging_size,alloter);
alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
}
if(data->gen_count >= 2)
{
alloter = init_zone(&data->generations[NURSERY],young_size,alloter);
alloter = init_zone(&data->semispaces[NURSERY],0,alloter);
alloter = init_zone(&data->generations[data->nursery()],young_size,alloter);
alloter = init_zone(&data->semispaces[data->nursery()],0,alloter);
}
if(data->seg->end - alloter > DECK_SIZE)
if(data->seg->end - alloter > deck_size)
critical_error("Bug in alloc_data_heap",alloter);
return data;
@ -141,12 +141,12 @@ void clear_allot_markers(cell from, cell to)
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
memset(first_card,invalid_allot_marker,last_card - first_card);
}
void reset_generation(cell i)
{
zone *z = (i == NURSERY ? &nursery : &data->generations[i]);
zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
z->here = z->start;
if(secure_gc)
@ -169,11 +169,11 @@ void reset_generations(cell from, cell to)
void set_data_heap(data_heap *data_)
{
data = data_;
nursery = data->generations[NURSERY];
nursery = data->generations[data->nursery()];
init_card_decks();
clear_cards(NURSERY,TENURED);
clear_decks(NURSERY,TENURED);
clear_allot_markers(NURSERY,TENURED);
clear_cards(data->nursery(),data->tenured());
clear_decks(data->nursery(),data->tenured());
clear_allot_markers(data->nursery(),data->tenured());
}
void init_data_heap(cell gens,
@ -298,7 +298,7 @@ PRIMITIVE(data_room)
cell gen;
for(gen = 0; gen < data->gen_count; gen++)
{
zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]);
zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]);
a.add(tag_fixnum((z->end - z->here) >> 10));
a.add(tag_fixnum((z->size) >> 10));
}
@ -314,7 +314,7 @@ cell heap_scan_ptr;
/* Disables GC and activates next-object ( -- obj ) primitive */
void begin_scan()
{
heap_scan_ptr = data->generations[TENURED].start;
heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
@ -328,7 +328,7 @@ cell next_object()
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
if(heap_scan_ptr >= data->generations[TENURED].here)
if(heap_scan_ptr >= data->generations[data->tenured()].here)
return F;
object *obj = (object *)heap_scan_ptr;

22
vm/data_heap.hpp
View File

@ -34,20 +34,22 @@ struct data_heap {
cell *decks;
cell *decks_end;
/* the 0th generation is where new objects are allocated. */
cell nursery() { return 0; }
/* where objects hang around */
cell aging() { return gen_count - 2; }
/* the oldest generation */
cell tenured() { return gen_count - 1; }
bool have_aging_p() { return gen_count > 2; }
};
extern data_heap *data;
/* the 0th generation is where new objects are allocated. */
#define NURSERY 0
/* where objects hang around */
#define AGING (data->gen_count-2)
#define HAVE_AGING_P (data->gen_count>2)
/* the oldest generation */
#define TENURED (data->gen_count-1)
#define MIN_GEN_COUNT 1
#define MAX_GEN_COUNT 3
static const cell max_gen_count = 3;
inline static bool in_zone(zone *z, object *pointer)
{

16
vm/image.cpp
View File

@ -31,7 +31,7 @@ static void load_data_heap(FILE *file, image_header *h, vm_parameters *p)
clear_gc_stats();
zone *tenured = &data->generations[TENURED];
zone *tenured = &data->generations[data->tenured()];
fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
@ -92,10 +92,10 @@ bool save_image(const vm_char *filename)
return false;
}
zone *tenured = &data->generations[TENURED];
zone *tenured = &data->generations[data->tenured()];
h.magic = IMAGE_MAGIC;
h.version = IMAGE_VERSION;
h.magic = image_magic;
h.version = image_version;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
h.code_relocation_base = code.seg->start;
@ -165,7 +165,7 @@ static void data_fixup(cell *cell)
if(immediate_p(*cell))
return;
zone *tenured = &data->generations[TENURED];
zone *tenured = &data->generations[data->tenured()];
*cell += (tenured->start - data_relocation_base);
}
@ -271,7 +271,7 @@ void relocate_data()
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
zone *tenured = &data->generations[TENURED];
zone *tenured = &data->generations[data->tenured()];
for(relocating = tenured->start;
relocating < tenured->here;
@ -313,10 +313,10 @@ void load_image(vm_parameters *p)
if(fread(&h,sizeof(image_header),1,file) != 1)
fatal_error("Cannot read image header",0);
if(h.magic != IMAGE_MAGIC)
if(h.magic != image_magic)
fatal_error("Bad image: magic number check failed",h.magic);
if(h.version != IMAGE_VERSION)
if(h.version != image_version)
fatal_error("Bad image: version number check failed",h.version);
load_data_heap(file,&h,p);

4
vm/image.hpp
View File

@ -1,8 +1,8 @@
namespace factor
{
#define IMAGE_MAGIC 0x0f0e0d0c
#define IMAGE_VERSION 4
static const cell image_magic = 0x0f0e0d0c;
static const cell image_version = 4;
struct image_header {
cell magic;

26
vm/layouts.hpp
View File

@ -23,8 +23,15 @@ inline static cell align(cell a, cell b)
return (a + (b-1)) & ~(b-1);
}
#define align8(a) align(a,8)
#define align_page(a) align(a,getpagesize())
inline static cell align8(cell a)
{
return align(a,8);
}
inline static cell align_page(cell a)
{
return align(a,getpagesize());
}
#define WORD_SIZE (signed)(sizeof(cell)*8)
@ -297,12 +304,6 @@ struct dll : public object {
void *dll;
};
struct callstack : public object {
static const cell type_number = CALLSTACK_TYPE;
/* tagged */
cell length;
};
struct stack_frame
{
void *xt;
@ -310,6 +311,15 @@ struct stack_frame
cell size;
};
struct callstack : public object {
static const cell type_number = CALLSTACK_TYPE;
/* tagged */
cell length;
stack_frame *top() { return (stack_frame *)(this + 1); }
stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
};
struct tuple : public object {
static const cell type_number = TUPLE_TYPE;
/* tagged layout */

39
vm/math.cpp
View File

@ -24,8 +24,8 @@ PRIMITIVE(fixnum_divint)
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
fixnum result = x / y;
if(result == -FIXNUM_MIN)
drepl(allot_integer(-FIXNUM_MIN));
if(result == -fixnum_min)
drepl(allot_integer(-fixnum_min));
else
drepl(tag_fixnum(result));
}
@ -34,9 +34,9 @@ PRIMITIVE(fixnum_divmod)
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min))
{
((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN);
((cell *)ds)[-1] = allot_integer(-fixnum_min);
((cell *)ds)[0] = tag_fixnum(0);
}
else
@ -50,9 +50,20 @@ PRIMITIVE(fixnum_divmod)
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
static inline fixnum sign_mask(fixnum x)
{
return x >> (WORD_SIZE - 1);
}
static inline fixnum branchless_max(fixnum x, fixnum y)
{
return (x - ((x - y) & sign_mask(x - y)));
}
static inline fixnum branchless_abs(fixnum x)
{
return (x ^ sign_mask(x)) - sign_mask(x);
}
PRIMITIVE(fixnum_shift)
{
@ -63,14 +74,14 @@ PRIMITIVE(fixnum_shift)
return;
else if(y < 0)
{
y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
y = branchless_max(y,-WORD_SIZE + 1);
drepl(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
{
fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y));
if(!(BRANCHLESS_ABS(x) & mask))
if(!(branchless_abs(x) & mask))
{
drepl(tag_fixnum(x << y));
return;
@ -226,7 +237,7 @@ cell unbox_array_size()
case FIXNUM_TYPE:
{
fixnum n = untag_fixnum(dpeek());
if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX)
if(n >= 0 && n < (fixnum)array_size_max)
{
dpop();
return n;
@ -236,7 +247,7 @@ cell unbox_array_size()
case BIGNUM_TYPE:
{
bignum * zero = untag<bignum>(bignum_zero);
bignum * max = cell_to_bignum(ARRAY_SIZE_MAX);
bignum * max = cell_to_bignum(array_size_max);
bignum * n = untag<bignum>(dpeek());
if(bignum_compare(n,zero) != bignum_comparison_less
&& bignum_compare(n,max) == bignum_comparison_less)
@ -248,7 +259,7 @@ cell unbox_array_size()
}
}
general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL);
return 0; /* can't happen */
}
@ -428,7 +439,7 @@ VM_C_API void box_unsigned_cell(cell cell)
VM_C_API void box_signed_8(s64 n)
{
if(n < FIXNUM_MIN || n > FIXNUM_MAX)
if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
@ -450,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj)
VM_C_API void box_unsigned_8(u64 n)
{
if(n > FIXNUM_MAX)
if(n > fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
else
dpush(tag_fixnum(n));

11
vm/math.hpp
View File

@ -5,10 +5,9 @@ extern cell bignum_zero;
extern cell bignum_pos_one;
extern cell bignum_neg_one;
#define cell_MAX (cell)(-1)
#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)))
#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2))
static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1);
static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
PRIMITIVE(fixnum_add);
PRIMITIVE(fixnum_subtract);
@ -45,7 +44,7 @@ PRIMITIVE(byte_array_to_bignum);
inline static cell allot_integer(fixnum x)
{
if(x < FIXNUM_MIN || x > FIXNUM_MAX)
if(x < fixnum_min || x > fixnum_max)
return tag<bignum>(fixnum_to_bignum(x));
else
return tag_fixnum(x);
@ -53,7 +52,7 @@ inline static cell allot_integer(fixnum x)
inline static cell allot_cell(cell x)
{
if(x > (cell)FIXNUM_MAX)
if(x > (cell)fixnum_max)
return tag<bignum>(cell_to_bignum(x));
else
return tag_fixnum(x);

42
vm/write_barrier.hpp
View File

@ -12,24 +12,24 @@ VM_C_API factor::cell decks_offset;
namespace factor
{
/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
#define CARD_POINTS_TO_NURSERY 0x80
#define CARD_POINTS_TO_AGING 0x40
#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
/* if card_points_to_nursery is set, card_points_to_aging must also be set. */
static const cell card_points_to_nursery = 0x80;
static const cell card_points_to_aging = 0x40;
static const cell card_mark_mask = (card_points_to_nursery | card_points_to_aging);
typedef u8 card;
#define CARD_BITS 8
#define CARD_SIZE (1<<CARD_BITS)
#define ADDR_CARD_MASK (CARD_SIZE-1)
static const cell card_bits = 8;
static const cell card_size = (1<<card_bits);
static const cell addr_card_mask = (card_size-1);
inline static card *addr_to_card(cell a)
{
return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
return (card*)(((cell)(a) >> card_bits) + cards_offset);
}
inline static cell card_to_addr(card *c)
{
return ((cell)c - cards_offset) << CARD_BITS;
return ((cell)c - cards_offset) << card_bits;
}
inline static cell card_offset(card *c)
@ -39,48 +39,48 @@ inline static cell card_offset(card *c)
typedef u8 card_deck;
#define DECK_BITS (CARD_BITS + 10)
#define DECK_SIZE (1<<DECK_BITS)
#define ADDR_DECK_MASK (DECK_SIZE-1)
static const cell deck_bits = (card_bits + 10);
static const cell deck_size = (1<<deck_bits);
static const cell addr_deck_mask = (deck_size-1);
inline static card_deck *addr_to_deck(cell a)
{
return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
}
inline static cell deck_to_addr(card_deck *c)
{
return ((cell)c - decks_offset) << DECK_BITS;
return ((cell)c - decks_offset) << deck_bits;
}
inline static card *deck_to_card(card_deck *d)
{
return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset);
return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
}
#define INVALID_ALLOT_MARKER 0xff
static const cell invalid_allot_marker = 0xff;
extern cell allot_markers_offset;
inline static card *addr_to_allot_marker(object *a)
{
return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset);
return (card *)(((cell)a >> card_bits) + allot_markers_offset);
}
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
inline static void write_barrier(object *obj)
{
*addr_to_card((cell)obj) = CARD_MARK_MASK;
*addr_to_deck((cell)obj) = CARD_MARK_MASK;
*addr_to_card((cell)obj) = card_mark_mask;
*addr_to_deck((cell)obj) = card_mark_mask;
}
/* we need to remember the first object allocated in the card */
inline static void allot_barrier(object *address)
{
card *ptr = addr_to_allot_marker(address);
if(*ptr == INVALID_ALLOT_MARKER)
*ptr = ((cell)address & ADDR_CARD_MASK);
if(*ptr == invalid_allot_marker)
*ptr = ((cell)address & addr_card_mask);
}
}