From 43a19be01f5a5bc205120fc666864e11ff3b3d9e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 14 May 2005 00:37:28 +0000 Subject: [PATCH] updated %set-slot, %set-fast-slot and new %getenv %setenv intrinsics --- TODO.FACTOR.txt | 1 + library/alien/compiler.factor | 28 +++++++++++++++++ library/compiler/intrinsics.factor | 50 ++++++++++++++++++++---------- library/compiler/relocate.factor | 7 +++-- library/compiler/vops.factor | 11 +++++++ library/compiler/x86/alien.factor | 8 +++-- library/compiler/x86/slots.factor | 44 ++++++++++++++++---------- native/factor.c | 4 ++- native/run.h | 4 ++- 9 files changed, 118 insertions(+), 39 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 8b20f0e728..f35bff470c 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -6,6 +6,7 @@ http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup +- alien-global type wrong - simplifier: - dead loads not optimized out - kill tag-fixnum/untag-fixnum diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index e7a1f83a5e..61fdd29447 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -125,6 +125,34 @@ SYMBOL: alien-parameters \ alien-invoke [ infer-alien-invoke ] "infer" set-word-prop +: alien-global ( type library name -- value ) + #! Fetch the value of C global variable. + #! 'type' is a type spec. 'library' is an entry in the + #! "libraries" namespace. + throw ; + +: alien-global-node ( type name library -- ) + 2dup ensure-dlsym + cons \ alien-global dataflow, + set-alien-returns ; + +: infer-alien-global ( -- ) + \ alien-global "infer-effect" word-prop car ensure-d + pop-literal + pop-literal + pop-literal -rot + alien-global-node ; + +: linearize-alien-global ( node -- ) + dup [ node-param get ] bind %alien-global , + linearize-returns ; + +\ alien-global [ linearize-alien-global ] "linearizer" set-word-prop + +\ alien-global [ [ string string string ] [ object ] ] "infer-effect" set-word-prop + +\ alien-global [ infer-alien-global ] "infer" set-word-prop + global [ "libraries" get [ "libraries" set ] unless ] bind diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index 796c7b10b6..8bb1478e4c 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -109,22 +109,22 @@ sequences words ; ] ifte out-1 ] "linearizer" set-word-prop -! \ set-slot intrinsic -! -! \ set-slot [ -! dup typed-literal? [ -! 1 %dec-d , -! in-2 -! 2 %dec-d , -! slot@ >r 0 1 r> %fast-set-slot , -! ] [ -! drop -! in-3 -! 3 %dec-d , -! 1 %untag , -! 0 1 2 %set-slot , -! ] ifte -! ] "linearizer" set-word-prop +\ set-slot intrinsic + +\ set-slot [ + dup typed-literal? [ + 1 %dec-d , + in-2 + 2 %dec-d , + slot@ >r 0 1 r> %fast-set-slot , + ] [ + drop + in-3 + 3 %dec-d , + 1 %untag , + 0 1 2 %set-slot , + ] ifte +] "linearizer" set-word-prop \ type intrinsic @@ -147,6 +147,24 @@ sequences words ; out-1 ] "linearizer" set-word-prop +\ getenv intrinsic + +\ getenv [ + 1 %dec-d , + node-peek literal-value 0 swap %getenv , + 1 %inc-d , + out-1 +] "linearizer" set-word-prop + +\ setenv intrinsic + +\ setenv [ + 1 %dec-d , + in-1 + node-peek literal-value 0 swap %setenv , + 1 %dec-d , +] "linearizer" set-word-prop + : binary-op-reg ( op out -- ) >r in-2 1 %dec-d , diff --git a/library/compiler/relocate.factor b/library/compiler/relocate.factor index b40ae446d4..0c60384eb5 100644 --- a/library/compiler/relocate.factor +++ b/library/compiler/relocate.factor @@ -26,5 +26,8 @@ SYMBOL: relocation-table over [ 2drop ] [ 2 rel-type, relocating 0 rel, ] ifte ; : rel-word ( word rel/abs 16/16 -- ) - #! If flag is true; relative. - over primitive? [ rel-primitive ] [ nip rel-address ] ifte ; + pick primitive? [ + rel-primitive + ] [ + rot drop rel-address + ] ifte ; diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor index 8e9a75cf84..fb26e2f0b4 100644 --- a/library/compiler/vops.factor +++ b/library/compiler/vops.factor @@ -43,6 +43,8 @@ M: vop calls-label? vop-label = ; : dest-vop ( dest) f swap f f ; : src/dest-vop ( src dest) f f ; : literal-vop ( literal) >r f f r> f ; +: src/literal-vop ( src literal) f swap f ; +: dest/literal-vop ( dest literal) >r f swap r> f ; ! miscellanea VOP: %prologue @@ -201,6 +203,12 @@ VOP: %untag-fixnum : check-dest ( vop reg -- ) swap vop-dest = [ "invalid VOP destination" throw ] unless ; +VOP: %getenv +: %getenv dest/literal-vop <%getenv> ; + +VOP: %setenv +: %setenv src/literal-vop <%setenv> ; + ! alien operations VOP: %parameters : %parameters ( n -- vop ) literal-vop <%parameters> ; @@ -231,3 +239,6 @@ VOP: %box-double VOP: %alien-invoke : %alien-invoke ( func -- vop ) literal-vop <%alien-invoke> ; + +VOP: %alien-global +: %alien-global ( global -- vop ) literal-vop <%alien-global> ; diff --git a/library/compiler/x86/alien.factor b/library/compiler/x86/alien.factor index 6c6d08db3a..6b44e27baf 100644 --- a/library/compiler/x86/alien.factor +++ b/library/compiler/x86/alien.factor @@ -1,13 +1,17 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: compiler-backend -USING: alien assembler inference kernel kernel-internals lists -math memory namespaces words ; +USING: alien assembler compiler inference kernel +kernel-internals lists math memory namespaces words ; M: %alien-invoke generate-node #! call a C function. vop-literal uncons load-library compile-c-call ; +M: %alien-global generate-node + vop-literal uncons load-library + 2dup dlsym EAX swap unit MOV 0 0 rel-dlsym ; + M: %parameters generate-node #! x86 does not pass parameters in registers drop ; diff --git a/library/compiler/x86/slots.factor b/library/compiler/x86/slots.factor index c0dc555bfd..7cb4b5a6e7 100644 --- a/library/compiler/x86/slots.factor +++ b/library/compiler/x86/slots.factor @@ -22,18 +22,17 @@ M: %fast-slot generate-node ( vop -- ) dup vop-literal swap vop-dest v>operand tuck >r 2list r> swap MOV ; -! : card-bits 5 ; -! -! : card-offset ( -- n ) -! #! We add this to an address that was shifted by card-bits -! #! to get the address of its card. -! -! ; -! -! : write-barrier ( vreg -- ) -! #! Mark the card pointed to by vreg. -! -! ; +: card-bits + #! must be the same as CARD_BITS in native/cards.h. + 7 ; + +: card-offset 1 getenv ; +: card-mark HEX: 80 ; + +: write-barrier ( reg -- ) + #! Mark the card pointed to by vreg. + dup card-bits SHR + card-offset 2list card-mark OR ; M: %set-slot generate-node ( vop -- ) #! the untagged object is in vop-dest, the new value is in @@ -41,15 +40,26 @@ M: %set-slot generate-node ( vop -- ) dup vop-literal v>operand over vop-dest v>operand ! turn tagged fixnum slot # into an offset, multiple of 4 over 1 SHR - ! compute slot address in vop-dest - dupd ADD + ! compute slot address in vop-literal + 2dup ADD ! store new slot value - >r vop-source v>operand r> unit swap MOV ; + >r >r vop-source v>operand r> unit swap MOV r> + write-barrier ; M: %fast-set-slot generate-node ( vop -- ) #! the tagged object is in vop-dest, the new value is in #! vop-source, the pointer offset is in vop-literal. the #! offset already takes the type tag into account, so its #! just one instruction to load. - dup vop-literal over vop-dest v>operand swap 2list - swap vop-source v>operand MOV ; + dup vop-literal over vop-dest v>operand + [ swap 2list swap vop-source v>operand MOV ] keep + write-barrier ; + +: userenv@ ( n -- addr ) + cell * "userenv" f dlsym + ; + +M: %getenv generate-node ( vop -- ) + dup vop-dest v>operand swap vop-literal userenv@ unit MOV ; + +M: %setenv generate-node ( vop -- ) + dup vop-literal userenv@ unit swap vop-source v>operand MOV ; diff --git a/native/factor.c b/native/factor.c index 1c7f43e3e2..0ea1881cea 100644 --- a/native/factor.c +++ b/native/factor.c @@ -4,7 +4,8 @@ void init_factor(char* image, CELL ds_size, CELL cs_size, CELL young_size, CELL aging_size, CELL code_size, CELL literal_size) { - srand((unsigned)time(NULL)); /* initialize random number generator */ + /* initialize random number generator */ + srand((unsigned)time(NULL)); init_ffi(); init_arena(young_size,aging_size); init_compiler(code_size); @@ -16,6 +17,7 @@ void init_factor(char* image, CELL ds_size, CELL cs_size, userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING)); userenv[OS_ENV] = tag_object(from_c_string(FACTOR_OS_STRING)); userenv[GEN_ENV] = tag_fixnum(GC_GENERATIONS); + userenv[CARD_OFF_ENV] = tag_cell((CELL)cards - (heap_start >> CARD_BITS)); } INLINE bool factor_arg(const char* str, const char* arg, CELL* value) diff --git a/native/run.h b/native/run.h index c9fb435c40..1ed07206ba 100644 --- a/native/run.h +++ b/native/run.h @@ -1,5 +1,7 @@ #define USER_ENV 16 +#define CARD_OFF_ENV 1 /* for compiling set-slot */ +#define UNUSED_ENV 2 #define NAMESTACK_ENV 3 /* used by library only */ #define GLOBAL_ENV 4 #define BREAK_ENV 5 @@ -15,7 +17,7 @@ #define GEN_ENV 15 /* set to GC_GENERATIONS constant */ /* TAGGED user environment data; see getenv/setenv prims */ -CELL userenv[USER_ENV]; +DLLEXPORT CELL userenv[USER_ENV]; /* Profiling timer */ #ifndef WIN32