updated %set-slot, %set-fast-slot and new %getenv %setenv intrinsics
Slava Pestov
parent
3b5855a195
commit
43a19be01f
|
|
@ -6,6 +6,7 @@
|
|||
<magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html
|
||||
<magnus--> 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ,
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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> ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue