From 5f6c074edd8b9ecd1debe9a23cf1d6cd81552f78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Apr 2009 17:26:11 -0500 Subject: [PATCH] Split up types.c/h into smaller files, remove optimized slot from F_WORD struct --- Makefile | 9 +- .../remote-control/remote-control.factor | 2 +- basis/bootstrap/compiler/compiler.factor | 2 +- basis/bootstrap/stage2.factor | 4 - basis/compiler/compiler.factor | 2 +- basis/compiler/tests/codegen.factor | 2 +- basis/compiler/tests/optimizer.factor | 14 +- basis/compiler/tests/peg-regression.factor | 4 +- basis/compiler/tests/redefine3.factor | 4 +- basis/compiler/tests/simple.factor | 2 +- basis/compiler/tests/spilling.factor | 6 +- basis/locals/locals-tests.factor | 2 +- .../call-effect/call-effect.factor | 2 +- .../known-words/known-words.factor | 4 +- basis/tools/walker/walker-tests.factor | 2 +- core/bootstrap/primitives.factor | 5 +- core/combinators/combinators-tests.factor | 8 +- vm/arrays.c | 146 ++++ vm/arrays.h | 90 +++ vm/booleans.c | 13 + vm/booleans.h | 7 + vm/byte_arrays.c | 73 ++ vm/byte_arrays.h | 40 ++ vm/callstack.h | 7 + vm/code_heap.c | 12 +- vm/code_heap.h | 2 - vm/layouts.h | 5 +- vm/master.h | 7 +- vm/primitives.c | 1 + vm/profiler.c | 21 +- vm/profiler.h | 2 +- vm/quotations.c | 2 +- vm/quotations.h | 2 + vm/run.c | 22 + vm/run.h | 6 +- vm/strings.c | 274 ++++++++ vm/strings.h | 50 ++ vm/tuples.c | 35 + vm/tuples.h | 25 + vm/types.c | 623 ------------------ vm/types.h | 231 ------- vm/words.c | 82 +++ vm/words.h | 16 + 43 files changed, 935 insertions(+), 933 deletions(-) create mode 100644 vm/arrays.c create mode 100644 vm/arrays.h create mode 100644 vm/booleans.c create mode 100644 vm/booleans.h create mode 100644 vm/byte_arrays.c create mode 100644 vm/byte_arrays.h create mode 100644 vm/strings.c create mode 100644 vm/strings.h create mode 100644 vm/tuples.c create mode 100644 vm/tuples.h delete mode 100755 vm/types.c delete mode 100755 vm/types.h create mode 100644 vm/words.c create mode 100644 vm/words.h diff --git a/Makefile b/Makefile index d5c7e00763..9053626291 100644 --- a/Makefile +++ b/Makefile @@ -28,7 +28,10 @@ endif DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/alien.o \ + vm/arrays.o \ vm/bignum.o \ + vm/booleans.o \ + vm/byte_arrays.o \ vm/callstack.o \ vm/code_block.o \ vm/code_gc.o \ @@ -48,8 +51,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/profiler.o \ vm/quotations.o \ vm/run.o \ - vm/types.o \ - vm/utilities.o + vm/strings.o \ + vm/tuples.o \ + vm/utilities.o \ + vm/words.o EXE_OBJS = $(PLAF_EXE_OBJS) diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 4da06ec4c9..b72c79e478 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/basis/alien/remote-control/remote-control.factor @@ -15,7 +15,7 @@ IN: alien.remote-control "void" { "long" } "cdecl" [ sleep ] alien-callback ; : ?callback ( word -- alien ) - dup optimized>> [ execute ] [ drop f ] if ; inline + dup optimized? [ execute ] [ drop f ] if ; inline : init-remote-control ( -- ) \ eval-callback ?callback 16 setenv diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 3eda3bcc37..6e82e16268 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -29,7 +29,7 @@ enable-compiler gc : compile-unoptimized ( words -- ) - [ optimized>> not ] filter compile ; + [ optimized? not ] filter compile ; nl "Compiling..." write flush diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index cc853e4842..14c08c070a 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -35,10 +35,6 @@ SYMBOL: bootstrap-time "Core bootstrap completed in " write core-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 "Now, you can run Factor:" print vm write " -i=" write "output-image" get print flush ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e8a38b147e..6783b728e4 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -122,7 +122,7 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ; : compile-dependency ( word -- ) #! 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. SYMBOL: compile-dependencies? diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index c746fdfb45..611371a457 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -211,7 +211,7 @@ TUPLE: my-tuple ; { tuple vector } 3 slot { word } declare 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 diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index bd7008f909..af0f029800 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -10,7 +10,7 @@ IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; -[ t ] [ \ xyz optimized>> ] unit-test +[ t ] [ \ xyz optimized? ] unit-test ! Test predicate inlining : pred-test-1 ( a -- b c ) @@ -95,7 +95,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) : breakage ( -- * ) "hi" void-generic ; -[ t ] [ \ breakage optimized>> ] unit-test +[ t ] [ \ breakage optimized? ] unit-test [ breakage ] must-fail ! regression @@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * ) ! compiling with a non-literal class failed : -regression ( class -- tuple ) ; -[ t ] [ \ -regression optimized>> ] unit-test +[ t ] [ \ -regression optimized? ] unit-test GENERIC: foozul ( a -- b ) M: reversed foozul ; @@ -229,7 +229,7 @@ USE: binary-search.private : node-successor-f-bug ( x -- * ) [ 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 @@ -243,7 +243,7 @@ USE: binary-search.private ] 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 [ "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 ; -[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test +[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test DEFER: recursive-inline-hang-3 @@ -325,7 +325,7 @@ PREDICATE: list < improper-list dup "a" get { array-capacity } declare >= [ 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 [ 2 3 ] [ 2 interval-inference-bug ] unit-test diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index e107135305..da2f3fa604 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]] USE: tools.test -[ t ] [ \ expr optimized>> ] unit-test -[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test +[ t ] [ \ expr optimized? ] unit-test +[ t ] [ \ ast>pipeline-expr optimized? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 51ce33c1bd..0a5eb84579 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ; : sheeple-test ( -- string ) { } sheeple ; [ "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 [ 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 [ "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 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 82cc97e0f6..88dc9a53b1 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -235,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ 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 ] times diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 2ec6fbde95..b0039132a0 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -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 ] [ 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 ) { @@ -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 ] [ 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 ) [ 1 fixnum+fast ] bi@ dup 10 fixnum< [ @@ -159,7 +159,7 @@ IN: compiler.tests.spilling 16 narray ] if ; -[ t ] [ \ resolve-spill-bug optimized>> ] unit-test +[ t ] [ \ resolve-spill-bug optimized? ] unit-test [ 4 ] [ 1 1 resolve-spill-bug ] unit-test diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 68fa8dbda0..1549a77663 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -585,4 +585,4 @@ M: integer ed's-bug neg ; :: ed's-test-case ( a -- b ) { [ a ed's-bug ] } && ; -[ t ] [ \ ed's-test-case optimized>> ] unit-test +[ t ] [ \ ed's-test-case optimized? ] unit-test diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index 100088f174..daeecc3ad5 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -79,7 +79,7 @@ M: quotation cached-effect [ '[ _ execute ] ] dip call-effect-slow ; inline : 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 -- ) 2over execute-effect-unsafe? diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c79bcde518..0bbaa32c25 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -676,4 +676,6 @@ M: object infer-call* \ reset-dispatch-stats { } { } define-primitive \ dispatch-stats { } { array } define-primitive \ reset-inline-cache-stats { } { } define-primitive -\ inline-cache-stats { } { array } define-primitive \ No newline at end of file +\ inline-cache-stats { } { array } define-primitive + +\ optimized? { word } { object } define-primitive \ No newline at end of file diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor index 6dabb73e30..c8ab2512f6 100644 --- a/basis/tools/walker/walker-tests.factor +++ b/basis/tools/walker/walker-tests.factor @@ -118,7 +118,7 @@ IN: tools.walker.tests \ 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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 41242e3c39..a3b4a91aeb 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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. USING: alien arrays byte-arrays generic hashtables hashtables.private io kernel math math.private math.order @@ -259,7 +259,7 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "optimized" read-only } + { "direct-entry-def" } { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin @@ -539,6 +539,7 @@ tuple { "dispatch-stats" "generic.single" (( -- stats )) } { "reset-inline-cache-stats" "generic.single" (( -- )) } { "inline-cache-stats" "generic.single" (( -- stats )) } + { "optimized?" "words" (( word -- ? )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index dd5fa06031..aae6618ee8 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -16,12 +16,12 @@ IN: combinators.tests : 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 : 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 [ 5 ] [ 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 ) ; -[ 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 [ 7 ] [ 1 3 2 [ * + ] curry 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 >> -[ t ] [ \ corner-case-1 optimized>> ] unit-test +[ t ] [ \ corner-case-1 optimized? ] unit-test [ 4 ] [ 2 corner-case-1 ] unit-test [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test diff --git a/vm/arrays.c b/vm/arrays.c new file mode 100644 index 0000000000..3f0de35262 --- /dev/null +++ b/vm/arrays.c @@ -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; +} diff --git a/vm/arrays.h b/vm/arrays.h new file mode 100644 index 0000000000..4d773922b4 --- /dev/null +++ b/vm/arrays.h @@ -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; diff --git a/vm/booleans.c b/vm/booleans.c new file mode 100644 index 0000000000..113265873f --- /dev/null +++ b/vm/booleans.c @@ -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; +} diff --git a/vm/booleans.h b/vm/booleans.h new file mode 100644 index 0000000000..ae49652dd8 --- /dev/null +++ b/vm/booleans.h @@ -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); diff --git a/vm/byte_arrays.c b/vm/byte_arrays.c new file mode 100644 index 0000000000..42fd5ba274 --- /dev/null +++ b/vm/byte_arrays.c @@ -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; +} diff --git a/vm/byte_arrays.h b/vm/byte_arrays.h new file mode 100644 index 0000000000..65c9731047 --- /dev/null +++ b/vm/byte_arrays.h @@ -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)); +} diff --git a/vm/callstack.h b/vm/callstack.h index 3c13e7b1cd..8b693c451c 100755 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -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); #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) diff --git a/vm/code_heap.c b/vm/code_heap.c index 0c63abfbe0..f75fcb1ec5 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -12,15 +12,6 @@ bool in_code_heap_p(CELL ptr) && 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 */ 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); word->code = untag_quotation(def)->code; - word->optimizedp = F; } /* Apply a function to every code block */ @@ -115,7 +105,7 @@ void primitive_modify_code_heap(void) UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); - set_word_code(word,compiled); + word->code = compiled; } else critical_error("Expected a quotation or an array",data); diff --git a/vm/code_heap.h b/vm/code_heap.h index 4c5aafcddd..c0d44e8558 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -7,8 +7,6 @@ bool in_code_heap_p(CELL ptr); 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); void iterate_code_heap(CODE_HEAP_ITERATOR iter); diff --git a/vm/layouts.h b/vm/layouts.h index 266d790f2a..27bbe5b137 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -155,9 +155,8 @@ typedef struct { CELL def; /* TAGGED property assoc for library code */ CELL props; - /* TAGGED t or f, t means its compiled with the optimizing compiler, - f means its compiled with the non-optimizing compiler */ - CELL optimizedp; + /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ + CELL direct_entry_def; /* TAGGED call count for profiling */ CELL counter; /* TAGGED machine code for sub-primitive */ diff --git a/vm/master.h b/vm/master.h index c6f2c0a090..83c2d39c0f 100644 --- a/vm/master.h +++ b/vm/master.h @@ -34,7 +34,12 @@ #include "data_gc.h" #include "local_roots.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 "float_bits.h" #include "io.h" diff --git a/vm/primitives.c b/vm/primitives.c index 9159ebd48f..3e9a829a2e 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -151,4 +151,5 @@ void *primitives[] = { primitive_dispatch_stats, primitive_reset_inline_cache_stats, primitive_inline_cache_stats, + primitive_optimized_p, }; diff --git a/vm/profiler.c b/vm/profiler.c index 7952a6b6f5..5578854d6d 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -1,7 +1,7 @@ #include "master.h" /* Allocates memory */ -static F_CODE_BLOCK *compile_profiling_stub(CELL word) +F_CODE_BLOCK *compile_profiling_stub(CELL word) { REGISTER_ROOT(word); F_JIT jit; @@ -13,25 +13,6 @@ static F_CODE_BLOCK *compile_profiling_stub(CELL word) 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 */ static void set_profiling(bool profiling) { diff --git a/vm/profiler.h b/vm/profiler.h index 481f75e966..40daab429c 100755 --- a/vm/profiler.h +++ b/vm/profiler.h @@ -1,3 +1,3 @@ bool profiling_p; +F_CODE_BLOCK *compile_profiling_stub(CELL word); void primitive_profiling(void); -void update_word_xt(F_WORD *word); diff --git a/vm/quotations.c b/vm/quotations.c index 6860e3acba..4b5eb0dd2c 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -461,7 +461,7 @@ void compile_all_words(void) F_WORD *word = untag_word(array_nth(untag_array(words),i)); REGISTER_UNTAGGED(word); - if(word->optimizedp == F) + if(!word->code || !word_optimized_p(word)) jit_compile_word(word,word->def,false); UNREGISTER_UNTAGGED(word); diff --git a/vm/quotations.h b/vm/quotations.h index d571a90ed6..6fcd894b05 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,3 +1,5 @@ +DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) + void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); diff --git a/vm/run.c b/vm/run.c index e55eb904a7..7dc2474113 100755 --- a/vm/run.c +++ b/vm/run.c @@ -224,3 +224,25 @@ void primitive_load_locals(void) ds -= 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())); +} diff --git a/vm/run.h b/vm/run.h index 2e15365dbd..9a827d00ef 100755 --- a/vm/run.h +++ b/vm/run.h @@ -262,14 +262,10 @@ void primitive_check_datastack(void); void primitive_getenv(void); void primitive_setenv(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_sleep(void); void primitive_set_slot(void); void primitive_load_locals(void); +void primitive_clone(void); bool stage2; diff --git a/vm/strings.c b/vm/strings.c new file mode 100644 index 0000000000..03414077b9 --- /dev/null +++ b/vm/strings.c @@ -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); +} diff --git a/vm/strings.h b/vm/strings.h new file mode 100644 index 0000000000..d16a85ebea --- /dev/null +++ b/vm/strings.h @@ -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); diff --git a/vm/tuples.c b/vm/tuples.c new file mode 100644 index 0000000000..0ad7557179 --- /dev/null +++ b/vm/tuples.c @@ -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)); +} diff --git a/vm/tuples.h b/vm/tuples.h new file mode 100644 index 0000000000..64b62e2539 --- /dev/null +++ b/vm/tuples.h @@ -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); diff --git a/vm/types.c b/vm/types.c deleted file mode 100755 index b5981dc3b1..0000000000 --- a/vm/types.c +++ /dev/null @@ -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; -} - -/* ( 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); -} diff --git a/vm/types.h b/vm/types.h deleted file mode 100755 index f881261dce..0000000000 --- a/vm/types.h +++ /dev/null @@ -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)); -} diff --git a/vm/words.c b/vm/words.c new file mode 100644 index 0000000000..615c11e5af --- /dev/null +++ b/vm/words.c @@ -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; +} + +/* ( 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)); +} diff --git a/vm/words.h b/vm/words.h new file mode 100644 index 0000000000..aa86c87ae1 --- /dev/null +++ b/vm/words.h @@ -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);