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

Split up types.c/h into smaller files, remove optimized slot from F_WORD struct

db4
Slava Pestov 2009-04-28 17:26:11 -05:00
parent e8008af5d0
commit 5f6c074edd
43 changed files with 935 additions and 933 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
Makefile
View File

@ -28,7 +28,10 @@ endif
DLL_OBJS = $(PLAF_DLL_OBJS) \ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \ vm/alien.o \
vm/arrays.o \
vm/bignum.o \ vm/bignum.o \
vm/booleans.o \
vm/byte_arrays.o \
vm/callstack.o \ vm/callstack.o \
vm/code_block.o \ vm/code_block.o \
vm/code_gc.o \ vm/code_gc.o \
@ -48,8 +51,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/profiler.o \ vm/profiler.o \
vm/quotations.o \ vm/quotations.o \
vm/run.o \ vm/run.o \
vm/types.o \ vm/strings.o \
vm/utilities.o vm/tuples.o \
vm/utilities.o \
vm/words.o
EXE_OBJS = $(PLAF_EXE_OBJS) EXE_OBJS = $(PLAF_EXE_OBJS)

2
basis/alien/remote-control/remote-control.factor
View File

@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ; "void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien ) : ?callback ( word -- alien )
dup optimized>> [ execute ] [ drop f ] if ; inline dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- ) : init-remote-control ( -- )
\ eval-callback ?callback 16 setenv \ eval-callback ?callback 16 setenv

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

@ -29,7 +29,7 @@ enable-compiler
gc gc
: compile-unoptimized ( words -- ) : compile-unoptimized ( words -- )
[ optimized>> not ] filter compile ; [ optimized? not ] filter compile ;
nl nl
"Compiling..." write flush "Compiling..." write flush

4
basis/bootstrap/stage2.factor
View File

@ -35,10 +35,6 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time "Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time "Bootstrap completed in " write bootstrap-time get print-time
[ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
"Bootstrapping is complete." print "Bootstrapping is complete." print
"Now, you can run Factor:" print "Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ; vm write " -i=" write "output-image" get print flush ;

2
basis/compiler/compiler.factor
View File

@ -122,7 +122,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
: compile-dependency ( word -- ) : compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee. #! If a word calls an unoptimized word, try to compile the callee.
dup optimized>> [ drop ] [ queue-compile ] if ; dup optimized? [ drop ] [ queue-compile ] if ;
! Only switch this off for debugging. ! Only switch this off for debugging.
SYMBOL: compile-dependencies? SYMBOL: compile-dependencies?

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

@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare { tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ; dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test [ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test [ vector ] [ dispatch-alignment-regression ] unit-test

14
basis/compiler/tests/optimizer.factor
View File

@ -10,7 +10,7 @@ IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj ) GENERIC: xyz ( obj -- obj )
M: array xyz xyz ; M: array xyz xyz ;
[ t ] [ \ xyz optimized>> ] unit-test [ t ] [ \ xyz optimized? ] unit-test
! Test predicate inlining ! Test predicate inlining
: pred-test-1 ( a -- b c ) : pred-test-1 ( a -- b c )
@ -95,7 +95,7 @@ TUPLE: pred-test ;
! regression ! regression
GENERIC: void-generic ( obj -- * ) GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ; : breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage optimized>> ] unit-test [ t ] [ \ breakage optimized? ] unit-test
[ breakage ] must-fail [ breakage ] must-fail
! regression ! regression
@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
! compiling <tuple> with a non-literal class failed ! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ; : <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression optimized>> ] unit-test [ t ] [ \ <tuple>-regression optimized? ] unit-test
GENERIC: foozul ( a -- b ) GENERIC: foozul ( a -- b )
M: reversed foozul ; M: reversed foozul ;
@ -229,7 +229,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * ) : node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug optimized>> ] unit-test [ t ] [ \ node-successor-f-bug optimized? ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@ -243,7 +243,7 @@ USE: binary-search.private
] if ] if
] if ; ] if ;
[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test [ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a ) : recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ; { } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test [ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
DEFER: recursive-inline-hang-3 DEFER: recursive-inline-hang-3
@ -325,7 +325,7 @@ PREDICATE: list < improper-list
dup "a" get { array-capacity } declare >= dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ; [ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
[ t ] [ \ interval-inference-bug optimized>> ] unit-test [ t ] [ \ interval-inference-bug optimized? ] unit-test
[ ] [ 1 "a" set 2 "b" set ] unit-test [ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test [ 2 3 ] [ 2 interval-inference-bug ] unit-test

4
basis/compiler/tests/peg-regression.factor
View File

@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test USE: tools.test
[ t ] [ \ expr optimized>> ] unit-test [ t ] [ \ expr optimized? ] unit-test
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test [ t ] [ \ ast>pipeline-expr optimized? ] unit-test

4
basis/compiler/tests/redefine3.factor
View File

@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ; : sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test [ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test [ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test [ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

2
basis/compiler/tests/simple.factor
View File

@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [ 10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [ [ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj ) "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test ] unit-test
] times ] times

6
basis/compiler/tests/spilling.factor
View File

@ -47,7 +47,7 @@ IN: compiler.tests.spilling
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ] [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test [ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug optimized>> ] unit-test [ t ] [ \ float-spill-bug optimized? ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object ) : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{ {
@ -132,7 +132,7 @@ IN: compiler.tests.spilling
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ] [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test [ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test [ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
: resolve-spill-bug ( a b -- c ) : resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [ [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@ -159,7 +159,7 @@ IN: compiler.tests.spilling
16 narray 16 narray
] if ; ] if ;
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test [ t ] [ \ resolve-spill-bug optimized? ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test [ 4 ] [ 1 1 resolve-spill-bug ] unit-test

2
basis/locals/locals-tests.factor
View File

@ -585,4 +585,4 @@ M: integer ed's-bug neg ;
:: ed's-test-case ( a -- b ) :: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ; { [ a ed's-bug ] } && ;
[ t ] [ \ ed's-test-case optimized>> ] unit-test [ t ] [ \ ed's-test-case optimized? ] unit-test

2
basis/stack-checker/call-effect/call-effect.factor
View File

@ -79,7 +79,7 @@ M: quotation cached-effect
[ '[ _ execute ] ] dip call-effect-slow ; inline [ '[ _ execute ] ] dip call-effect-slow ; inline
: execute-effect-unsafe? ( word effect -- ? ) : execute-effect-unsafe? ( word effect -- ? )
over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
: execute-effect-fast ( word effect inline-cache -- ) : execute-effect-fast ( word effect inline-cache -- )
2over execute-effect-unsafe? 2over execute-effect-unsafe?

2
basis/stack-checker/known-words/known-words.factor
View File

@ -677,3 +677,5 @@ M: object infer-call*
\ dispatch-stats { } { array } define-primitive \ dispatch-stats { } { array } define-primitive
\ reset-inline-cache-stats { } { } define-primitive \ reset-inline-cache-stats { } { } define-primitive
\ inline-cache-stats { } { array } define-primitive \ inline-cache-stats { } { array } define-primitive
\ optimized? { word } { object } define-primitive

2
basis/tools/walker/walker-tests.factor
View File

@ -118,7 +118,7 @@ IN: tools.walker.tests
\ breakpoint-test don't-step-into \ breakpoint-test don't-step-into
[ f ] [ \ breakpoint-test optimized>> ] unit-test [ f ] [ \ breakpoint-test optimized? ] unit-test
[ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test [ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test

5
core/bootstrap/primitives.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math math.private math.order hashtables.private io kernel math math.private math.order
@ -259,7 +259,7 @@ bi
"vocabulary" "vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] } { "def" { "quotation" "quotations" } initial: [ ] }
"props" "props"
{ "optimized" read-only } { "direct-entry-def" }
{ "counter" { "fixnum" "math" } } { "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only } { "sub-primitive" read-only }
} define-builtin } define-builtin
@ -539,6 +539,7 @@ tuple
{ "dispatch-stats" "generic.single" (( -- stats )) } { "dispatch-stats" "generic.single" (( -- stats )) }
{ "reset-inline-cache-stats" "generic.single" (( -- )) } { "reset-inline-cache-stats" "generic.single" (( -- )) }
{ "inline-cache-stats" "generic.single" (( -- stats )) } { "inline-cache-stats" "generic.single" (( -- stats )) }
{ "optimized?" "words" (( word -- ? )) }
} [ [ first3 ] dip swap make-primitive ] each-index } [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number ! Bump build number

8
core/combinators/combinators-tests.factor
View File

@ -16,12 +16,12 @@ IN: combinators.tests
: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ; : compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test [ t ] [ \ compile-execute(-test-1 optimized? ] unit-test
[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test [ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ; : compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test [ t ] [ \ compile-execute(-test-2 optimized? ] unit-test
[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test [ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test [ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test [ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
@ -29,7 +29,7 @@ IN: combinators.tests
: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ; : compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test [ t ] [ \ compile-call(-test-1 optimized? ] unit-test
[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test [ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test [ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test [ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
@ -352,7 +352,7 @@ DEFER: corner-case-1
<< \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >> << \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >>
[ t ] [ \ corner-case-1 optimized>> ] unit-test [ t ] [ \ corner-case-1 optimized? ] unit-test
[ 4 ] [ 2 corner-case-1 ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test

146
vm/arrays.c Normal file
View File

@ -0,0 +1,146 @@
#include "master.h"
/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
F_ARRAY *allot_array_internal(CELL type, CELL capacity)
{
F_ARRAY *array = allot_object(type,array_size(capacity));
array->capacity = tag_fixnum(capacity);
return array;
}
/* make a new array with an initial element */
F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
{
int i;
REGISTER_ROOT(fill);
F_ARRAY* array = allot_array_internal(type, capacity);
UNREGISTER_ROOT(fill);
if(fill == 0)
memset((void*)AREF(array,0),'\0',capacity * CELLS);
else
{
/* No need for write barrier here. Either the object is in
the nursery, or it was allocated directly in tenured space
and the write barrier is already hit for us in that case. */
for(i = 0; i < capacity; i++)
put(AREF(array,i),fill);
}
return array;
}
/* push a new array on the stack */
void primitive_array(void)
{
CELL initial = dpop();
CELL size = unbox_array_size();
dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
}
CELL allot_array_1(CELL obj)
{
REGISTER_ROOT(obj);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
UNREGISTER_ROOT(obj);
set_array_nth(a,0,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);
REGISTER_ROOT(v2);
REGISTER_ROOT(v3);
REGISTER_ROOT(v4);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
UNREGISTER_ROOT(v4);
UNREGISTER_ROOT(v3);
UNREGISTER_ROOT(v2);
UNREGISTER_ROOT(v1);
set_array_nth(a,0,v1);
set_array_nth(a,1,v2);
set_array_nth(a,2,v3);
set_array_nth(a,3,v4);
return tag_object(a);
}
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
{
#ifdef FACTOR_DEBUG
CELL header = untag_header(array->header);
assert(header == ARRAY_TYPE || header == BIGNUM_TYPE);
#endif
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
return new_array;
}
void primitive_resize_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_array(array,capacity)));
}
void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt)
{
F_ARRAY *underlying = untag_object(array->array);
REGISTER_ROOT(elt);
if(array->count == array_capacity(underlying))
{
underlying = reallot_array(underlying,array->count * 2);
array->array = tag_object(underlying);
}
UNREGISTER_ROOT(elt);
set_array_nth(underlying,array->count++,elt);
}
void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts)
{
REGISTER_UNTAGGED(elts);
F_ARRAY *underlying = untag_object(array->array);
CELL elts_size = array_capacity(elts);
CELL new_size = array->count + elts_size;
if(new_size >= array_capacity(underlying))
{
underlying = reallot_array(underlying,new_size * 2);
array->array = tag_object(underlying);
}
UNREGISTER_UNTAGGED(elts);
write_barrier(array->array);
memcpy((void *)AREF(underlying,array->count),
(void *)AREF(elts,0),
elts_size * CELLS);
array->count += elts_size;
}

90
vm/arrays.h Normal file
View File

@ -0,0 +1,90 @@
DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
/* Inline functions */
INLINE CELL array_size(CELL size)
{
return sizeof(F_ARRAY) + size * CELLS;
}
INLINE CELL array_capacity(F_ARRAY* array)
{
#ifdef FACTOR_DEBUG
CELL header = untag_header(array->header);
assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE);
#endif
return array->capacity >> TAG_BITS;
}
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
INLINE CELL array_nth(F_ARRAY *array, CELL slot)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(untag_header(array->header) == ARRAY_TYPE);
#endif
return get(AREF(array,slot));
}
INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(untag_header(array->header) == ARRAY_TYPE);
#endif
put(AREF(array,slot),value);
write_barrier((CELL)array);
}
F_ARRAY *allot_array_internal(CELL type, CELL capacity);
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);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
void primitive_resize_array(void);
/* Macros to simulate a vector in C */
typedef struct {
CELL count;
CELL array;
} F_GROWABLE_ARRAY;
/* Allocates memory */
INLINE F_GROWABLE_ARRAY make_growable_array(void)
{
F_GROWABLE_ARRAY result;
result.count = 0;
result.array = tag_object(allot_array(ARRAY_TYPE,100,F));
return result;
}
#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \
REGISTER_ROOT(result##_g.array)
void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt);
#define GROWABLE_ARRAY_ADD(result,elt) \
growable_array_add(&result##_g,elt)
void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts);
#define GROWABLE_ARRAY_APPEND(result,elts) \
growable_array_append(&result##_g,elts)
INLINE void growable_array_trim(F_GROWABLE_ARRAY *array)
{
array->array = tag_object(reallot_array(untag_object(array->array),array->count));
}
#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g)
#define GROWABLE_ARRAY_DONE(result) \
UNREGISTER_ROOT(result##_g.array); \
CELL result = result##_g.array;

13
vm/booleans.c Normal file
View File

@ -0,0 +1,13 @@
#include "master.h"
/* FFI calls this */
void box_boolean(bool value)
{
dpush(value ? T : F);
}
/* FFI calls this */
bool to_boolean(CELL value)
{
return value != F;
}

7
vm/booleans.h Normal file
View File

@ -0,0 +1,7 @@
INLINE CELL tag_boolean(CELL untagged)
{
return (untagged == false ? F : T);
}
DLLEXPORT void box_boolean(bool value);
DLLEXPORT bool to_boolean(CELL value);

73
vm/byte_arrays.c Normal file
View File

@ -0,0 +1,73 @@
#include "master.h"
/* must fill out array before next GC */
F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
{
F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
byte_array_size(size));
array->capacity = tag_fixnum(size);
return array;
}
/* size is in bytes this time */
F_BYTE_ARRAY *allot_byte_array(CELL size)
{
F_BYTE_ARRAY *array = allot_byte_array_internal(size);
memset(array + 1,0,size);
return array;
}
/* push a new byte array on the stack */
void primitive_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
}
void primitive_uninitialized_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array_internal(size)));
}
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
{
#ifdef FACTOR_DEBUG
assert(untag_header(array->header) == BYTE_ARRAY_TYPE);
#endif
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy);
return new_array;
}
void primitive_resize_byte_array(void)
{
F_BYTE_ARRAY* array = untag_byte_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_byte_array(array,capacity)));
}
void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len)
{
CELL new_size = array->count + len;
F_BYTE_ARRAY *underlying = untag_object(array->array);
if(new_size >= byte_array_capacity(underlying))
{
underlying = reallot_byte_array(underlying,new_size * 2);
array->array = tag_object(underlying);
}
memcpy((void *)BREF(underlying,array->count),elts,len);
array->count += len;
}

40
vm/byte_arrays.h Normal file
View File

@ -0,0 +1,40 @@
DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
{
return untag_fixnum_fast(array->capacity);
}
INLINE CELL byte_array_size(CELL size)
{
return sizeof(F_BYTE_ARRAY) + size;
}
F_BYTE_ARRAY *allot_byte_array(CELL size);
F_BYTE_ARRAY *allot_byte_array_internal(CELL size);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
void primitive_byte_array(void);
void primitive_uninitialized_byte_array(void);
void primitive_resize_byte_array(void);
/* Macros to simulate a byte vector in C */
typedef struct {
CELL count;
CELL array;
} F_GROWABLE_BYTE_ARRAY;
INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void)
{
F_GROWABLE_BYTE_ARRAY result;
result.count = 0;
result.array = tag_object(allot_byte_array(100));
return result;
}
void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len);
INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
{
byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
}

7
vm/callstack.h
View File

@ -1,3 +1,10 @@
INLINE CELL callstack_size(CELL size)
{
return sizeof(F_CALLSTACK) + size;
}
DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)

12
vm/code_heap.c
View File

@ -12,15 +12,6 @@ bool in_code_heap_p(CELL ptr)
&& ptr <= code_heap.segment->end); && ptr <= code_heap.segment->end);
} }
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
{
if(compiled->block.type != WORD_TYPE)
critical_error("bad param to set_word_xt",(CELL)compiled);
word->code = compiled;
word->optimizedp = T;
}
/* Compile a word definition with the non-optimizing compiler. Allocates memory */ /* Compile a word definition with the non-optimizing compiler. Allocates memory */
void jit_compile_word(F_WORD *word, CELL def, bool relocate) void jit_compile_word(F_WORD *word, CELL def, bool relocate)
{ {
@ -31,7 +22,6 @@ void jit_compile_word(F_WORD *word, CELL def, bool relocate)
UNREGISTER_ROOT(def); UNREGISTER_ROOT(def);
word->code = untag_quotation(def)->code; word->code = untag_quotation(def)->code;
word->optimizedp = F;
} }
/* Apply a function to every code block */ /* Apply a function to every code block */
@ -115,7 +105,7 @@ void primitive_modify_code_heap(void)
UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(word);
UNREGISTER_UNTAGGED(alist); UNREGISTER_UNTAGGED(alist);
set_word_code(word,compiled); word->code = compiled;
} }
else else
critical_error("Expected a quotation or an array",data); critical_error("Expected a quotation or an array",data);

2
vm/code_heap.h
View File

@ -7,8 +7,6 @@ bool in_code_heap_p(CELL ptr);
void jit_compile_word(F_WORD *word, CELL def, bool relocate); void jit_compile_word(F_WORD *word, CELL def, bool relocate);
void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled);
typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled); typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
void iterate_code_heap(CODE_HEAP_ITERATOR iter); void iterate_code_heap(CODE_HEAP_ITERATOR iter);

5
vm/layouts.h
View File

@ -155,9 +155,8 @@ typedef struct {
CELL def; CELL def;
/* TAGGED property assoc for library code */ /* TAGGED property assoc for library code */
CELL props; CELL props;
/* TAGGED t or f, t means its compiled with the optimizing compiler, /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
f means its compiled with the non-optimizing compiler */ CELL direct_entry_def;
CELL optimizedp;
/* TAGGED call count for profiling */ /* TAGGED call count for profiling */
CELL counter; CELL counter;
/* TAGGED machine code for sub-primitive */ /* TAGGED machine code for sub-primitive */

7
vm/master.h
View File

@ -34,7 +34,12 @@
#include "data_gc.h" #include "data_gc.h"
#include "local_roots.h" #include "local_roots.h"
#include "debug.h" #include "debug.h"
#include "types.h" #include "arrays.h"
#include "strings.h"
#include "booleans.h"
#include "byte_arrays.h"
#include "tuples.h"
#include "words.h"
#include "math.h" #include "math.h"
#include "float_bits.h" #include "float_bits.h"
#include "io.h" #include "io.h"

1
vm/primitives.c
View File

@ -151,4 +151,5 @@ void *primitives[] = {
primitive_dispatch_stats, primitive_dispatch_stats,
primitive_reset_inline_cache_stats, primitive_reset_inline_cache_stats,
primitive_inline_cache_stats, primitive_inline_cache_stats,
primitive_optimized_p,
}; };

21
vm/profiler.c
View File

@ -1,7 +1,7 @@
#include "master.h" #include "master.h"
/* Allocates memory */ /* Allocates memory */
static F_CODE_BLOCK *compile_profiling_stub(CELL word) F_CODE_BLOCK *compile_profiling_stub(CELL word)
{ {
REGISTER_ROOT(word); REGISTER_ROOT(word);
F_JIT jit; F_JIT jit;
@ -13,25 +13,6 @@ static F_CODE_BLOCK *compile_profiling_stub(CELL word)
return block; return block;
} }
/* Allocates memory */
void update_word_xt(F_WORD *word)
{
if(profiling_p)
{
if(!word->profiling)
{
REGISTER_UNTAGGED(word);
F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word));
UNREGISTER_UNTAGGED(word);
word->profiling = profiling;
}
word->xt = (XT)(word->profiling + 1);
}
else
word->xt = (XT)(word->code + 1);
}
/* Allocates memory */ /* Allocates memory */
static void set_profiling(bool profiling) static void set_profiling(bool profiling)
{ {

2
vm/profiler.h
View File

@ -1,3 +1,3 @@
bool profiling_p; bool profiling_p;
F_CODE_BLOCK *compile_profiling_stub(CELL word);
void primitive_profiling(void); void primitive_profiling(void);
void update_word_xt(F_WORD *word);

2
vm/quotations.c
View File

@ -461,7 +461,7 @@ void compile_all_words(void)
F_WORD *word = untag_word(array_nth(untag_array(words),i)); F_WORD *word = untag_word(array_nth(untag_array(words),i));
REGISTER_UNTAGGED(word); REGISTER_UNTAGGED(word);
if(word->optimizedp == F) if(!word->code || !word_optimized_p(word))
jit_compile_word(word,word->def,false); jit_compile_word(word,word->def,false);
UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(word);

2
vm/quotations.h
View File

@ -1,3 +1,5 @@
DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
void jit_compile(CELL quot, bool relocate); void jit_compile(CELL quot, bool relocate);
F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);

22
vm/run.c
View File

@ -224,3 +224,25 @@ void primitive_load_locals(void)
ds -= CELLS * count; ds -= CELLS * count;
rs += CELLS * count; rs += CELLS * count;
} }
static CELL clone_object(CELL object)
{
CELL size = object_size(object);
if(size == 0)
return object;
else
{
REGISTER_ROOT(object);
void *new_obj = allot_object(type_of(object),size);
UNREGISTER_ROOT(object);
CELL tag = TAG(object);
memcpy(new_obj,(void*)UNTAG(object),size);
return RETAG(new_obj,tag);
}
}
void primitive_clone(void)
{
drepl(clone_object(dpeek()));
}

6
vm/run.h
View File

@ -262,14 +262,10 @@ void primitive_check_datastack(void);
void primitive_getenv(void); void primitive_getenv(void);
void primitive_setenv(void); void primitive_setenv(void);
void primitive_exit(void); void primitive_exit(void);
void primitive_os_env(void);
void primitive_os_envs(void);
void primitive_set_os_env(void);
void primitive_unset_os_env(void);
void primitive_set_os_envs(void);
void primitive_micros(void); void primitive_micros(void);
void primitive_sleep(void); void primitive_sleep(void);
void primitive_set_slot(void); void primitive_set_slot(void);
void primitive_load_locals(void); void primitive_load_locals(void);
void primitive_clone(void);
bool stage2; bool stage2;

274
vm/strings.c Normal file
View File

@ -0,0 +1,274 @@
#include "master.h"
CELL string_nth(F_STRING* string, CELL index)
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
corresponding aux vector entry is negated, so that we can
XOR the two components together and get the original code point
back. */
CELL ch = bget(SREF(string,index));
if((ch & 0x80) == 0)
return ch;
else
{
F_BYTE_ARRAY *aux = untag_object(string->aux);
return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
}
}
void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
{
bput(SREF(string,index),ch);
}
void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
{
F_BYTE_ARRAY *aux;
bput(SREF(string,index),(ch & 0x7f) | 0x80);
if(string->aux == F)
{
REGISTER_UNTAGGED(string);
/* We don't need to pre-initialize the
byte array with any data, since we
only ever read from the aux vector
if the most significant bit of a
character is set. Initially all of
the bits are clear. */
aux = allot_byte_array_internal(
untag_fixnum_fast(string->length)
* sizeof(u16));
UNREGISTER_UNTAGGED(string);
write_barrier((CELL)string);
string->aux = tag_object(aux);
}
else
aux = untag_object(string->aux);
cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
}
/* allocates memory */
void set_string_nth(F_STRING* string, CELL index, CELL ch)
{
if(ch <= 0x7f)
set_string_nth_fast(string,index,ch);
else
set_string_nth_slow(string,index,ch);
}
/* untagged */
F_STRING* allot_string_internal(CELL capacity)
{
F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
string->length = tag_fixnum(capacity);
string->hashcode = F;
string->aux = F;
return string;
}
/* allocates memory */
void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{
if(fill <= 0x7f)
memset((void *)SREF(string,start),fill,capacity - start);
else
{
CELL i;
for(i = start; i < capacity; i++)
{
REGISTER_UNTAGGED(string);
set_string_nth(string,i,fill);
UNREGISTER_UNTAGGED(string);
}
}
}
/* untagged */
F_STRING *allot_string(CELL capacity, CELL fill)
{
F_STRING* string = allot_string_internal(capacity);
REGISTER_UNTAGGED(string);
fill_string(string,0,capacity,fill);
UNREGISTER_UNTAGGED(string);
return string;
}
void primitive_string(void)
{
CELL initial = to_cell(dpop());
CELL length = unbox_array_size();
dpush(tag_object(allot_string(length,initial)));
}
F_STRING* reallot_string(F_STRING* string, CELL capacity)
{
CELL to_copy = string_capacity(string);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(string);
F_STRING *new_string = allot_string_internal(capacity);
UNREGISTER_UNTAGGED(string);
memcpy(new_string + 1,string + 1,to_copy);
if(string->aux != F)
{
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
write_barrier((CELL)new_string);
new_string->aux = tag_object(new_aux);
F_BYTE_ARRAY *aux = untag_object(string->aux);
memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
}
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
fill_string(new_string,to_copy,capacity,'\0');
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
return new_string;
}
void primitive_resize_string(void)
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_string(string,capacity)));
}
/* Some ugly macros to prevent a 2x code duplication */
#define MEMORY_TO_STRING(type,utype) \
F_STRING *memory_to_##type##_string(const type *string, CELL length) \
{ \
REGISTER_C_STRING(string); \
F_STRING* s = allot_string_internal(length); \
UNREGISTER_C_STRING(string); \
CELL i; \
for(i = 0; i < length; i++) \
{ \
REGISTER_UNTAGGED(s); \
set_string_nth(s,i,(utype)*string); \
UNREGISTER_UNTAGGED(s); \
string++; \
} \
return s; \
} \
F_STRING *from_##type##_string(const type *str) \
{ \
CELL length = 0; \
const type *scan = str; \
while(*scan++) length++; \
return memory_to_##type##_string(str,length); \
} \
void box_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
}
MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16)
MEMORY_TO_STRING(u32,u32)
bool check_string(F_STRING *s, CELL max)
{
CELL capacity = string_capacity(s);
CELL i;
for(i = 0; i < capacity; i++)
{
CELL ch = string_nth(s,i);
if(ch == '\0' || ch >= (1 << (max * 8)))
return false;
}
return true;
}
F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
{
return allot_byte_array((capacity + 1) * size);
}
#define STRING_TO_MEMORY(type) \
void type##_string_to_memory(F_STRING *s, type *string) \
{ \
CELL i; \
CELL capacity = string_capacity(s); \
for(i = 0; i < capacity; i++) \
string[i] = string_nth(s,i); \
} \
void primitive_##type##_string_to_memory(void) \
{ \
type *address = unbox_alien(); \
F_STRING *str = untag_string(dpop()); \
type##_string_to_memory(str,address); \
} \
F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
{ \
CELL capacity = string_capacity(s); \
F_BYTE_ARRAY *_c_str; \
if(check && !check_string(s,sizeof(type))) \
general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
REGISTER_UNTAGGED(s); \
_c_str = allot_c_string(capacity,sizeof(type)); \
UNREGISTER_UNTAGGED(s); \
type *c_str = (type*)(_c_str + 1); \
type##_string_to_memory(s,c_str); \
c_str[capacity] = 0; \
return _c_str; \
} \
type *to_##type##_string(F_STRING *s, bool check) \
{ \
return (type*)(string_to_##type##_alien(s,check) + 1); \
} \
type *unbox_##type##_string(void) \
{ \
return to_##type##_string(untag_string(dpop()),true); \
}
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
void primitive_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
void primitive_set_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
void primitive_set_string_nth_fast(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth_fast(string,index,value);
}
void primitive_set_string_nth_slow(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth_slow(string,index,value);
}

50
vm/strings.h Normal file
View File

@ -0,0 +1,50 @@
INLINE CELL string_capacity(F_STRING* str)
{
return untag_fixnum_fast(str->length);
}
INLINE CELL string_size(CELL size)
{
return sizeof(F_STRING) + size;
}
#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
INLINE F_STRING* untag_string(CELL tagged)
{
type_check(STRING_TYPE,tagged);
return untag_object(tagged);
}
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
void primitive_string(void);
F_STRING *reallot_string(F_STRING *string, CELL capacity);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
DLLEXPORT void box_char_string(const char *c_string);
F_STRING *memory_to_u16_string(const u16 *string, CELL length);
F_STRING *from_u16_string(const u16 *c_string);
DLLEXPORT void box_u16_string(const u16 *c_string);
void char_string_to_memory(F_STRING *s, char *string);
F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
char* to_char_string(F_STRING *s, bool check);
DLLEXPORT char *unbox_char_string(void);
void u16_string_to_memory(F_STRING *s, u16 *string);
F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
u16* to_u16_string(F_STRING *s, bool check);
DLLEXPORT u16 *unbox_u16_string(void);
/* String getters and setters */
CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);
void primitive_string_nth(void);
void primitive_set_string_nth_slow(void);
void primitive_set_string_nth_fast(void);

35
vm/tuples.c Normal file
View File

@ -0,0 +1,35 @@
#include "master.h"
/* push a new tuple on the stack */
F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
{
REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
UNREGISTER_UNTAGGED(layout);
tuple->layout = tag_object(layout);
return tuple;
}
void primitive_tuple(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
F_FIXNUM i;
for(i = size - 1; i >= 0; i--)
put(AREF(tuple,i),F);
dpush(tag_tuple(tuple));
}
/* push a new tuple on the stack, filling its slots from the stack */
void primitive_tuple_boa(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
ds -= CELLS * size;
dpush(tag_tuple(tuple));
}

25
vm/tuples.h Normal file
View File

@ -0,0 +1,25 @@
INLINE CELL tag_tuple(F_TUPLE *tuple)
{
return RETAG(tuple,TUPLE_TYPE);
}
INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
{
CELL size = untag_fixnum_fast(layout->size);
return sizeof(F_TUPLE) + size * CELLS;
}
INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
{
return get(AREF(tuple,slot));
}
INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
{
put(AREF(tuple,slot),value);
write_barrier((CELL)tuple);
}
void primitive_tuple(void);
void primitive_tuple_boa(void);
void primitive_tuple_layout(void);

623
vm/types.c
View File

@ -1,623 +0,0 @@
#include "master.h"
/* FFI calls this */
void box_boolean(bool value)
{
dpush(value ? T : F);
}
/* FFI calls this */
bool to_boolean(CELL value)
{
return value != F;
}
CELL clone_object(CELL object)
{
CELL size = object_size(object);
if(size == 0)
return object;
else
{
REGISTER_ROOT(object);
void *new_obj = allot_object(type_of(object),size);
UNREGISTER_ROOT(object);
CELL tag = TAG(object);
memcpy(new_obj,(void*)UNTAG(object),size);
return RETAG(new_obj,tag);
}
}
void primitive_clone(void)
{
drepl(clone_object(dpeek()));
}
F_WORD *allot_word(CELL vocab, CELL name)
{
REGISTER_ROOT(vocab);
REGISTER_ROOT(name);
F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
UNREGISTER_ROOT(name);
UNREGISTER_ROOT(vocab);
word->hashcode = tag_fixnum((rand() << 16) ^ rand());
word->vocabulary = vocab;
word->name = name;
word->def = userenv[UNDEFINED_ENV];
word->props = F;
word->counter = tag_fixnum(0);
word->optimizedp = F;
word->subprimitive = F;
word->profiling = NULL;
word->code = NULL;
REGISTER_UNTAGGED(word);
jit_compile_word(word,word->def,true);
UNREGISTER_UNTAGGED(word);
REGISTER_UNTAGGED(word);
update_word_xt(word);
UNREGISTER_UNTAGGED(word);
if(profiling_p)
relocate_code_block(word->profiling);
return word;
}
/* <word> ( name vocabulary -- word ) */
void primitive_word(void)
{
CELL vocab = dpop();
CELL name = dpop();
dpush(tag_object(allot_word(vocab,name)));
}
/* word-xt ( word -- start end ) */
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 + code->block.size));
}
void primitive_wrapper(void)
{
F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
drepl(tag_object(wrapper));
}
/* Arrays */
/* the array is full of undefined data, and must be correctly filled before the
next GC. size is in cells */
F_ARRAY *allot_array_internal(CELL type, CELL capacity)
{
F_ARRAY *array = allot_object(type,array_size(capacity));
array->capacity = tag_fixnum(capacity);
return array;
}
/* make a new array with an initial element */
F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
{
int i;
REGISTER_ROOT(fill);
F_ARRAY* array = allot_array_internal(type, capacity);
UNREGISTER_ROOT(fill);
if(fill == 0)
memset((void*)AREF(array,0),'\0',capacity * CELLS);
else
{
/* No need for write barrier here. Either the object is in
the nursery, or it was allocated directly in tenured space
and the write barrier is already hit for us in that case. */
for(i = 0; i < capacity; i++)
put(AREF(array,i),fill);
}
return array;
}
/* push a new array on the stack */
void primitive_array(void)
{
CELL initial = dpop();
CELL size = unbox_array_size();
dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
}
CELL allot_array_1(CELL obj)
{
REGISTER_ROOT(obj);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
UNREGISTER_ROOT(obj);
set_array_nth(a,0,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);
REGISTER_ROOT(v2);
REGISTER_ROOT(v3);
REGISTER_ROOT(v4);
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
UNREGISTER_ROOT(v4);
UNREGISTER_ROOT(v3);
UNREGISTER_ROOT(v2);
UNREGISTER_ROOT(v1);
set_array_nth(a,0,v1);
set_array_nth(a,1,v2);
set_array_nth(a,2,v3);
set_array_nth(a,3,v4);
return tag_object(a);
}
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
{
#ifdef FACTOR_DEBUG
CELL header = untag_header(array->header);
assert(header == ARRAY_TYPE || header == BIGNUM_TYPE);
#endif
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy * CELLS);
memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
return new_array;
}
void primitive_resize_array(void)
{
F_ARRAY* array = untag_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_array(array,capacity)));
}
void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt)
{
F_ARRAY *underlying = untag_object(array->array);
REGISTER_ROOT(elt);
if(array->count == array_capacity(underlying))
{
underlying = reallot_array(underlying,array->count * 2);
array->array = tag_object(underlying);
}
UNREGISTER_ROOT(elt);
set_array_nth(underlying,array->count++,elt);
}
void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts)
{
REGISTER_UNTAGGED(elts);
F_ARRAY *underlying = untag_object(array->array);
CELL elts_size = array_capacity(elts);
CELL new_size = array->count + elts_size;
if(new_size >= array_capacity(underlying))
{
underlying = reallot_array(underlying,new_size * 2);
array->array = tag_object(underlying);
}
UNREGISTER_UNTAGGED(elts);
write_barrier(array->array);
memcpy((void *)AREF(underlying,array->count),
(void *)AREF(elts,0),
elts_size * CELLS);
array->count += elts_size;
}
/* Byte arrays */
/* must fill out array before next GC */
F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
{
F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
byte_array_size(size));
array->capacity = tag_fixnum(size);
return array;
}
/* size is in bytes this time */
F_BYTE_ARRAY *allot_byte_array(CELL size)
{
F_BYTE_ARRAY *array = allot_byte_array_internal(size);
memset(array + 1,0,size);
return array;
}
/* push a new byte array on the stack */
void primitive_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array(size)));
}
void primitive_uninitialized_byte_array(void)
{
CELL size = unbox_array_size();
dpush(tag_object(allot_byte_array_internal(size)));
}
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
{
#ifdef FACTOR_DEBUG
assert(untag_header(array->header) == BYTE_ARRAY_TYPE);
#endif
CELL to_copy = array_capacity(array);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(array);
F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
UNREGISTER_UNTAGGED(array);
memcpy(new_array + 1,array + 1,to_copy);
return new_array;
}
void primitive_resize_byte_array(void)
{
F_BYTE_ARRAY* array = untag_byte_array(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_byte_array(array,capacity)));
}
void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *array, void *elts, CELL len)
{
CELL new_size = array->count + len;
F_BYTE_ARRAY *underlying = untag_object(array->array);
if(new_size >= byte_array_capacity(underlying))
{
underlying = reallot_byte_array(underlying,new_size * 2);
array->array = tag_object(underlying);
}
memcpy((void *)BREF(underlying,array->count),elts,len);
array->count += len;
}
/* Tuples */
/* push a new tuple on the stack */
F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
{
REGISTER_UNTAGGED(layout);
F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
UNREGISTER_UNTAGGED(layout);
tuple->layout = tag_object(layout);
return tuple;
}
void primitive_tuple(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
F_FIXNUM i;
for(i = size - 1; i >= 0; i--)
put(AREF(tuple,i),F);
dpush(tag_tuple(tuple));
}
/* push a new tuple on the stack, filling its slots from the stack */
void primitive_tuple_boa(void)
{
F_TUPLE_LAYOUT *layout = untag_object(dpop());
F_FIXNUM size = untag_fixnum_fast(layout->size);
F_TUPLE *tuple = allot_tuple(layout);
memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
ds -= CELLS * size;
dpush(tag_tuple(tuple));
}
/* Strings */
CELL string_nth(F_STRING* string, CELL index)
{
/* If high bit is set, the most significant 16 bits of the char
come from the aux vector. The least significant bit of the
corresponding aux vector entry is negated, so that we can
XOR the two components together and get the original code point
back. */
CELL ch = bget(SREF(string,index));
if((ch & 0x80) == 0)
return ch;
else
{
F_BYTE_ARRAY *aux = untag_object(string->aux);
return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
}
}
void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
{
bput(SREF(string,index),ch);
}
void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
{
F_BYTE_ARRAY *aux;
bput(SREF(string,index),(ch & 0x7f) | 0x80);
if(string->aux == F)
{
REGISTER_UNTAGGED(string);
/* We don't need to pre-initialize the
byte array with any data, since we
only ever read from the aux vector
if the most significant bit of a
character is set. Initially all of
the bits are clear. */
aux = allot_byte_array_internal(
untag_fixnum_fast(string->length)
* sizeof(u16));
UNREGISTER_UNTAGGED(string);
write_barrier((CELL)string);
string->aux = tag_object(aux);
}
else
aux = untag_object(string->aux);
cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
}
/* allocates memory */
void set_string_nth(F_STRING* string, CELL index, CELL ch)
{
if(ch <= 0x7f)
set_string_nth_fast(string,index,ch);
else
set_string_nth_slow(string,index,ch);
}
/* untagged */
F_STRING* allot_string_internal(CELL capacity)
{
F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
string->length = tag_fixnum(capacity);
string->hashcode = F;
string->aux = F;
return string;
}
/* allocates memory */
void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
{
if(fill <= 0x7f)
memset((void *)SREF(string,start),fill,capacity - start);
else
{
CELL i;
for(i = start; i < capacity; i++)
{
REGISTER_UNTAGGED(string);
set_string_nth(string,i,fill);
UNREGISTER_UNTAGGED(string);
}
}
}
/* untagged */
F_STRING *allot_string(CELL capacity, CELL fill)
{
F_STRING* string = allot_string_internal(capacity);
REGISTER_UNTAGGED(string);
fill_string(string,0,capacity,fill);
UNREGISTER_UNTAGGED(string);
return string;
}
void primitive_string(void)
{
CELL initial = to_cell(dpop());
CELL length = unbox_array_size();
dpush(tag_object(allot_string(length,initial)));
}
F_STRING* reallot_string(F_STRING* string, CELL capacity)
{
CELL to_copy = string_capacity(string);
if(capacity < to_copy)
to_copy = capacity;
REGISTER_UNTAGGED(string);
F_STRING *new_string = allot_string_internal(capacity);
UNREGISTER_UNTAGGED(string);
memcpy(new_string + 1,string + 1,to_copy);
if(string->aux != F)
{
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
write_barrier((CELL)new_string);
new_string->aux = tag_object(new_aux);
F_BYTE_ARRAY *aux = untag_object(string->aux);
memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
}
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
fill_string(new_string,to_copy,capacity,'\0');
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
return new_string;
}
void primitive_resize_string(void)
{
F_STRING* string = untag_string(dpop());
CELL capacity = unbox_array_size();
dpush(tag_object(reallot_string(string,capacity)));
}
/* Some ugly macros to prevent a 2x code duplication */
#define MEMORY_TO_STRING(type,utype) \
F_STRING *memory_to_##type##_string(const type *string, CELL length) \
{ \
REGISTER_C_STRING(string); \
F_STRING* s = allot_string_internal(length); \
UNREGISTER_C_STRING(string); \
CELL i; \
for(i = 0; i < length; i++) \
{ \
REGISTER_UNTAGGED(s); \
set_string_nth(s,i,(utype)*string); \
UNREGISTER_UNTAGGED(s); \
string++; \
} \
return s; \
} \
F_STRING *from_##type##_string(const type *str) \
{ \
CELL length = 0; \
const type *scan = str; \
while(*scan++) length++; \
return memory_to_##type##_string(str,length); \
} \
void box_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
}
MEMORY_TO_STRING(char,u8)
MEMORY_TO_STRING(u16,u16)
MEMORY_TO_STRING(u32,u32)
bool check_string(F_STRING *s, CELL max)
{
CELL capacity = string_capacity(s);
CELL i;
for(i = 0; i < capacity; i++)
{
CELL ch = string_nth(s,i);
if(ch == '\0' || ch >= (1 << (max * 8)))
return false;
}
return true;
}
F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
{
return allot_byte_array((capacity + 1) * size);
}
#define STRING_TO_MEMORY(type) \
void type##_string_to_memory(F_STRING *s, type *string) \
{ \
CELL i; \
CELL capacity = string_capacity(s); \
for(i = 0; i < capacity; i++) \
string[i] = string_nth(s,i); \
} \
void primitive_##type##_string_to_memory(void) \
{ \
type *address = unbox_alien(); \
F_STRING *str = untag_string(dpop()); \
type##_string_to_memory(str,address); \
} \
F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
{ \
CELL capacity = string_capacity(s); \
F_BYTE_ARRAY *_c_str; \
if(check && !check_string(s,sizeof(type))) \
general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
REGISTER_UNTAGGED(s); \
_c_str = allot_c_string(capacity,sizeof(type)); \
UNREGISTER_UNTAGGED(s); \
type *c_str = (type*)(_c_str + 1); \
type##_string_to_memory(s,c_str); \
c_str[capacity] = 0; \
return _c_str; \
} \
type *to_##type##_string(F_STRING *s, bool check) \
{ \
return (type*)(string_to_##type##_alien(s,check) + 1); \
} \
type *unbox_##type##_string(void) \
{ \
return to_##type##_string(untag_string(dpop()),true); \
}
STRING_TO_MEMORY(char);
STRING_TO_MEMORY(u16);
void primitive_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
void primitive_set_string_nth(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
void primitive_set_string_nth_fast(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth_fast(string,index,value);
}
void primitive_set_string_nth_slow(void)
{
F_STRING *string = untag_object(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth_slow(string,index,value);
}

231
vm/types.h
View File

@ -1,231 +0,0 @@
/* Inline functions */
INLINE CELL array_size(CELL size)
{
return sizeof(F_ARRAY) + size * CELLS;
}
INLINE CELL string_capacity(F_STRING* str)
{
return untag_fixnum_fast(str->length);
}
INLINE CELL string_size(CELL size)
{
return sizeof(F_STRING) + size;
}
DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
{
return untag_fixnum_fast(array->capacity);
}
INLINE CELL byte_array_size(CELL size)
{
return sizeof(F_BYTE_ARRAY) + size;
}
INLINE CELL callstack_size(CELL size)
{
return sizeof(F_CALLSTACK) + size;
}
DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
INLINE CELL tag_boolean(CELL untagged)
{
return (untagged == false ? F : T);
}
DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
INLINE CELL array_capacity(F_ARRAY* array)
{
#ifdef FACTOR_DEBUG
CELL header = untag_header(array->header);
assert(header == ARRAY_TYPE || header == BIGNUM_TYPE || header == BYTE_ARRAY_TYPE);
#endif
return array->capacity >> TAG_BITS;
}
#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
INLINE CELL array_nth(F_ARRAY *array, CELL slot)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(untag_header(array->header) == ARRAY_TYPE);
#endif
return get(AREF(array,slot));
}
INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
{
#ifdef FACTOR_DEBUG
assert(slot < array_capacity(array));
assert(untag_header(array->header) == ARRAY_TYPE);
#endif
put(AREF(array,slot),value);
write_barrier((CELL)array);
}
#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
INLINE F_STRING* untag_string(CELL tagged)
{
type_check(STRING_TYPE,tagged);
return untag_object(tagged);
}
DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
INLINE CELL tag_tuple(F_TUPLE *tuple)
{
return RETAG(tuple,TUPLE_TYPE);
}
INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
{
CELL size = untag_fixnum_fast(layout->size);
return sizeof(F_TUPLE) + size * CELLS;
}
INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
{
return get(AREF(tuple,slot));
}
INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
{
put(AREF(tuple,slot),value);
write_barrier((CELL)tuple);
}
/* Prototypes */
DLLEXPORT void box_boolean(bool value);
DLLEXPORT bool to_boolean(CELL value);
F_ARRAY *allot_array_internal(CELL type, CELL capacity);
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);
void primitive_tuple(void);
void primitive_tuple_boa(void);
void primitive_tuple_layout(void);
void primitive_byte_array(void);
void primitive_uninitialized_byte_array(void);
void primitive_clone(void);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
void primitive_resize_array(void);
void primitive_resize_byte_array(void);
F_STRING* allot_string_internal(CELL capacity);
F_STRING* allot_string(CELL capacity, CELL fill);
void primitive_uninitialized_string(void);
void primitive_string(void);
F_STRING *reallot_string(F_STRING *string, CELL capacity);
void primitive_resize_string(void);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
DLLEXPORT void box_char_string(const char *c_string);
F_STRING *memory_to_u16_string(const u16 *string, CELL length);
F_STRING *from_u16_string(const u16 *c_string);
DLLEXPORT void box_u16_string(const u16 *c_string);
void char_string_to_memory(F_STRING *s, char *string);
F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
char* to_char_string(F_STRING *s, bool check);
DLLEXPORT char *unbox_char_string(void);
void u16_string_to_memory(F_STRING *s, u16 *string);
F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
u16* to_u16_string(F_STRING *s, bool check);
DLLEXPORT u16 *unbox_u16_string(void);
/* String getters and setters */
CELL string_nth(F_STRING* string, CELL index);
void set_string_nth(F_STRING* string, CELL index, CELL value);
void primitive_string_nth(void);
void primitive_set_string_nth_slow(void);
void primitive_set_string_nth_fast(void);
F_WORD *allot_word(CELL vocab, CELL name);
void primitive_word(void);
void primitive_word_xt(void);
void primitive_wrapper(void);
/* Macros to simulate a vector in C */
typedef struct {
CELL count;
CELL array;
} F_GROWABLE_ARRAY;
/* Allocates memory */
INLINE F_GROWABLE_ARRAY make_growable_array(void)
{
F_GROWABLE_ARRAY result;
result.count = 0;
result.array = tag_object(allot_array(ARRAY_TYPE,100,F));
return result;
}
#define GROWABLE_ARRAY(result) F_GROWABLE_ARRAY result##_g = make_growable_array(); \
REGISTER_ROOT(result##_g.array)
void growable_array_add(F_GROWABLE_ARRAY *result, CELL elt);
#define GROWABLE_ARRAY_ADD(result,elt) \
growable_array_add(&result##_g,elt)
void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts);
#define GROWABLE_ARRAY_APPEND(result,elts) \
growable_array_append(&result##_g,elts)
INLINE void growable_array_trim(F_GROWABLE_ARRAY *array)
{
array->array = tag_object(reallot_array(untag_object(array->array),array->count));
}
#define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g)
#define GROWABLE_ARRAY_DONE(result) \
UNREGISTER_ROOT(result##_g.array); \
CELL result = result##_g.array;
/* Macros to simulate a byte vector in C */
typedef struct {
CELL count;
CELL array;
} F_GROWABLE_BYTE_ARRAY;
INLINE F_GROWABLE_BYTE_ARRAY make_growable_byte_array(void)
{
F_GROWABLE_BYTE_ARRAY result;
result.count = 0;
result.array = tag_object(allot_byte_array(100));
return result;
}
void growable_byte_array_append(F_GROWABLE_BYTE_ARRAY *result, void *elts, CELL len);
INLINE void growable_byte_array_trim(F_GROWABLE_BYTE_ARRAY *byte_array)
{
byte_array->array = tag_object(reallot_byte_array(untag_object(byte_array->array),byte_array->count));
}

82
vm/words.c Normal file
View File

@ -0,0 +1,82 @@
#include "master.h"
F_WORD *allot_word(CELL vocab, CELL name)
{
REGISTER_ROOT(vocab);
REGISTER_ROOT(name);
F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
UNREGISTER_ROOT(name);
UNREGISTER_ROOT(vocab);
word->hashcode = tag_fixnum((rand() << 16) ^ rand());
word->vocabulary = vocab;
word->name = name;
word->def = userenv[UNDEFINED_ENV];
word->props = F;
word->counter = tag_fixnum(0);
word->direct_entry_def = F;
word->subprimitive = F;
word->profiling = NULL;
word->code = NULL;
REGISTER_UNTAGGED(word);
jit_compile_word(word,word->def,true);
UNREGISTER_UNTAGGED(word);
REGISTER_UNTAGGED(word);
update_word_xt(word);
UNREGISTER_UNTAGGED(word);
if(profiling_p)
relocate_code_block(word->profiling);
return word;
}
/* <word> ( name vocabulary -- word ) */
void primitive_word(void)
{
CELL vocab = dpop();
CELL name = dpop();
dpush(tag_object(allot_word(vocab,name)));
}
/* word-xt ( word -- start end ) */
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 + code->block.size));
}
/* Allocates memory */
void update_word_xt(F_WORD *word)
{
if(profiling_p)
{
if(!word->profiling)
{
REGISTER_UNTAGGED(word);
F_CODE_BLOCK *profiling = compile_profiling_stub(tag_object(word));
UNREGISTER_UNTAGGED(word);
word->profiling = profiling;
}
word->xt = (XT)(word->profiling + 1);
}
else
word->xt = (XT)(word->code + 1);
}
void primitive_optimized_p(void)
{
drepl(tag_boolean(word_optimized_p(untag_word(dpeek()))));
}
void primitive_wrapper(void)
{
F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
wrapper->object = dpeek();
drepl(tag_object(wrapper));
}

16
vm/words.h Normal file
View File

@ -0,0 +1,16 @@
DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
F_WORD *allot_word(CELL vocab, CELL name);
void primitive_word(void);
void primitive_word_xt(void);
void update_word_xt(F_WORD *word);
INLINE bool word_optimized_p(F_WORD *word)
{
return word->code->block.type == WORD_TYPE;
}
void primitive_optimized_p(void);
void primitive_wrapper(void);