updated %set-slot, %set-fast-slot and new %getenv %setenv intrinsics

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 8b20f0e728edb8ca2f2d1cdee8ff865186703a96..f35bff470ca130cbd6da5e59068c95ea90db2bc4 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -6,6 +6,7 @@
 <magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html\r
 <magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup\r
 \r
+- alien-global type wrong\r
 - simplifier:\r
   - dead loads not optimized out\r
   - kill tag-fixnum/untag-fixnum\r

diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor
index e7a1f83a5ee349f790f4ca72f2ebd4b26eb69387..61fdd2944756b68fdbcaf431de14a648b6b8d0e2 100644 (file)
--- 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.
+    <alien-error> 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 [ <namespace> "libraries" set ] unless
 ] bind

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 796c7b10b632867d3d74c22a8eb5b65cef2b92e4..8bb1478e4cc4d40ccb10f2438a9194a6bc93b197 100644 (file)
--- 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 <vreg> swap %getenv ,
+    1 %inc-d ,
+    out-1
+] "linearizer" set-word-prop
+
+\ setenv intrinsic
+
+\ setenv [
+    1 %dec-d ,
+    in-1
+    node-peek literal-value 0 <vreg> 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 b40ae446d4670a4fd9273df709175cc11d8e55b8..0c60384eb5bac1ea22b3acb19d1264026da9b172 100644 (file)
--- 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 8e9a75cf849e005df03fe7e15a5576731044a6d7..fb26e2f0b497bce416a0d0fad0cd10b0cd67947d 100644 (file)
--- 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 6c6d08db3a0230f43ea70288a9de7299deb6dd3c..6b44e27baf28dbd5cd5c7190c238ed48393a534a 100644 (file)
--- 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 c0dc555bfd60e30185cadd6bf670a4c7b5190a26..7cb4b5a6e75a24e00b12de8b59ecffc00e670e6b 100644 (file)
--- 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 1c7f43e3e21ea361d24ed3590351d0ea8ef6c7b7..0ea1881cea1c52e13e7a5327a2fea24c9a3e5667 100644 (file)
--- 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 c9fb435c400bf814915595bb6183496f320b2658..1ed07206ba7e42d0eebb2cc403cb94bc5022b26d 100644 (file)
--- 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