Merge branch 'master' of factorcode.org:/git/factor
commit
d3767a7f27
|
@ -129,8 +129,8 @@ SYMBOL: jit-literals
|
|||
: jit-vm ( offset rc -- )
|
||||
[ jit-parameter ] dip rt-vm jit-rel ;
|
||||
|
||||
: jit-dlsym ( name library rc -- )
|
||||
rt-dlsym jit-rel [ string>symbol jit-parameter ] bi@ ;
|
||||
: jit-dlsym ( name rc -- )
|
||||
rt-dlsym jit-rel string>symbol jit-parameter f jit-parameter ;
|
||||
|
||||
:: jit-conditional ( test-quot false-quot -- )
|
||||
[ 0 test-quot call ] B{ } make length :> len
|
||||
|
|
|
@ -43,14 +43,16 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
|
|||
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
|
||||
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
|
||||
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
|
||||
{ { $snippet "-callstack=" { $emphasis "n" } } "Call stack size, kilobytes" }
|
||||
{ { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
|
||||
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
|
||||
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
|
||||
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
|
||||
{ { $snippet "-callbacks=" { $emphasis "n" } } "Callback heap size, megabytes" }
|
||||
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
|
||||
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
|
||||
}
|
||||
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
|
||||
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the Factor executable." ;
|
||||
|
||||
ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
|
||||
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"
|
||||
|
|
|
@ -1,17 +1,17 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces make math sequences layouts
|
||||
alien.c-types cpu.architecture ;
|
||||
IN: compiler.alien
|
||||
|
||||
: large-struct? ( ctype -- ? )
|
||||
: large-struct? ( type -- ? )
|
||||
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
|
||||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ void* prefix ] when ;
|
||||
|
||||
: alien-return ( params -- ctype )
|
||||
: alien-return ( params -- type )
|
||||
return>> dup large-struct? [ drop void ] when ;
|
||||
|
||||
: c-type-stack-align ( type -- align )
|
||||
|
|
|
@ -458,7 +458,7 @@ M: ##alien-indirect generate-insn
|
|||
! Generate code for boxing input parameters in a callback.
|
||||
[
|
||||
dup \ %save-param-reg move-parameters
|
||||
%nest-stacks
|
||||
%begin-callback
|
||||
box-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
|
@ -482,5 +482,4 @@ M: ##alien-callback generate-insn
|
|||
params>>
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot %alien-callback ]
|
||||
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
|
||||
tri ;
|
||||
[ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
|
||||
|
|
|
@ -28,10 +28,12 @@ CONSTANT: deck-bits 18
|
|||
: callstack-length-offset ( -- n ) 1 \ callstack type-number slot-offset ; inline
|
||||
: callstack-top-offset ( -- n ) 2 \ callstack type-number slot-offset ; inline
|
||||
: vm-context-offset ( -- n ) 0 bootstrap-cells ; inline
|
||||
: vm-spare-context-offset ( -- n ) 1 bootstrap-cells ; inline
|
||||
: context-callstack-top-offset ( -- n ) 0 bootstrap-cells ; inline
|
||||
: context-callstack-bottom-offset ( -- n ) 1 bootstrap-cells ; inline
|
||||
: context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
|
||||
: context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
|
||||
: context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
CONSTANT: rc-absolute-cell 0
|
||||
|
|
|
@ -4,7 +4,7 @@ compiler continuations effects io io.backend io.pathnames
|
|||
io.streams.string kernel math memory namespaces
|
||||
namespaces.private parser quotations sequences
|
||||
specialized-arrays stack-checker stack-checker.errors
|
||||
system threads tools.test words alien.complex ;
|
||||
system threads tools.test words alien.complex concurrency.promises ;
|
||||
FROM: alien.c-types => float short ;
|
||||
SPECIALIZED-ARRAY: float
|
||||
SPECIALIZED-ARRAY: char
|
||||
|
@ -579,6 +579,21 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
|||
|
||||
] unless
|
||||
|
||||
! Test interaction between threads and callbacks
|
||||
: thread-callback-1 ( -- callback )
|
||||
int { } "cdecl" [ yield 100 ] alien-callback ;
|
||||
|
||||
: thread-callback-2 ( -- callback )
|
||||
int { } "cdecl" [ yield 200 ] alien-callback ;
|
||||
|
||||
: thread-callback-invoker ( callback -- n )
|
||||
int { } "cdecl" alien-indirect ;
|
||||
|
||||
<promise> "p" set
|
||||
[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
|
||||
[ 200 ] [ thread-callback-2 thread-callback-invoker ] unit-test
|
||||
[ 100 ] [ "p" get ?promise ] unit-test
|
||||
|
||||
! Regression: calling an undefined function would raise a protection fault
|
||||
FUNCTION: void this_does_not_exist ( ) ;
|
||||
|
||||
|
|
|
@ -467,6 +467,12 @@ TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
|
|||
[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
|
||||
unit-test
|
||||
|
||||
TUPLE: don't-fold-boa-test-tuple < identity-tuple ;
|
||||
|
||||
[ V{ f } ]
|
||||
[ [ don't-fold-boa-test-tuple boa ] final-literals ]
|
||||
unit-test
|
||||
|
||||
TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
||||
|
||||
[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [
|
||||
|
|
|
@ -34,17 +34,18 @@ IN: compiler.tree.propagation.slots
|
|||
[ read-only>> [ value-info ] [ drop f ] if ] 2map
|
||||
f prefix ;
|
||||
|
||||
: (propagate-tuple-constructor) ( values class -- info )
|
||||
[ read-only-slots ] keep
|
||||
over rest-slice [ dup [ literal?>> ] when ] all? [
|
||||
[ rest-slice ] dip fold-<tuple-boa>
|
||||
] [
|
||||
<tuple-info>
|
||||
] if ;
|
||||
: fold-<tuple-boa>? ( values class -- ? )
|
||||
[ rest-slice [ dup [ literal?>> ] when ] all? ]
|
||||
[ identity-tuple class<= not ]
|
||||
bi* and ;
|
||||
|
||||
: (propagate-<tuple-boa>) ( values class -- info )
|
||||
[ read-only-slots ] keep 2dup fold-<tuple-boa>?
|
||||
[ [ rest-slice ] dip fold-<tuple-boa> ] [ <tuple-info> ] if ;
|
||||
|
||||
: propagate-<tuple-boa> ( #call -- infos )
|
||||
in-d>> unclip-last
|
||||
value-info literal>> first (propagate-tuple-constructor) 1array ;
|
||||
value-info literal>> first (propagate-<tuple-boa>) 1array ;
|
||||
|
||||
: read-only-slot? ( n class -- ? )
|
||||
all-slots [ offset>> = ] with find nip
|
||||
|
|
|
@ -582,13 +582,13 @@ HOOK: %prepare-alien-indirect cpu ( -- )
|
|||
|
||||
HOOK: %alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %begin-callback cpu ( -- )
|
||||
|
||||
HOOK: %alien-callback cpu ( quot -- )
|
||||
|
||||
HOOK: %callback-value cpu ( ctype -- )
|
||||
HOOK: %end-callback cpu ( -- )
|
||||
|
||||
HOOK: %nest-stacks cpu ( -- )
|
||||
|
||||
HOOK: %unnest-stacks cpu ( -- )
|
||||
HOOK: %end-callback-value cpu ( c-type -- )
|
||||
|
||||
HOOK: callback-return-rewind cpu ( params -- n )
|
||||
|
||||
|
|
|
@ -267,7 +267,7 @@ CONSTANT: ctx-reg 16
|
|||
jit-save-context
|
||||
3 6 MR
|
||||
4 vm-reg MR
|
||||
0 5 LOAD32 "inline_cache_miss" f rc-absolute-ppc-2/2 jit-dlsym
|
||||
0 5 LOAD32 "inline_cache_miss" rc-absolute-ppc-2/2 jit-dlsym
|
||||
5 MTLR
|
||||
BLRL
|
||||
jit-restore-context ;
|
||||
|
@ -392,7 +392,7 @@ CONSTANT: ctx-reg 16
|
|||
1 3 MR
|
||||
! Call memcpy; arguments are now in the correct registers
|
||||
1 1 -64 STWU
|
||||
0 2 LOAD32 "factor_memcpy" f rc-absolute-ppc-2/2 jit-dlsym
|
||||
0 2 LOAD32 "factor_memcpy" rc-absolute-ppc-2/2 jit-dlsym
|
||||
2 MTLR
|
||||
BLRL
|
||||
1 1 0 LWZ
|
||||
|
@ -405,7 +405,7 @@ CONSTANT: ctx-reg 16
|
|||
[
|
||||
jit-save-context
|
||||
4 vm-reg MR
|
||||
0 2 LOAD32 "lazy_jit_compile" f rc-absolute-ppc-2/2 jit-dlsym
|
||||
0 2 LOAD32 "lazy_jit_compile" rc-absolute-ppc-2/2 jit-dlsym
|
||||
2 MTLR
|
||||
BLRL
|
||||
5 3 quot-entry-point-offset LWZ
|
||||
|
@ -665,7 +665,7 @@ CONSTANT: ctx-reg 16
|
|||
[ BNO ]
|
||||
[
|
||||
5 vm-reg MR
|
||||
0 6 LOAD32 func f rc-absolute-ppc-2/2 jit-dlsym
|
||||
0 6 LOAD32 func rc-absolute-ppc-2/2 jit-dlsym
|
||||
6 MTLR
|
||||
BLRL
|
||||
]
|
||||
|
@ -689,7 +689,7 @@ CONSTANT: ctx-reg 16
|
|||
[
|
||||
4 4 tag-bits get SRAWI
|
||||
5 vm-reg MR
|
||||
0 6 LOAD32 "overflow_fixnum_multiply" f rc-absolute-ppc-2/2 jit-dlsym
|
||||
0 6 LOAD32 "overflow_fixnum_multiply" rc-absolute-ppc-2/2 jit-dlsym
|
||||
6 MTLR
|
||||
BLRL
|
||||
]
|
||||
|
|
|
@ -716,7 +716,7 @@ M: ppc %callback-value ( ctype -- )
|
|||
3 1 0 local@ STW
|
||||
3 %load-vm-addr
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
"unnest_context" f %alien-invoke
|
||||
! Restore top of data stack
|
||||
3 1 0 local@ LWZ
|
||||
! Unbox former top of data stack to return registers
|
||||
|
@ -757,13 +757,13 @@ M: ppc %box-small-struct ( c-type -- )
|
|||
4 3 4 LWZ
|
||||
3 3 0 LWZ ;
|
||||
|
||||
M: ppc %nest-stacks ( -- )
|
||||
M: ppc %nest-context ( -- )
|
||||
3 %load-vm-addr
|
||||
"nest_stacks" f %alien-invoke ;
|
||||
"nest_context" f %alien-invoke ;
|
||||
|
||||
M: ppc %unnest-stacks ( -- )
|
||||
M: ppc %unnest-context ( -- )
|
||||
3 %load-vm-addr
|
||||
"unnest_stacks" f %alien-invoke ;
|
||||
"unnest_context" f %alien-invoke ;
|
||||
|
||||
M: ppc %unbox-small-struct ( size -- )
|
||||
heap-size cell align cell /i {
|
||||
|
|
|
@ -228,14 +228,6 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
|
|||
0 stack@ EAX MOV
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %nest-stacks ( -- )
|
||||
0 save-vm-ptr
|
||||
"nest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %unnest-stacks ( -- )
|
||||
0 save-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
EAX ds-reg [] MOV
|
||||
ds-reg 4 SUB
|
||||
|
@ -247,18 +239,24 @@ M: x86.32 %prepare-alien-indirect ( -- )
|
|||
M: x86.32 %alien-indirect ( -- )
|
||||
EBP CALL ;
|
||||
|
||||
M: x86.32 %begin-callback ( -- )
|
||||
0 save-vm-ptr
|
||||
"begin_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
EAX EDX %restore-context
|
||||
EAX swap %load-reference
|
||||
EAX quot-entry-point-offset [+] CALL
|
||||
EAX EDX %save-context ;
|
||||
|
||||
M: x86.32 %callback-value ( ctype -- )
|
||||
M: x86.32 %end-callback ( -- )
|
||||
0 save-vm-ptr
|
||||
"end_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %end-callback-value ( ctype -- )
|
||||
%pop-context-stack
|
||||
4 stack@ EAX MOV
|
||||
0 save-vm-ptr
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
%end-callback
|
||||
! Place former top of data stack back in EAX
|
||||
EAX 4 stack@ MOV
|
||||
! Unbox EAX
|
||||
|
|
|
@ -16,17 +16,20 @@ IN: bootstrap.x86
|
|||
: temp1 ( -- reg ) EDX ;
|
||||
: temp2 ( -- reg ) ECX ;
|
||||
: temp3 ( -- reg ) EBX ;
|
||||
: safe-reg ( -- reg ) EAX ;
|
||||
: stack-reg ( -- reg ) ESP ;
|
||||
: frame-reg ( -- reg ) EBP ;
|
||||
: vm-reg ( -- reg ) ECX ;
|
||||
: ctx-reg ( -- reg ) EBP ;
|
||||
: nv-regs ( -- seq ) { ESI EDI EBX } ;
|
||||
: nv-reg ( -- reg ) nv-regs first ;
|
||||
: ds-reg ( -- reg ) ESI ;
|
||||
: rs-reg ( -- reg ) EDI ;
|
||||
: fixnum>slot@ ( -- ) temp0 2 SAR ;
|
||||
: rex-length ( -- n ) 0 ;
|
||||
|
||||
: jit-call ( name -- )
|
||||
0 CALL rc-relative jit-dlsym ;
|
||||
|
||||
[
|
||||
! save stack frame size
|
||||
stack-frame-size PUSH
|
||||
|
@ -49,7 +52,7 @@ IN: bootstrap.x86
|
|||
ctx-reg vm-reg vm-context-offset [+] MOV ;
|
||||
|
||||
: jit-save-context ( -- )
|
||||
EDX RSP -4 [+] LEA
|
||||
EDX ESP -4 [+] LEA
|
||||
ctx-reg context-callstack-top-offset [+] EDX MOV
|
||||
ctx-reg context-datastack-offset [+] ds-reg MOV
|
||||
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
|
||||
|
@ -70,18 +73,37 @@ IN: bootstrap.x86
|
|||
] jit-primitive jit-define
|
||||
|
||||
[
|
||||
! Load quotation
|
||||
jit-load-vm
|
||||
ESP [] vm-reg MOV
|
||||
"begin_callback" jit-call
|
||||
|
||||
! load quotation - EBP is ctx-reg so it will get clobbered
|
||||
! later on
|
||||
EAX EBP 8 [+] MOV
|
||||
! save ctx->callstack_bottom, load ds, rs registers
|
||||
|
||||
jit-load-vm
|
||||
jit-load-context
|
||||
jit-restore-context
|
||||
EDX stack-reg stack-frame-size 4 - [+] LEA
|
||||
ctx-reg context-callstack-bottom-offset [+] EDX MOV
|
||||
|
||||
! save C callstack pointer
|
||||
ctx-reg context-callstack-save-offset [+] ESP MOV
|
||||
|
||||
! load Factor callstack pointer
|
||||
ESP ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
ESP 4 ADD
|
||||
|
||||
! call the quotation
|
||||
EAX quot-entry-point-offset [+] CALL
|
||||
! save ds, rs registers
|
||||
|
||||
jit-load-vm
|
||||
jit-load-context
|
||||
jit-save-context
|
||||
|
||||
! load C callstack pointer
|
||||
ESP ctx-reg context-callstack-save-offset [+] MOV
|
||||
|
||||
ESP [] vm-reg MOV
|
||||
"end_callback" jit-call
|
||||
] \ c-to-factor define-sub-primitive
|
||||
|
||||
[
|
||||
|
@ -137,7 +159,7 @@ IN: bootstrap.x86
|
|||
EDX PUSH
|
||||
EBP PUSH
|
||||
EAX PUSH
|
||||
0 CALL "factor_memcpy" f rc-relative jit-dlsym
|
||||
"factor_memcpy" jit-call
|
||||
ESP 12 ADD
|
||||
! Return with new callstack
|
||||
0 RET
|
||||
|
@ -153,7 +175,7 @@ IN: bootstrap.x86
|
|||
ESP 4 [+] vm-reg MOV
|
||||
|
||||
! Call VM
|
||||
0 CALL "lazy_jit_compile" f rc-relative jit-dlsym
|
||||
"lazy_jit_compile" jit-call
|
||||
]
|
||||
[ EAX quot-entry-point-offset [+] CALL ]
|
||||
[ EAX quot-entry-point-offset [+] JMP ]
|
||||
|
@ -171,7 +193,7 @@ IN: bootstrap.x86
|
|||
jit-save-context
|
||||
ESP 4 [+] vm-reg MOV
|
||||
ESP [] EBX MOV
|
||||
0 CALL "inline_cache_miss" f rc-relative jit-dlsym
|
||||
"inline_cache_miss" jit-call
|
||||
jit-restore-context ;
|
||||
|
||||
[ jit-load-return-address jit-inline-cache-miss ]
|
||||
|
@ -200,7 +222,7 @@ IN: bootstrap.x86
|
|||
ESP [] EAX MOV
|
||||
ESP 4 [+] EDX MOV
|
||||
ESP 8 [+] vm-reg MOV
|
||||
[ 0 CALL ] dip f rc-relative jit-dlsym
|
||||
jit-call
|
||||
]
|
||||
jit-conditional ;
|
||||
|
||||
|
@ -225,7 +247,7 @@ IN: bootstrap.x86
|
|||
ESP [] EBX MOV
|
||||
ESP 4 [+] EBP MOV
|
||||
ESP 8 [+] vm-reg MOV
|
||||
0 CALL "overflow_fixnum_multiply" f rc-relative jit-dlsym
|
||||
"overflow_fixnum_multiply" jit-call
|
||||
]
|
||||
jit-conditional
|
||||
] \ fixnum* define-sub-primitive
|
||||
|
|
|
@ -38,6 +38,7 @@ M: x86.64 machine-registers
|
|||
} ;
|
||||
|
||||
: vm-reg ( -- reg ) R13 ; inline
|
||||
: nv-reg ( -- reg ) RBX ; inline
|
||||
|
||||
M: x86.64 %mov-vm-ptr ( reg -- )
|
||||
vm-reg MOV ;
|
||||
|
@ -215,23 +216,19 @@ M: x86.64 %alien-invoke
|
|||
rc-absolute-cell rel-dlsym
|
||||
R11 CALL ;
|
||||
|
||||
M: x86.64 %nest-stacks ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
"nest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %unnest-stacks ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %prepare-alien-indirect ( -- )
|
||||
param-reg-0 ds-reg [] MOV
|
||||
ds-reg 8 SUB
|
||||
param-reg-1 %mov-vm-ptr
|
||||
"pinned_alien_offset" f %alien-invoke
|
||||
RBP RAX MOV ;
|
||||
nv-reg RAX MOV ;
|
||||
|
||||
M: x86.64 %alien-indirect ( -- )
|
||||
RBP CALL ;
|
||||
nv-reg CALL ;
|
||||
|
||||
M: x86.64 %begin-callback ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
"begin_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
param-reg-0 param-reg-1 %restore-context
|
||||
|
@ -239,16 +236,15 @@ M: x86.64 %alien-callback ( quot -- )
|
|||
param-reg-0 quot-entry-point-offset [+] CALL
|
||||
param-reg-0 param-reg-1 %save-context ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
%pop-context-stack
|
||||
RSP 8 SUB
|
||||
param-reg-0 PUSH
|
||||
M: x86.64 %end-callback ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Put former top of data stack in param-reg-0
|
||||
param-reg-0 POP
|
||||
RSP 8 ADD
|
||||
"end_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %end-callback-value ( ctype -- )
|
||||
%pop-context-stack
|
||||
nv-reg param-reg-0 MOV
|
||||
%end-callback
|
||||
param-reg-0 nv-reg MOV
|
||||
! Unbox former top of data stack to return registers
|
||||
unbox-return ;
|
||||
|
||||
|
|
|
@ -16,7 +16,7 @@ IN: bootstrap.x86
|
|||
: temp2 ( -- reg ) RDX ;
|
||||
: temp3 ( -- reg ) RBX ;
|
||||
: return-reg ( -- reg ) RAX ;
|
||||
: safe-reg ( -- reg ) RAX ;
|
||||
: nv-reg ( -- reg ) nv-regs first ;
|
||||
: stack-reg ( -- reg ) RSP ;
|
||||
: frame-reg ( -- reg ) RBP ;
|
||||
: ctx-reg ( -- reg ) R12 ;
|
||||
|
@ -26,13 +26,17 @@ IN: bootstrap.x86
|
|||
: fixnum>slot@ ( -- ) temp0 1 SAR ;
|
||||
: rex-length ( -- n ) 1 ;
|
||||
|
||||
: jit-call ( name -- )
|
||||
RAX 0 MOV rc-absolute-cell jit-dlsym
|
||||
RAX CALL ;
|
||||
|
||||
[
|
||||
! load entry point
|
||||
safe-reg 0 MOV rc-absolute-cell rt-this jit-rel
|
||||
RAX 0 MOV rc-absolute-cell rt-this jit-rel
|
||||
! save stack frame size
|
||||
stack-frame-size PUSH
|
||||
! push entry point
|
||||
safe-reg PUSH
|
||||
RAX PUSH
|
||||
! alignment
|
||||
RSP stack-frame-size 3 bootstrap-cells - SUB
|
||||
] jit-prolog jit-define
|
||||
|
@ -47,8 +51,8 @@ IN: bootstrap.x86
|
|||
|
||||
: jit-save-context ( -- )
|
||||
jit-load-context
|
||||
safe-reg RSP -8 [+] LEA
|
||||
ctx-reg context-callstack-top-offset [+] safe-reg MOV
|
||||
RAX RSP -8 [+] LEA
|
||||
ctx-reg context-callstack-top-offset [+] RAX MOV
|
||||
ctx-reg context-datastack-offset [+] ds-reg MOV
|
||||
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
|
||||
|
||||
|
@ -67,13 +71,31 @@ IN: bootstrap.x86
|
|||
] jit-primitive jit-define
|
||||
|
||||
[
|
||||
nv-reg arg1 MOV
|
||||
|
||||
arg1 vm-reg MOV
|
||||
"begin_callback" jit-call
|
||||
|
||||
jit-restore-context
|
||||
! save ctx->callstack_bottom
|
||||
safe-reg stack-reg stack-frame-size 8 - [+] LEA
|
||||
ctx-reg context-callstack-bottom-offset [+] safe-reg MOV
|
||||
|
||||
! save C callstack pointer
|
||||
ctx-reg context-callstack-save-offset [+] stack-reg MOV
|
||||
|
||||
! load Factor callstack pointer
|
||||
stack-reg ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
stack-reg 8 ADD
|
||||
|
||||
! call the quotation
|
||||
arg1 nv-reg MOV
|
||||
arg1 quot-entry-point-offset [+] CALL
|
||||
|
||||
jit-save-context
|
||||
|
||||
! load C callstack pointer
|
||||
stack-reg ctx-reg context-callstack-save-offset [+] MOV
|
||||
|
||||
arg1 vm-reg MOV
|
||||
"end_callback" jit-call
|
||||
] \ c-to-factor define-sub-primitive
|
||||
|
||||
[
|
||||
|
@ -124,8 +146,7 @@ IN: bootstrap.x86
|
|||
! Call memcpy; arguments are now in the correct registers
|
||||
! Create register shadow area for Win64
|
||||
RSP 32 SUB
|
||||
safe-reg 0 MOV "factor_memcpy" f rc-absolute-cell jit-dlsym
|
||||
safe-reg CALL
|
||||
"factor_memcpy" jit-call
|
||||
! Tear down register shadow area
|
||||
RSP 32 ADD
|
||||
! Return with new callstack
|
||||
|
@ -135,8 +156,7 @@ IN: bootstrap.x86
|
|||
[
|
||||
jit-save-context
|
||||
arg2 vm-reg MOV
|
||||
safe-reg 0 MOV "lazy_jit_compile" f rc-absolute-cell jit-dlsym
|
||||
safe-reg CALL
|
||||
"lazy_jit_compile" jit-call
|
||||
]
|
||||
[ return-reg quot-entry-point-offset [+] CALL ]
|
||||
[ return-reg quot-entry-point-offset [+] JMP ]
|
||||
|
@ -152,8 +172,7 @@ IN: bootstrap.x86
|
|||
jit-save-context
|
||||
arg1 RBX MOV
|
||||
arg2 vm-reg MOV
|
||||
RAX 0 MOV "inline_cache_miss" f rc-absolute-cell jit-dlsym
|
||||
RAX CALL
|
||||
"inline_cache_miss" jit-call
|
||||
jit-restore-context ;
|
||||
|
||||
[ jit-load-return-address jit-inline-cache-miss ]
|
||||
|
@ -176,11 +195,7 @@ IN: bootstrap.x86
|
|||
[ [ arg3 arg2 ] dip call ] dip
|
||||
ds-reg [] arg3 MOV
|
||||
[ JNO ]
|
||||
[
|
||||
arg3 vm-reg MOV
|
||||
RAX 0 MOV f rc-absolute-cell jit-dlsym
|
||||
RAX CALL
|
||||
]
|
||||
[ arg3 vm-reg MOV jit-call ]
|
||||
jit-conditional ; inline
|
||||
|
||||
[ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
|
||||
|
@ -202,8 +217,7 @@ IN: bootstrap.x86
|
|||
arg1 tag-bits get SAR
|
||||
arg2 RBX MOV
|
||||
arg3 vm-reg MOV
|
||||
RAX 0 MOV "overflow_fixnum_multiply" f rc-absolute-cell jit-dlsym
|
||||
RAX CALL
|
||||
"overflow_fixnum_multiply" jit-call
|
||||
]
|
||||
jit-conditional
|
||||
] \ fixnum* define-sub-primitive
|
||||
|
|
|
@ -13,35 +13,45 @@ big-endian off
|
|||
! Optimizing compiler's side of callback accesses
|
||||
! arguments that are on the stack via the frame pointer.
|
||||
! On x86-64, some arguments are passed in registers, and
|
||||
! so the only register that is safe for use here is safe-reg.
|
||||
! so the only register that is safe for use here is nv-reg.
|
||||
frame-reg PUSH
|
||||
frame-reg stack-reg MOV
|
||||
|
||||
! Save all non-volatile registers
|
||||
nv-regs [ PUSH ] each
|
||||
|
||||
! Save old stack pointer and align
|
||||
safe-reg stack-reg MOV
|
||||
stack-reg bootstrap-cell SUB
|
||||
stack-reg -16 AND
|
||||
stack-reg [] safe-reg MOV
|
||||
! Load VM into vm-reg
|
||||
vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
|
||||
|
||||
! Register shadow area - only required on Win64, but doesn't
|
||||
! hurt on other platforms
|
||||
stack-reg 32 SUB
|
||||
! Save old context
|
||||
nv-reg vm-reg vm-context-offset [+] MOV
|
||||
nv-reg PUSH
|
||||
|
||||
! Switch over to the spare context
|
||||
nv-reg vm-reg vm-spare-context-offset [+] MOV
|
||||
vm-reg vm-context-offset [+] nv-reg MOV
|
||||
|
||||
! Save C callstack pointer
|
||||
nv-reg context-callstack-save-offset [+] stack-reg MOV
|
||||
|
||||
! Load Factor callstack pointer
|
||||
stack-reg nv-reg context-callstack-bottom-offset [+] MOV
|
||||
stack-reg bootstrap-cell ADD
|
||||
|
||||
! Call into Factor code
|
||||
nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
|
||||
nv-reg CALL
|
||||
|
||||
! Load VM into vm-reg
|
||||
vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
|
||||
|
||||
! Call into Factor code
|
||||
safe-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
|
||||
safe-reg CALL
|
||||
! Load C callstack pointer
|
||||
nv-reg vm-reg vm-context-offset [+] MOV
|
||||
stack-reg nv-reg context-callstack-save-offset [+] MOV
|
||||
|
||||
! Tear down register shadow area
|
||||
stack-reg 32 ADD
|
||||
|
||||
! Undo stack alignment
|
||||
stack-reg stack-reg [] MOV
|
||||
! Load old context
|
||||
nv-reg POP
|
||||
vm-reg vm-context-offset [+] nv-reg MOV
|
||||
|
||||
! Restore non-volatile registers
|
||||
nv-regs <reversed> [ POP ] each
|
||||
|
@ -56,15 +66,15 @@ big-endian off
|
|||
|
||||
[
|
||||
! Load word
|
||||
safe-reg 0 MOV rc-absolute-cell rt-literal jit-rel
|
||||
temp0 0 MOV rc-absolute-cell rt-literal jit-rel
|
||||
! Bump profiling counter
|
||||
safe-reg profile-count-offset [+] 1 tag-fixnum ADD
|
||||
temp0 profile-count-offset [+] 1 tag-fixnum ADD
|
||||
! Load word->code
|
||||
safe-reg safe-reg word-code-offset [+] MOV
|
||||
temp0 temp0 word-code-offset [+] MOV
|
||||
! Compute word entry point
|
||||
safe-reg compiled-header-size ADD
|
||||
temp0 compiled-header-size ADD
|
||||
! Jump to entry point
|
||||
safe-reg JMP
|
||||
temp0 JMP
|
||||
] jit-profiling jit-define
|
||||
|
||||
[
|
||||
|
|
|
@ -1403,10 +1403,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
|
|||
|
||||
M:: x86 %restore-context ( temp1 temp2 -- )
|
||||
#! Load Factor stack pointers on entry from C to Factor.
|
||||
#! Also save callstack bottom!
|
||||
temp1 "ctx" %vm-field
|
||||
temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
|
||||
temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
|
||||
ds-reg temp1 "datastack" context-field-offset [+] MOV
|
||||
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
|
||||
|
||||
|
|
|
@ -1,19 +1,20 @@
|
|||
! Copyright (C) 2004, 2010 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry accessors alien alien.accessors arrays byte-arrays
|
||||
classes continuations.private effects generic hashtables
|
||||
hashtables.private io io.backend io.files io.files.private
|
||||
io.streams.c kernel kernel.private math math.private
|
||||
math.parser.private memory memory.private namespaces
|
||||
namespaces.private parser quotations quotations.private sbufs
|
||||
sbufs.private sequences sequences.private slots.private strings
|
||||
strings.private system threads.private classes.tuple
|
||||
classes.tuple.private vectors vectors.private words
|
||||
words.private definitions assocs summary compiler.units
|
||||
system.private combinators combinators.short-circuit locals
|
||||
locals.backend locals.types combinators.private
|
||||
stack-checker.values generic.single generic.single.private
|
||||
alien.libraries tools.dispatch.private tools.profiler.private
|
||||
USING: fry accessors alien alien.accessors alien.private arrays
|
||||
byte-arrays classes continuations.private effects generic
|
||||
hashtables hashtables.private io io.backend io.files
|
||||
io.files.private io.streams.c kernel kernel.private math
|
||||
math.private math.parser.private memory memory.private
|
||||
namespaces namespaces.private parser quotations
|
||||
quotations.private sbufs sbufs.private sequences
|
||||
sequences.private slots.private strings strings.private system
|
||||
threads.private classes.tuple classes.tuple.private vectors
|
||||
vectors.private words words.private definitions assocs summary
|
||||
compiler.units system.private combinators
|
||||
combinators.short-circuit locals locals.backend locals.types
|
||||
combinators.private stack-checker.values generic.single
|
||||
generic.single.private alien.libraries tools.dispatch.private
|
||||
tools.profiler.private
|
||||
stack-checker.alien
|
||||
stack-checker.state
|
||||
stack-checker.errors
|
||||
|
@ -504,6 +505,16 @@ M: bad-executable summary
|
|||
\ word-code { word } { integer integer } define-primitive
|
||||
\ word-code make-flushable
|
||||
|
||||
\ current-callback { } { fixnum } define-primitive
|
||||
\ current-callback make-flushable
|
||||
|
||||
\ current-context { } { c-ptr } define-primitive
|
||||
\ current-context make-flushable
|
||||
|
||||
\ delete-context { c-ptr } { } define-primitive
|
||||
|
||||
\ start-context { quotation } { } define-primitive
|
||||
|
||||
\ special-object { fixnum } { object } define-primitive
|
||||
\ special-object make-flushable
|
||||
|
||||
|
|
|
@ -10,12 +10,11 @@ STRUCT: context
|
|||
{ callstack-bottom void* }
|
||||
{ datastack cell }
|
||||
{ retainstack cell }
|
||||
{ magic-frame void* }
|
||||
{ callstack-save cell }
|
||||
{ context-objects cell[10] }
|
||||
{ datastack-region void* }
|
||||
{ retainstack-region void* }
|
||||
{ catchstack-save cell }
|
||||
{ current-callback-save cell }
|
||||
{ next context* } ;
|
||||
{ callstack-region void* } ;
|
||||
|
||||
: context-field-offset ( field -- offset ) context offset-of ; inline
|
||||
|
||||
|
@ -27,6 +26,7 @@ STRUCT: zone
|
|||
|
||||
STRUCT: vm
|
||||
{ ctx context* }
|
||||
{ spare-ctx context* }
|
||||
{ nursery zone }
|
||||
{ cards-offset cell }
|
||||
{ decks-offset cell }
|
||||
|
|
|
@ -94,26 +94,21 @@ SYMBOL: callbacks
|
|||
|
||||
[ H{ } clone callbacks set-global ] "alien" add-startup-hook
|
||||
|
||||
! Every context object in the VM is identified from the Factor
|
||||
! side by a unique identifier
|
||||
TUPLE: context-id < identity-tuple ;
|
||||
|
||||
C: <context-id> context-id
|
||||
|
||||
: context-id ( -- id ) 2 context-object ;
|
||||
|
||||
: set-context-id ( id -- ) 2 set-context-object ;
|
||||
|
||||
: wait-to-return ( yield-quot id -- )
|
||||
dup context-id eq?
|
||||
! Every callback invocation has a unique identifier in the VM.
|
||||
! We make sure that the current callback is the right one before
|
||||
! returning from it, to avoid a bad interaction between threads
|
||||
! and callbacks. See basis/compiler/tests/alien.factor for a
|
||||
! test case.
|
||||
: wait-to-return ( yield-quot callback-id -- )
|
||||
dup current-callback eq?
|
||||
[ 2drop ] [ over call( -- ) wait-to-return ] if ;
|
||||
|
||||
! Used by compiler.codegen to wrap callback bodies
|
||||
: do-callback ( callback-quot yield-quot -- )
|
||||
init-namespaces
|
||||
init-catchstack
|
||||
<context-id>
|
||||
[ set-context-id drop call ] [ wait-to-return drop ] 3bi ; inline
|
||||
current-callback
|
||||
[ 2drop call ] [ wait-to-return drop ] 3bi ; inline
|
||||
|
||||
! A utility for defining global variables that are recompiled in
|
||||
! every session
|
||||
|
|
|
@ -63,6 +63,7 @@ call( -- )
|
|||
"alien"
|
||||
"alien.accessors"
|
||||
"alien.libraries"
|
||||
"alien.private"
|
||||
"arrays"
|
||||
"byte-arrays"
|
||||
"classes.private"
|
||||
|
@ -415,6 +416,7 @@ tuple
|
|||
{ "(dlsym)" "alien.libraries" "primitive_dlsym" (( name dll -- alien )) }
|
||||
{ "dlclose" "alien.libraries" "primitive_dlclose" (( dll -- )) }
|
||||
{ "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
|
||||
{ "current-callback" "alien.private" "primitive_current_callback" (( -- n )) }
|
||||
{ "<array>" "arrays" "primitive_array" (( n elt -- array )) }
|
||||
{ "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) }
|
||||
{ "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
|
||||
|
@ -532,6 +534,9 @@ tuple
|
|||
{ "nano-count" "system" "primitive_nano_count" (( -- ns )) }
|
||||
{ "system-micros" "system" "primitive_system_micros" (( -- us )) }
|
||||
{ "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
|
||||
{ "current-context" "threads.private" "primitive_current_context" (( -- c-ptr )) }
|
||||
{ "delete-context" "threads.private" "primitive_delete_context" (( c-ptr -- )) }
|
||||
{ "start-context" "threads.private" "primitive_start_context" (( quot -- )) }
|
||||
{ "dispatch-stats" "tools.dispatch.private" "primitive_dispatch_stats" (( -- stats )) }
|
||||
{ "reset-dispatch-stats" "tools.dispatch.private" "primitive_reset_dispatch_stats" (( -- )) }
|
||||
{ "profiling" "tools.profiler.private" "primitive_profiling" (( ? -- )) }
|
||||
|
|
|
@ -86,8 +86,7 @@ M: lexer skip-word ( lexer -- )
|
|||
|
||||
: scan ( -- str/f ) lexer get parse-token ;
|
||||
|
||||
PREDICATE: unexpected-eof < unexpected
|
||||
got>> not ;
|
||||
PREDICATE: unexpected-eof < unexpected got>> not ;
|
||||
|
||||
: unexpected-eof ( word -- * ) f unexpected ;
|
||||
|
||||
|
@ -97,14 +96,15 @@ PREDICATE: unexpected-eof < unexpected
|
|||
[ unexpected-eof ]
|
||||
if* ;
|
||||
|
||||
: (each-token) ( end quot -- pred quot )
|
||||
[ [ [ scan dup ] ] dip [ = not ] curry [ [ f ] if* ] curry compose ] dip ; inline
|
||||
|
||||
: each-token ( ... end quot: ( ... token -- ... ) -- ... )
|
||||
(each-token) while drop ; inline
|
||||
[ scan ] 2dip {
|
||||
{ [ 2over = ] [ 3drop ] }
|
||||
{ [ pick not ] [ drop unexpected-eof ] }
|
||||
[ [ nip call ] [ each-token ] 2bi ]
|
||||
} cond ; inline recursive
|
||||
|
||||
: map-tokens ( ... end quot: ( ... token -- ... elt ) -- ... seq )
|
||||
(each-token) produce nip ; inline
|
||||
collector [ each-token ] dip { } like ; inline
|
||||
|
||||
: parse-tokens ( end -- seq )
|
||||
[ ] map-tokens ;
|
||||
|
@ -112,6 +112,7 @@ PREDICATE: unexpected-eof < unexpected
|
|||
TUPLE: lexer-error line column line-text parsing-words error ;
|
||||
|
||||
M: lexer-error error-file error>> error-file ;
|
||||
|
||||
M: lexer-error error-line [ error>> error-line ] [ line>> ] bi or ;
|
||||
|
||||
: <lexer-error> ( msg -- error )
|
||||
|
|
|
@ -7,332 +7,334 @@ vocabs.parser words.symbol multiline source-files.errors
|
|||
tools.crossref grouping ;
|
||||
IN: parser.tests
|
||||
|
||||
[ 1 [ 2 [ 3 ] 4 ] 5 ]
|
||||
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
|
||||
unit-test
|
||||
|
||||
[ t t f f ]
|
||||
[ "t t f f" eval( -- ? ? ? ? ) ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[ "\"hello world\"" eval( -- string ) ]
|
||||
unit-test
|
||||
|
||||
[ "\n\r\t\\" ]
|
||||
[ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[
|
||||
[ 1 [ 2 [ 3 ] 4 ] 5 ]
|
||||
[ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
|
||||
unit-test
|
||||
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
|
||||
eval( -- ) "USE: parser.tests hello" eval( -- string )
|
||||
] unit-test
|
||||
|
||||
[ t t f f ]
|
||||
[ "t t f f" eval( -- ? ? ? ? ) ]
|
||||
unit-test
|
||||
[ ]
|
||||
[ "! This is a comment, people." eval( -- ) ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[ "\"hello world\"" eval( -- string ) ]
|
||||
unit-test
|
||||
! Test escapes
|
||||
|
||||
[ "\n\r\t\\" ]
|
||||
[ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
|
||||
unit-test
|
||||
[ " " ]
|
||||
[ "\"\\u000020\"" eval( -- string ) ]
|
||||
unit-test
|
||||
|
||||
[ "hello world" ]
|
||||
[
|
||||
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
|
||||
eval( -- ) "USE: parser.tests hello" eval( -- string )
|
||||
] unit-test
|
||||
[ "'" ]
|
||||
[ "\"\\u000027\"" eval( -- string ) ]
|
||||
unit-test
|
||||
|
||||
[ ]
|
||||
[ "! This is a comment, people." eval( -- ) ]
|
||||
unit-test
|
||||
! Test EOL comments in multiline strings.
|
||||
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test
|
||||
|
||||
! Test escapes
|
||||
[ word ] [ \ f class ] unit-test
|
||||
|
||||
[ " " ]
|
||||
[ "\"\\u000020\"" eval( -- string ) ]
|
||||
unit-test
|
||||
! Test stack effect parsing
|
||||
|
||||
[ "'" ]
|
||||
[ "\"\\u000027\"" eval( -- string ) ]
|
||||
unit-test
|
||||
: effect-parsing-test ( a b -- c ) + ;
|
||||
|
||||
! Test EOL comments in multiline strings.
|
||||
[ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test
|
||||
[ t ] [
|
||||
"effect-parsing-test" "parser.tests" lookup
|
||||
\ effect-parsing-test eq?
|
||||
] unit-test
|
||||
|
||||
[ word ] [ \ f class ] unit-test
|
||||
[ T{ effect f { "a" "b" } { "c" } f } ]
|
||||
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
|
||||
|
||||
! Test stack effect parsing
|
||||
: baz ( a b -- * ) 2array throw ;
|
||||
|
||||
: effect-parsing-test ( a b -- c ) + ;
|
||||
[ t ]
|
||||
[ \ baz "declared-effect" word-prop terminated?>> ]
|
||||
unit-test
|
||||
|
||||
[ t ] [
|
||||
"effect-parsing-test" "parser.tests" lookup
|
||||
\ effect-parsing-test eq?
|
||||
] unit-test
|
||||
[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test
|
||||
|
||||
[ T{ effect f { "a" "b" } { "c" } f } ]
|
||||
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
|
||||
[ t ] [
|
||||
"effect-parsing-test" "parser.tests" lookup
|
||||
\ effect-parsing-test eq?
|
||||
] unit-test
|
||||
|
||||
: baz ( a b -- * ) 2array throw ;
|
||||
[ T{ effect f { "a" "b" } { "d" } f } ]
|
||||
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
|
||||
|
||||
[ t ]
|
||||
[ \ baz "declared-effect" word-prop terminated?>> ]
|
||||
unit-test
|
||||
[ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail
|
||||
|
||||
[ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test
|
||||
! Funny bug
|
||||
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test
|
||||
|
||||
[ t ] [
|
||||
"effect-parsing-test" "parser.tests" lookup
|
||||
\ effect-parsing-test eq?
|
||||
] unit-test
|
||||
! These should throw errors
|
||||
[ "HEX: zzz" eval( -- obj ) ] must-fail
|
||||
[ "OCT: 999" eval( -- obj ) ] must-fail
|
||||
[ "BIN: --0" eval( -- obj ) ] must-fail
|
||||
|
||||
[ T{ effect f { "a" "b" } { "d" } f } ]
|
||||
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
|
||||
DEFER: foo
|
||||
|
||||
! Funny bug
|
||||
[ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test
|
||||
"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
|
||||
|
||||
[ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail
|
||||
[ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test
|
||||
|
||||
! These should throw errors
|
||||
[ "HEX: zzz" eval( -- obj ) ] must-fail
|
||||
[ "OCT: 999" eval( -- obj ) ] must-fail
|
||||
[ "BIN: --0" eval( -- obj ) ] must-fail
|
||||
"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- )
|
||||
|
||||
DEFER: foo
|
||||
[ t ] [
|
||||
"USE: parser.tests \\ foo" eval( -- word )
|
||||
"foo" "parser.tests" lookup eq?
|
||||
] unit-test
|
||||
|
||||
"IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
|
||||
! parse-tokens should do the right thing on EOF
|
||||
[ "USING: kernel" eval( -- ) ]
|
||||
[ error>> T{ unexpected { want ";" } } = ] must-fail-with
|
||||
|
||||
[ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test
|
||||
! Test smudging
|
||||
|
||||
"IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- )
|
||||
[ 1 ] [
|
||||
"IN: parser.tests : smudge-me ( -- ) ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
[ t ] [
|
||||
"USE: parser.tests \\ foo" eval( -- word )
|
||||
"foo" "parser.tests" lookup eq?
|
||||
] unit-test
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
|
||||
! Test smudging
|
||||
[ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
"IN: parser.tests : smudge-me ( -- ) ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
[ ] [
|
||||
"IN: parser.tests : smudge-me-more ( -- ) ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
[ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
|
||||
[ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
|
||||
|
||||
[ t ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
|
||||
[ 3 ] [
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : smudge-me-more ( -- ) ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "smudge-me-more" "parser.tests" lookup >boolean ] unit-test
|
||||
[ f ] [ "smudge-me" "parser.tests" lookup >boolean ] unit-test
|
||||
[ 1 ] [
|
||||
"IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
|
||||
parse-stream drop
|
||||
|
||||
[ 3 ] [
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ; M: string smudge-me ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
"bar" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
[ 2 ] [
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
|
||||
[ 1 ] [
|
||||
"IN: parser.tests USING: arrays ; M: array smudge-me ;" <string-reader> "bar"
|
||||
parse-stream drop
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
|
||||
"bar" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
[ t ] [
|
||||
array "smudge-me" "parser.tests" lookup order member-eq?
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
"IN: parser.tests USING: math strings ; GENERIC: smudge-me ( a -- b ) M: integer smudge-me ;" <string-reader> "foo"
|
||||
parse-stream drop
|
||||
[ t ] [
|
||||
integer "smudge-me" "parser.tests" lookup order member-eq?
|
||||
] unit-test
|
||||
|
||||
"foo" source-file definitions>> first assoc-size
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
array "smudge-me" "parser.tests" lookup order member-eq?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
integer "smudge-me" "parser.tests" lookup order member-eq?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
string "smudge-me" "parser.tests" lookup order member-eq?
|
||||
] unit-test
|
||||
[ f ] [
|
||||
string "smudge-me" "parser.tests" lookup order member-eq?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests USE: math 2 2 +" <string-reader> "a"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"a" <pathname> \ + usage member?
|
||||
] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests USE: math 2 2 +" <string-reader> "a"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests USE: math 2 2 -" <string-reader> "a"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
"a" <pathname> \ + usage member?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"a" source-files get delete-at
|
||||
2 [
|
||||
"IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;"
|
||||
<string-reader> "a" parse-stream drop
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"a" <pathname> \ + usage member?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests USE: math 2 2 -" <string-reader> "a"
|
||||
parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
"a" <pathname> \ + usage member?
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"a" source-files get delete-at
|
||||
|
||||
[
|
||||
"IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error"
|
||||
<string-reader> "a" parse-stream
|
||||
] [ source-file-error? ] must-fail-with
|
||||
|
||||
[ t ] [
|
||||
"y" "parser.tests" lookup >boolean
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
"IN: parser.tests : x ( -- ) ;"
|
||||
2 [
|
||||
"IN: parser.tests DEFER: x : y ( -- ) x ; : x ( -- ) y ;"
|
||||
<string-reader> "a" parse-stream drop
|
||||
|
||||
"y" "parser.tests" lookup
|
||||
] unit-test
|
||||
] times
|
||||
] unit-test
|
||||
|
||||
! Test new forward definition logic
|
||||
[ ] [
|
||||
"IN: axx : axx ( -- ) ;"
|
||||
<string-reader> "axx" parse-stream drop
|
||||
] unit-test
|
||||
"a" source-files get delete-at
|
||||
|
||||
[ ] [
|
||||
"USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;"
|
||||
<string-reader> "bxx" parse-stream drop
|
||||
] unit-test
|
||||
[
|
||||
"IN: parser.tests : x ( -- ) ; : y ( -- * ) 3 throw ; this is an error"
|
||||
<string-reader> "a" parse-stream
|
||||
] [ source-file-error? ] must-fail-with
|
||||
|
||||
! So we move the bxx word to axx...
|
||||
[ ] [
|
||||
"IN: axx : axx ( -- ) ; : bxx ( -- ) ;"
|
||||
<string-reader> "axx" parse-stream drop
|
||||
] unit-test
|
||||
[ t ] [
|
||||
"y" "parser.tests" lookup >boolean
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "bxx" "axx" lookup >boolean ] unit-test
|
||||
|
||||
! And reload the file that uses it...
|
||||
[ ] [
|
||||
"USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;"
|
||||
<string-reader> "bxx" parse-stream drop
|
||||
] unit-test
|
||||
[ f ] [
|
||||
"IN: parser.tests : x ( -- ) ;"
|
||||
<string-reader> "a" parse-stream drop
|
||||
|
||||
! And hope not to get a forward-error!
|
||||
"y" "parser.tests" lookup
|
||||
] unit-test
|
||||
|
||||
! Turning a generic into a non-generic could cause all
|
||||
! kinds of funnyness
|
||||
[ ] [
|
||||
"IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
|
||||
<string-reader> "ayy" parse-stream drop
|
||||
] unit-test
|
||||
! Test new forward definition logic
|
||||
[ ] [
|
||||
"IN: axx : axx ( -- ) ;"
|
||||
<string-reader> "axx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: ayy USE: kernel : ayy ( -- ) ;"
|
||||
<string-reader> "ayy" parse-stream drop
|
||||
] unit-test
|
||||
[ ] [
|
||||
"USE: axx IN: bxx : bxx ( -- ) ; : cxx ( -- ) axx bxx ;"
|
||||
<string-reader> "bxx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
|
||||
<string-reader> "azz" parse-stream drop
|
||||
] unit-test
|
||||
! So we move the bxx word to axx...
|
||||
[ ] [
|
||||
"IN: axx : axx ( -- ) ; : bxx ( -- ) ;"
|
||||
<string-reader> "axx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"USE: azz M: my-class a-generic ;"
|
||||
<string-reader> "azz-2" parse-stream drop
|
||||
] unit-test
|
||||
[ t ] [ "bxx" "axx" lookup >boolean ] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: azz GENERIC: a-generic ( a -- b )"
|
||||
<string-reader> "azz" parse-stream drop
|
||||
] unit-test
|
||||
! And reload the file that uses it...
|
||||
[ ] [
|
||||
"USE: axx IN: bxx ( -- ) : cxx ( -- ) axx bxx ;"
|
||||
<string-reader> "bxx" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"USE: azz USE: math M: integer a-generic ;"
|
||||
<string-reader> "azz-2" parse-stream drop
|
||||
] unit-test
|
||||
! And hope not to get a forward-error!
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
! Turning a generic into a non-generic could cause all
|
||||
! kinds of funnyness
|
||||
[ ] [
|
||||
"IN: ayy USE: kernel GENERIC: ayy ( a -- b ) M: object ayy ;"
|
||||
<string-reader> "ayy" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
[ ] [
|
||||
"IN: ayy USE: kernel : ayy ( -- ) ;"
|
||||
<string-reader> "ayy" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
! Problems with class predicates -vs- ordinary words
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: killer ;"
|
||||
<string-reader> "removing-the-predicate" parse-stream drop
|
||||
] unit-test
|
||||
[ ] [
|
||||
"IN: azz TUPLE: my-class ; GENERIC: a-generic ( a -- b )"
|
||||
<string-reader> "azz" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests GENERIC: killer? ( a -- b )"
|
||||
<string-reader> "removing-the-predicate" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"killer?" "parser.tests" lookup >boolean
|
||||
] unit-test
|
||||
[ ] [
|
||||
"USE: azz M: my-class a-generic ;"
|
||||
<string-reader> "azz-2" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
|
||||
<string-reader> "removing-the-predicate" parse-stream
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
[ ] [
|
||||
"IN: azz GENERIC: a-generic ( a -- b )"
|
||||
<string-reader> "azz" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
|
||||
<string-reader> "redefining-a-class-1" parse-stream
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
[ ] [
|
||||
"USE: azz USE: math M: integer a-generic ;"
|
||||
<string-reader> "azz-2" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
|
||||
<string-reader> "redefining-a-class-2" parse-stream drop
|
||||
] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
|
||||
<string-reader> "bogus-error" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: class-fwd-test ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] unit-test
|
||||
! Problems with class predicates -vs- ordinary words
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: killer ;"
|
||||
<string-reader> "removing-the-predicate" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ error>> error>> error>> no-word-error? ] must-fail-with
|
||||
[ ] [
|
||||
"IN: parser.tests GENERIC: killer? ( a -- b )"
|
||||
<string-reader> "removing-the-predicate" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] unit-test
|
||||
[ t ] [
|
||||
"killer?" "parser.tests" lookup >boolean
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ error>> error>> error>> no-word-error? ] must-fail-with
|
||||
[
|
||||
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test? ( a -- b )"
|
||||
<string-reader> "removing-the-predicate" parse-stream
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
[
|
||||
"IN: parser.tests : foo ( -- ) ; TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-4" parse-stream drop
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
[
|
||||
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
|
||||
<string-reader> "redefining-a-class-1" parse-stream
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- )
|
||||
] unit-test
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
|
||||
<string-reader> "redefining-a-class-2" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- )
|
||||
] must-fail
|
||||
] with-file-vocabs
|
||||
[
|
||||
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ( -- ) ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: class-fwd-test ;"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ error>> error>> error>> no-word-error? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests \\ class-fwd-test"
|
||||
<string-reader> "redefining-a-class-3" parse-stream drop
|
||||
] [ error>> error>> error>> no-word-error? ] must-fail-with
|
||||
|
||||
[
|
||||
"IN: parser.tests : foo ( -- ) ; TUPLE: foo ;"
|
||||
<string-reader> "redefining-a-class-4" parse-stream drop
|
||||
] [ error>> error>> error>> redefine-error? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- )
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- )
|
||||
] must-fail
|
||||
|
||||
[ ] [
|
||||
"IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- )
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien arrays byte-arrays byte-vectors definitions generic
|
||||
hashtables kernel math namespaces parser lexer sequences strings
|
||||
|
@ -125,7 +125,7 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"SYMBOLS:" [
|
||||
";" [ create-in dup reset-generic define-symbol ] each-token
|
||||
";" [ create-in [ reset-generic ] [ define-symbol ] bi ] each-token
|
||||
] define-core-syntax
|
||||
|
||||
"SINGLETONS:" [
|
||||
|
|
|
@ -9,7 +9,7 @@ body, button {
|
|||
border: none;
|
||||
}
|
||||
|
||||
a, .link {
|
||||
a:link, a:visited, .link {
|
||||
color: #222;
|
||||
border-bottom:1px dotted #666;
|
||||
text-decoration:none;
|
||||
|
|
|
@ -64,11 +64,12 @@ code_block *callback_heap::add(cell owner, cell return_rewind)
|
|||
|
||||
/* Store VM pointer */
|
||||
store_callback_operand(stub,0,(cell)parent);
|
||||
store_callback_operand(stub,2,(cell)parent);
|
||||
|
||||
/* On x86, the RET instruction takes an argument which depends on
|
||||
the callback's calling convention */
|
||||
#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
|
||||
store_callback_operand(stub,2,return_rewind);
|
||||
store_callback_operand(stub,3,return_rewind);
|
||||
#endif
|
||||
|
||||
update(stub);
|
||||
|
|
|
@ -13,7 +13,7 @@ void factor_vm::check_frame(stack_frame *frame)
|
|||
|
||||
callstack *factor_vm::allot_callstack(cell size)
|
||||
{
|
||||
callstack *stack = allot<callstack>(callstack_size(size));
|
||||
callstack *stack = allot<callstack>(callstack_object_size(size));
|
||||
stack->length = tag_fixnum(size);
|
||||
return stack;
|
||||
}
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
namespace factor
|
||||
{
|
||||
|
||||
inline static cell callstack_size(cell size)
|
||||
inline static cell callstack_object_size(cell size)
|
||||
{
|
||||
return sizeof(callstack) + size;
|
||||
}
|
||||
|
|
|
@ -114,7 +114,7 @@ template<typename Visitor>
|
|||
void code_block_visitor<Visitor>::visit_context_code_blocks()
|
||||
{
|
||||
call_frame_code_block_visitor<Visitor> call_frame_visitor(parent,visitor);
|
||||
parent->iterate_active_frames(call_frame_visitor);
|
||||
parent->iterate_active_callstacks(call_frame_visitor);
|
||||
}
|
||||
|
||||
template<typename Visitor>
|
||||
|
|
155
vm/contexts.cpp
155
vm/contexts.cpp
|
@ -3,28 +3,32 @@
|
|||
namespace factor
|
||||
{
|
||||
|
||||
context::context(cell ds_size, cell rs_size) :
|
||||
context::context(cell datastack_size, cell retainstack_size, cell callstack_size) :
|
||||
callstack_top(NULL),
|
||||
callstack_bottom(NULL),
|
||||
datastack(0),
|
||||
retainstack(0),
|
||||
datastack_region(new segment(ds_size,false)),
|
||||
retainstack_region(new segment(rs_size,false)),
|
||||
next(NULL)
|
||||
callstack_save(0),
|
||||
datastack_seg(new segment(datastack_size,false)),
|
||||
retainstack_seg(new segment(retainstack_size,false)),
|
||||
callstack_seg(new segment(callstack_size,false))
|
||||
{
|
||||
reset_datastack();
|
||||
reset_retainstack();
|
||||
reset_context_objects();
|
||||
reset();
|
||||
}
|
||||
|
||||
void context::reset_datastack()
|
||||
{
|
||||
datastack = datastack_region->start - sizeof(cell);
|
||||
datastack = datastack_seg->start - sizeof(cell);
|
||||
}
|
||||
|
||||
void context::reset_retainstack()
|
||||
{
|
||||
retainstack = retainstack_region->start - sizeof(cell);
|
||||
retainstack = retainstack_seg->start - sizeof(cell);
|
||||
}
|
||||
|
||||
void context::reset_callstack()
|
||||
{
|
||||
callstack_top = callstack_bottom = CALLSTACK_BOTTOM(this);
|
||||
}
|
||||
|
||||
void context::reset_context_objects()
|
||||
|
@ -32,68 +36,99 @@ void context::reset_context_objects()
|
|||
memset_cell(context_objects,false_object,context_object_count * sizeof(cell));
|
||||
}
|
||||
|
||||
context *factor_vm::alloc_context()
|
||||
void context::reset()
|
||||
{
|
||||
reset_datastack();
|
||||
reset_retainstack();
|
||||
reset_callstack();
|
||||
reset_context_objects();
|
||||
}
|
||||
|
||||
context::~context()
|
||||
{
|
||||
delete datastack_seg;
|
||||
delete retainstack_seg;
|
||||
delete callstack_seg;
|
||||
}
|
||||
|
||||
/* called on startup */
|
||||
void factor_vm::init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_)
|
||||
{
|
||||
datastack_size = datastack_size_;
|
||||
retainstack_size = retainstack_size_;
|
||||
callstack_size = callstack_size_;
|
||||
|
||||
ctx = NULL;
|
||||
spare_ctx = new_context();
|
||||
}
|
||||
|
||||
void factor_vm::delete_contexts()
|
||||
{
|
||||
assert(!ctx);
|
||||
std::vector<context *>::const_iterator iter = unused_contexts.begin();
|
||||
std::vector<context *>::const_iterator end = unused_contexts.end();
|
||||
while(iter != end)
|
||||
{
|
||||
delete *iter;
|
||||
iter++;
|
||||
}
|
||||
}
|
||||
|
||||
context *factor_vm::new_context()
|
||||
{
|
||||
context *new_context;
|
||||
|
||||
if(unused_contexts)
|
||||
if(unused_contexts.empty())
|
||||
{
|
||||
new_context = unused_contexts;
|
||||
unused_contexts = unused_contexts->next;
|
||||
new_context = new context(datastack_size,
|
||||
retainstack_size,
|
||||
callstack_size);
|
||||
}
|
||||
else
|
||||
new_context = new context(ds_size,rs_size);
|
||||
{
|
||||
new_context = unused_contexts.back();
|
||||
unused_contexts.pop_back();
|
||||
}
|
||||
|
||||
new_context->reset();
|
||||
|
||||
active_contexts.insert(new_context);
|
||||
|
||||
return new_context;
|
||||
}
|
||||
|
||||
void factor_vm::dealloc_context(context *old_context)
|
||||
void factor_vm::delete_context(context *old_context)
|
||||
{
|
||||
old_context->next = unused_contexts;
|
||||
unused_contexts = old_context;
|
||||
unused_contexts.push_back(old_context);
|
||||
active_contexts.erase(old_context);
|
||||
}
|
||||
|
||||
/* called on entry into a compiled callback */
|
||||
void factor_vm::nest_stacks()
|
||||
void factor_vm::begin_callback()
|
||||
{
|
||||
context *new_ctx = alloc_context();
|
||||
|
||||
new_ctx->callstack_bottom = (stack_frame *)-1;
|
||||
new_ctx->callstack_top = (stack_frame *)-1;
|
||||
|
||||
new_ctx->reset_datastack();
|
||||
new_ctx->reset_retainstack();
|
||||
new_ctx->reset_context_objects();
|
||||
|
||||
new_ctx->next = ctx;
|
||||
ctx = new_ctx;
|
||||
ctx->reset();
|
||||
spare_ctx = new_context();
|
||||
callback_ids.push_back(callback_id++);
|
||||
}
|
||||
|
||||
void nest_stacks(factor_vm *parent)
|
||||
void begin_callback(factor_vm *parent)
|
||||
{
|
||||
return parent->nest_stacks();
|
||||
parent->begin_callback();
|
||||
}
|
||||
|
||||
/* called when leaving a compiled callback */
|
||||
void factor_vm::unnest_stacks()
|
||||
void factor_vm::end_callback()
|
||||
{
|
||||
context *old_ctx = ctx;
|
||||
ctx = old_ctx->next;
|
||||
dealloc_context(old_ctx);
|
||||
callback_ids.pop_back();
|
||||
delete_context(ctx);
|
||||
}
|
||||
|
||||
void unnest_stacks(factor_vm *parent)
|
||||
void end_callback(factor_vm *parent)
|
||||
{
|
||||
return parent->unnest_stacks();
|
||||
parent->end_callback();
|
||||
}
|
||||
|
||||
/* called on startup */
|
||||
void factor_vm::init_stacks(cell ds_size_, cell rs_size_)
|
||||
void factor_vm::primitive_current_callback()
|
||||
{
|
||||
ds_size = ds_size_;
|
||||
rs_size = rs_size_;
|
||||
ctx = NULL;
|
||||
unused_contexts = NULL;
|
||||
ctx->push(tag_fixnum(callback_ids.back()));
|
||||
}
|
||||
|
||||
void factor_vm::primitive_context_object()
|
||||
|
@ -126,13 +161,13 @@ bool factor_vm::stack_to_array(cell bottom, cell top)
|
|||
|
||||
void factor_vm::primitive_datastack()
|
||||
{
|
||||
if(!stack_to_array(ctx->datastack_region->start,ctx->datastack))
|
||||
if(!stack_to_array(ctx->datastack_seg->start,ctx->datastack))
|
||||
general_error(ERROR_DS_UNDERFLOW,false_object,false_object,NULL);
|
||||
}
|
||||
|
||||
void factor_vm::primitive_retainstack()
|
||||
{
|
||||
if(!stack_to_array(ctx->retainstack_region->start,ctx->retainstack))
|
||||
if(!stack_to_array(ctx->retainstack_seg->start,ctx->retainstack))
|
||||
general_error(ERROR_RS_UNDERFLOW,false_object,false_object,NULL);
|
||||
}
|
||||
|
||||
|
@ -146,12 +181,12 @@ cell factor_vm::array_to_stack(array *array, cell bottom)
|
|||
|
||||
void factor_vm::primitive_set_datastack()
|
||||
{
|
||||
ctx->datastack = array_to_stack(untag_check<array>(ctx->pop()),ctx->datastack_region->start);
|
||||
ctx->datastack = array_to_stack(untag_check<array>(ctx->pop()),ctx->datastack_seg->start);
|
||||
}
|
||||
|
||||
void factor_vm::primitive_set_retainstack()
|
||||
{
|
||||
ctx->retainstack = array_to_stack(untag_check<array>(ctx->pop()),ctx->retainstack_region->start);
|
||||
ctx->retainstack = array_to_stack(untag_check<array>(ctx->pop()),ctx->retainstack_seg->start);
|
||||
}
|
||||
|
||||
/* Used to implement call( */
|
||||
|
@ -162,12 +197,12 @@ void factor_vm::primitive_check_datastack()
|
|||
fixnum height = out - in;
|
||||
array *saved_datastack = untag_check<array>(ctx->pop());
|
||||
fixnum saved_height = array_capacity(saved_datastack);
|
||||
fixnum current_height = (ctx->datastack - ctx->datastack_region->start + sizeof(cell)) / sizeof(cell);
|
||||
fixnum current_height = (ctx->datastack - ctx->datastack_seg->start + sizeof(cell)) / sizeof(cell);
|
||||
if(current_height - height != saved_height)
|
||||
ctx->push(false_object);
|
||||
else
|
||||
{
|
||||
cell *ds_bot = (cell *)ctx->datastack_region->start;
|
||||
cell *ds_bot = (cell *)ctx->datastack_seg->start;
|
||||
for(fixnum i = 0; i < saved_height - in; i++)
|
||||
{
|
||||
if(ds_bot[i] != array_nth(saved_datastack,i))
|
||||
|
@ -190,4 +225,22 @@ void factor_vm::primitive_load_locals()
|
|||
ctx->retainstack += sizeof(cell) * count;
|
||||
}
|
||||
|
||||
void factor_vm::primitive_current_context()
|
||||
{
|
||||
ctx->push(allot_alien(ctx));
|
||||
}
|
||||
|
||||
void factor_vm::primitive_start_context()
|
||||
{
|
||||
cell quot = ctx->pop();
|
||||
ctx = new_context();
|
||||
unwind_native_frames(quot,ctx->callstack_bottom);
|
||||
}
|
||||
|
||||
void factor_vm::primitive_delete_context()
|
||||
{
|
||||
context *old_context = (context *)pinned_alien_offset(ctx->pop());
|
||||
delete_context(old_context);
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
@ -6,12 +6,13 @@ static const cell context_object_count = 10;
|
|||
enum context_object {
|
||||
OBJ_NAMESTACK,
|
||||
OBJ_CATCHSTACK,
|
||||
OBJ_CONTEXT_ID,
|
||||
};
|
||||
|
||||
/* Assembly code makes assumptions about the layout of this struct */
|
||||
struct context {
|
||||
/* C stack pointer on entry */
|
||||
|
||||
// First 4 fields accessed directly by compiler. See basis/vm/vm.factor
|
||||
|
||||
/* Factor callstack pointers */
|
||||
stack_frame *callstack_top;
|
||||
stack_frame *callstack_bottom;
|
||||
|
||||
|
@ -21,22 +22,25 @@ struct context {
|
|||
/* current retain stack top pointer */
|
||||
cell retainstack;
|
||||
|
||||
/* memory region holding current datastack */
|
||||
segment *datastack_region;
|
||||
|
||||
/* memory region holding current retain stack */
|
||||
segment *retainstack_region;
|
||||
/* C callstack pointer */
|
||||
cell callstack_save;
|
||||
|
||||
/* context-specific special objects, accessed by context-object and
|
||||
set-context-object primitives */
|
||||
cell context_objects[context_object_count];
|
||||
|
||||
context *next;
|
||||
segment *datastack_seg;
|
||||
segment *retainstack_seg;
|
||||
segment *callstack_seg;
|
||||
|
||||
context(cell datastack_size, cell retainstack_size, cell callstack_size);
|
||||
~context();
|
||||
|
||||
context(cell ds_size, cell rs_size);
|
||||
void reset_datastack();
|
||||
void reset_retainstack();
|
||||
void reset_callstack();
|
||||
void reset_context_objects();
|
||||
void reset();
|
||||
|
||||
cell peek()
|
||||
{
|
||||
|
@ -65,17 +69,17 @@ struct context {
|
|||
|
||||
void fix_stacks()
|
||||
{
|
||||
if(datastack + sizeof(cell) < datastack_region->start
|
||||
|| datastack + stack_reserved >= datastack_region->end)
|
||||
if(datastack + sizeof(cell) < datastack_seg->start
|
||||
|| datastack + stack_reserved >= datastack_seg->end)
|
||||
reset_datastack();
|
||||
|
||||
if(retainstack + sizeof(cell) < retainstack_region->start
|
||||
|| retainstack + stack_reserved >= retainstack_region->end)
|
||||
if(retainstack + sizeof(cell) < retainstack_seg->start
|
||||
|| retainstack + stack_reserved >= retainstack_seg->end)
|
||||
reset_retainstack();
|
||||
}
|
||||
};
|
||||
|
||||
VM_C_API void nest_stacks(factor_vm *vm);
|
||||
VM_C_API void unnest_stacks(factor_vm *vm);
|
||||
VM_C_API void begin_callback(factor_vm *vm);
|
||||
VM_C_API void end_callback(factor_vm *vm);
|
||||
|
||||
}
|
||||
|
|
|
@ -3,6 +3,8 @@ namespace factor
|
|||
|
||||
#define FACTOR_CPU_STRING "ppc"
|
||||
|
||||
#define CALLSTACK_BOTTOM(ctx) (stack_frame *)ctx->callstack_seg->end
|
||||
|
||||
/* In the instruction sequence:
|
||||
|
||||
LOAD32 r3,...
|
||||
|
|
|
@ -5,6 +5,8 @@ namespace factor
|
|||
|
||||
#define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1)
|
||||
|
||||
#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell))
|
||||
|
||||
inline static void flush_icache(cell start, cell len) {}
|
||||
|
||||
/* In the instruction sequence:
|
||||
|
|
|
@ -159,7 +159,7 @@ cell object::size() const
|
|||
case WRAPPER_TYPE:
|
||||
return align(sizeof(wrapper),data_alignment);
|
||||
case CALLSTACK_TYPE:
|
||||
return align(callstack_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
|
||||
return align(callstack_object_size(untag_fixnum(((callstack *)this)->length)),data_alignment);
|
||||
default:
|
||||
critical_error("Invalid header",(cell)this);
|
||||
return 0; /* can't happen */
|
||||
|
|
|
@ -145,13 +145,13 @@ void factor_vm::print_objects(cell *start, cell *end)
|
|||
void factor_vm::print_datastack()
|
||||
{
|
||||
std::cout << "==== DATA STACK:\n";
|
||||
print_objects((cell *)ctx->datastack_region->start,(cell *)ctx->datastack);
|
||||
print_objects((cell *)ctx->datastack_seg->start,(cell *)ctx->datastack);
|
||||
}
|
||||
|
||||
void factor_vm::print_retainstack()
|
||||
{
|
||||
std::cout << "==== RETAIN STACK:\n";
|
||||
print_objects((cell *)ctx->retainstack_region->start,(cell *)ctx->retainstack);
|
||||
print_objects((cell *)ctx->retainstack_seg->start,(cell *)ctx->retainstack);
|
||||
}
|
||||
|
||||
struct stack_frame_printer {
|
||||
|
@ -421,9 +421,9 @@ void factor_vm::factorbug()
|
|||
else if(strcmp(cmd,"t") == 0)
|
||||
full_output = !full_output;
|
||||
else if(strcmp(cmd,"s") == 0)
|
||||
dump_memory(ctx->datastack_region->start,ctx->datastack);
|
||||
dump_memory(ctx->datastack_seg->start,ctx->datastack);
|
||||
else if(strcmp(cmd,"r") == 0)
|
||||
dump_memory(ctx->retainstack_region->start,ctx->retainstack);
|
||||
dump_memory(ctx->retainstack_seg->start,ctx->retainstack);
|
||||
else if(strcmp(cmd,".s") == 0)
|
||||
print_datastack();
|
||||
else if(strcmp(cmd,".r") == 0)
|
||||
|
|
|
@ -99,13 +99,13 @@ bool factor_vm::in_page(cell fault, cell area, cell area_size, int offset)
|
|||
|
||||
void factor_vm::memory_protection_error(cell addr, stack_frame *native_stack)
|
||||
{
|
||||
if(in_page(addr, ctx->datastack_region->start, 0, -1))
|
||||
if(in_page(addr, ctx->datastack_seg->start, 0, -1))
|
||||
general_error(ERROR_DS_UNDERFLOW,false_object,false_object,native_stack);
|
||||
else if(in_page(addr, ctx->datastack_region->start, ds_size, 0))
|
||||
else if(in_page(addr, ctx->datastack_seg->start, datastack_size, 0))
|
||||
general_error(ERROR_DS_OVERFLOW,false_object,false_object,native_stack);
|
||||
else if(in_page(addr, ctx->retainstack_region->start, 0, -1))
|
||||
else if(in_page(addr, ctx->retainstack_seg->start, 0, -1))
|
||||
general_error(ERROR_RS_UNDERFLOW,false_object,false_object,native_stack);
|
||||
else if(in_page(addr, ctx->retainstack_region->start, rs_size, 0))
|
||||
else if(in_page(addr, ctx->retainstack_seg->start, retainstack_size, 0))
|
||||
general_error(ERROR_RS_OVERFLOW,false_object,false_object,native_stack);
|
||||
else if(in_page(addr, nursery.end, 0, 0))
|
||||
critical_error("allot_object() missed GC check",0);
|
||||
|
|
|
@ -14,8 +14,9 @@ void factor_vm::default_parameters(vm_parameters *p)
|
|||
{
|
||||
p->image_path = NULL;
|
||||
|
||||
p->ds_size = 32 * sizeof(cell);
|
||||
p->rs_size = 32 * sizeof(cell);
|
||||
p->datastack_size = 32 * sizeof(cell);
|
||||
p->retainstack_size = 32 * sizeof(cell);
|
||||
p->callstack_size = 128 * sizeof(cell);
|
||||
|
||||
p->code_size = 8 * sizeof(cell);
|
||||
p->young_size = sizeof(cell) / 4;
|
||||
|
@ -59,8 +60,9 @@ void factor_vm::init_parameters_from_args(vm_parameters *p, int argc, vm_char **
|
|||
{
|
||||
vm_char *arg = argv[i];
|
||||
if(STRCMP(arg,STRING_LITERAL("--")) == 0) break;
|
||||
else if(factor_arg(arg,STRING_LITERAL("-datastack=%d"),&p->ds_size));
|
||||
else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->rs_size));
|
||||
else if(factor_arg(arg,STRING_LITERAL("-datastack=%d"),&p->datastack_size));
|
||||
else if(factor_arg(arg,STRING_LITERAL("-retainstack=%d"),&p->retainstack_size));
|
||||
else if(factor_arg(arg,STRING_LITERAL("-callstack=%d"),&p->callstack_size));
|
||||
else if(factor_arg(arg,STRING_LITERAL("-young=%d"),&p->young_size));
|
||||
else if(factor_arg(arg,STRING_LITERAL("-aging=%d"),&p->aging_size));
|
||||
else if(factor_arg(arg,STRING_LITERAL("-tenured=%d"),&p->tenured_size));
|
||||
|
@ -91,8 +93,9 @@ void factor_vm::prepare_boot_image()
|
|||
void factor_vm::init_factor(vm_parameters *p)
|
||||
{
|
||||
/* Kilobytes */
|
||||
p->ds_size = align_page(p->ds_size << 10);
|
||||
p->rs_size = align_page(p->rs_size << 10);
|
||||
p->datastack_size = align_page(p->datastack_size << 10);
|
||||
p->retainstack_size = align_page(p->retainstack_size << 10);
|
||||
p->callstack_size = align_page(p->retainstack_size << 10);
|
||||
p->callback_size = align_page(p->callback_size << 10);
|
||||
|
||||
/* Megabytes */
|
||||
|
@ -117,7 +120,7 @@ void factor_vm::init_factor(vm_parameters *p)
|
|||
|
||||
srand((unsigned int)system_micros());
|
||||
init_ffi();
|
||||
init_stacks(p->ds_size,p->rs_size);
|
||||
init_contexts(p->datastack_size,p->retainstack_size,p->callstack_size);
|
||||
init_callbacks(p->callback_size);
|
||||
load_image(p);
|
||||
init_c_io();
|
||||
|
@ -161,16 +164,12 @@ void factor_vm::start_factor(vm_parameters *p)
|
|||
{
|
||||
if(p->fep) factorbug();
|
||||
|
||||
nest_stacks();
|
||||
c_to_factor_toplevel(special_objects[OBJ_STARTUP_QUOT]);
|
||||
unnest_stacks();
|
||||
}
|
||||
|
||||
void factor_vm::stop_factor()
|
||||
{
|
||||
nest_stacks();
|
||||
c_to_factor_toplevel(special_objects[OBJ_SHUTDOWN_QUOT]);
|
||||
unnest_stacks();
|
||||
}
|
||||
|
||||
char *factor_vm::factor_eval_string(char *string)
|
||||
|
|
|
@ -30,7 +30,7 @@ struct image_header {
|
|||
struct vm_parameters {
|
||||
const vm_char *image_path;
|
||||
const vm_char *executable_path;
|
||||
cell ds_size, rs_size;
|
||||
cell datastack_size, retainstack_size, callstack_size;
|
||||
cell young_size, aging_size, tenured_size;
|
||||
cell code_size;
|
||||
bool fep;
|
||||
|
|
|
@ -2,157 +2,159 @@ namespace factor
|
|||
{
|
||||
|
||||
/* Generated with PRIMITIVE in primitives.cpp */
|
||||
#define EACH_PRIMITIVE(_) \
|
||||
_(alien_address) \
|
||||
_(all_instances) \
|
||||
_(array) \
|
||||
_(array_to_quotation) \
|
||||
_(become) \
|
||||
_(bignum_add) \
|
||||
_(bignum_and) \
|
||||
_(bignum_bitp) \
|
||||
_(bignum_divint) \
|
||||
_(bignum_divmod) \
|
||||
_(bignum_eq) \
|
||||
_(bignum_greater) \
|
||||
_(bignum_greatereq) \
|
||||
_(bignum_less) \
|
||||
_(bignum_lesseq) \
|
||||
_(bignum_log2) \
|
||||
_(bignum_mod) \
|
||||
_(bignum_multiply) \
|
||||
_(bignum_not) \
|
||||
_(bignum_or) \
|
||||
_(bignum_shift) \
|
||||
_(bignum_subtract) \
|
||||
_(bignum_to_fixnum) \
|
||||
_(bignum_to_float) \
|
||||
_(bignum_xor) \
|
||||
_(bits_double) \
|
||||
_(bits_float) \
|
||||
_(byte_array) \
|
||||
_(byte_array_to_bignum) \
|
||||
_(call_clear) \
|
||||
_(callback) \
|
||||
_(callstack) \
|
||||
_(callstack_to_array) \
|
||||
_(check_datastack) \
|
||||
_(clone) \
|
||||
_(code_blocks) \
|
||||
_(code_room) \
|
||||
_(compact_gc) \
|
||||
_(compute_identity_hashcode) \
|
||||
_(context_object) \
|
||||
_(data_room) \
|
||||
_(datastack) \
|
||||
_(die) \
|
||||
_(disable_gc_events) \
|
||||
_(dispatch_stats) \
|
||||
_(displaced_alien) \
|
||||
_(dlclose) \
|
||||
_(dll_validp) \
|
||||
_(dlopen) \
|
||||
_(dlsym) \
|
||||
_(double_bits) \
|
||||
_(enable_gc_events) \
|
||||
_(existsp) \
|
||||
_(exit) \
|
||||
_(fclose) \
|
||||
_(fflush) \
|
||||
_(fgetc) \
|
||||
_(fixnum_divint) \
|
||||
_(fixnum_divmod) \
|
||||
_(fixnum_shift) \
|
||||
_(fixnum_to_bignum) \
|
||||
_(fixnum_to_float) \
|
||||
_(float_add) \
|
||||
_(float_bits) \
|
||||
_(float_divfloat) \
|
||||
_(float_eq) \
|
||||
_(float_greater) \
|
||||
_(float_greatereq) \
|
||||
_(float_less) \
|
||||
_(float_lesseq) \
|
||||
_(float_mod) \
|
||||
_(float_multiply) \
|
||||
_(float_subtract) \
|
||||
_(float_to_bignum) \
|
||||
_(float_to_fixnum) \
|
||||
_(float_to_str) \
|
||||
_(fopen) \
|
||||
_(fputc) \
|
||||
_(fread) \
|
||||
_(fseek) \
|
||||
_(ftell) \
|
||||
_(full_gc) \
|
||||
_(fwrite) \
|
||||
_(identity_hashcode) \
|
||||
_(innermost_stack_frame_executing) \
|
||||
_(innermost_stack_frame_scan) \
|
||||
_(jit_compile) \
|
||||
_(load_locals) \
|
||||
_(lookup_method) \
|
||||
_(mega_cache_miss) \
|
||||
_(minor_gc) \
|
||||
_(modify_code_heap) \
|
||||
_(nano_count) \
|
||||
_(optimized_p) \
|
||||
_(profiling) \
|
||||
_(quot_compiled_p) \
|
||||
_(quotation_code) \
|
||||
_(reset_dispatch_stats) \
|
||||
_(resize_array) \
|
||||
_(resize_byte_array) \
|
||||
_(resize_string) \
|
||||
_(retainstack) \
|
||||
_(save_image) \
|
||||
_(save_image_and_exit) \
|
||||
_(set_context_object) \
|
||||
_(set_datastack) \
|
||||
_(set_innermost_stack_frame_quot) \
|
||||
_(set_retainstack) \
|
||||
_(set_slot) \
|
||||
_(set_special_object) \
|
||||
_(set_string_nth_fast) \
|
||||
_(set_string_nth_slow) \
|
||||
_(size) \
|
||||
_(sleep) \
|
||||
_(special_object) \
|
||||
_(string) \
|
||||
_(string_nth) \
|
||||
_(strip_stack_traces) \
|
||||
_(system_micros) \
|
||||
_(tuple) \
|
||||
_(tuple_boa) \
|
||||
_(unimplemented) \
|
||||
_(uninitialized_byte_array) \
|
||||
_(word) \
|
||||
_(word_code) \
|
||||
_(wrapper)
|
||||
|
||||
/* These are generated with macros in alien.cpp, and not with PRIMIIVE in
|
||||
primitives.cpp */
|
||||
#define EACH_PRIMITIVE(_) \
|
||||
_(alien_address) \
|
||||
_(all_instances) \
|
||||
_(array) \
|
||||
_(array_to_quotation) \
|
||||
_(become) \
|
||||
_(bignum_add) \
|
||||
_(bignum_and) \
|
||||
_(bignum_bitp) \
|
||||
_(bignum_divint) \
|
||||
_(bignum_divmod) \
|
||||
_(bignum_eq) \
|
||||
_(bignum_greater) \
|
||||
_(bignum_greatereq) \
|
||||
_(bignum_less) \
|
||||
_(bignum_lesseq) \
|
||||
_(bignum_log2) \
|
||||
_(bignum_mod) \
|
||||
_(bignum_multiply) \
|
||||
_(bignum_not) \
|
||||
_(bignum_or) \
|
||||
_(bignum_shift) \
|
||||
_(bignum_subtract) \
|
||||
_(bignum_to_fixnum) \
|
||||
_(bignum_to_float) \
|
||||
_(bignum_xor) \
|
||||
_(bits_double) \
|
||||
_(bits_float) \
|
||||
_(byte_array) \
|
||||
_(byte_array_to_bignum) \
|
||||
_(call_clear) \
|
||||
_(callback) \
|
||||
_(callstack) \
|
||||
_(callstack_to_array) \
|
||||
_(check_datastack) \
|
||||
_(clone) \
|
||||
_(code_blocks) \
|
||||
_(code_room) \
|
||||
_(compact_gc) \
|
||||
_(compute_identity_hashcode) \
|
||||
_(context_object) \
|
||||
_(current_callback) \
|
||||
_(current_context) \
|
||||
_(data_room) \
|
||||
_(datastack) \
|
||||
_(delete_context) \
|
||||
_(die) \
|
||||
_(disable_gc_events) \
|
||||
_(dispatch_stats) \
|
||||
_(displaced_alien) \
|
||||
_(dlclose) \
|
||||
_(dll_validp) \
|
||||
_(dlopen) \
|
||||
_(dlsym) \
|
||||
_(double_bits) \
|
||||
_(enable_gc_events) \
|
||||
_(existsp) \
|
||||
_(exit) \
|
||||
_(fclose) \
|
||||
_(fflush) \
|
||||
_(fgetc) \
|
||||
_(fixnum_divint) \
|
||||
_(fixnum_divmod) \
|
||||
_(fixnum_shift) \
|
||||
_(fixnum_to_bignum) \
|
||||
_(fixnum_to_float) \
|
||||
_(float_add) \
|
||||
_(float_bits) \
|
||||
_(float_divfloat) \
|
||||
_(float_eq) \
|
||||
_(float_greater) \
|
||||
_(float_greatereq) \
|
||||
_(float_less) \
|
||||
_(float_lesseq) \
|
||||
_(float_mod) \
|
||||
_(float_multiply) \
|
||||
_(float_subtract) \
|
||||
_(float_to_bignum) \
|
||||
_(float_to_fixnum) \
|
||||
_(float_to_str) \
|
||||
_(fopen) \
|
||||
_(fputc) \
|
||||
_(fread) \
|
||||
_(fseek) \
|
||||
_(ftell) \
|
||||
_(full_gc) \
|
||||
_(fwrite) \
|
||||
_(identity_hashcode) \
|
||||
_(innermost_stack_frame_executing) \
|
||||
_(innermost_stack_frame_scan) \
|
||||
_(jit_compile) \
|
||||
_(load_locals) \
|
||||
_(lookup_method) \
|
||||
_(mega_cache_miss) \
|
||||
_(minor_gc) \
|
||||
_(modify_code_heap) \
|
||||
_(nano_count) \
|
||||
_(optimized_p) \
|
||||
_(profiling) \
|
||||
_(quot_compiled_p) \
|
||||
_(quotation_code) \
|
||||
_(reset_dispatch_stats) \
|
||||
_(resize_array) \
|
||||
_(resize_byte_array) \
|
||||
_(resize_string) \
|
||||
_(retainstack) \
|
||||
_(save_image) \
|
||||
_(save_image_and_exit) \
|
||||
_(set_context_object) \
|
||||
_(set_datastack) \
|
||||
_(set_innermost_stack_frame_quot) \
|
||||
_(set_retainstack) \
|
||||
_(set_slot) \
|
||||
_(set_special_object) \
|
||||
_(set_string_nth_fast) \
|
||||
_(set_string_nth_slow) \
|
||||
_(size) \
|
||||
_(sleep) \
|
||||
_(special_object) \
|
||||
_(start_context) \
|
||||
_(string) \
|
||||
_(string_nth) \
|
||||
_(strip_stack_traces) \
|
||||
_(system_micros) \
|
||||
_(tuple) \
|
||||
_(tuple_boa) \
|
||||
_(unimplemented) \
|
||||
_(uninitialized_byte_array) \
|
||||
_(word) \
|
||||
_(word_code) \
|
||||
_(wrapper)
|
||||
|
||||
#define EACH_ALIEN_PRIMITIVE(_) \
|
||||
_(signed_cell,fixnum,from_signed_cell,to_fixnum) \
|
||||
_(unsigned_cell,cell,from_unsigned_cell,to_cell) \
|
||||
_(signed_8,s64,from_signed_8,to_signed_8) \
|
||||
_(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
|
||||
_(signed_4,s32,from_signed_4,to_fixnum) \
|
||||
_(unsigned_4,u32,from_unsigned_4,to_cell) \
|
||||
_(signed_2,s16,from_signed_2,to_fixnum) \
|
||||
_(unsigned_2,u16,from_unsigned_2,to_cell) \
|
||||
_(signed_1,s8,from_signed_1,to_fixnum) \
|
||||
_(unsigned_1,u8,from_unsigned_1,to_cell) \
|
||||
_(float,float,from_float,to_float) \
|
||||
_(double,double,from_double,to_double) \
|
||||
_(cell,void *,allot_alien,pinned_alien_offset)
|
||||
_(signed_cell,fixnum,from_signed_cell,to_fixnum) \
|
||||
_(unsigned_cell,cell,from_unsigned_cell,to_cell) \
|
||||
_(signed_8,s64,from_signed_8,to_signed_8) \
|
||||
_(unsigned_8,u64,from_unsigned_8,to_unsigned_8) \
|
||||
_(signed_4,s32,from_signed_4,to_fixnum) \
|
||||
_(unsigned_4,u32,from_unsigned_4,to_cell) \
|
||||
_(signed_2,s16,from_signed_2,to_fixnum) \
|
||||
_(unsigned_2,u16,from_unsigned_2,to_cell) \
|
||||
_(signed_1,s8,from_signed_1,to_fixnum) \
|
||||
_(unsigned_1,u8,from_unsigned_1,to_cell) \
|
||||
_(float,float,from_float,to_float) \
|
||||
_(double,double,from_double,to_double) \
|
||||
_(cell,void *,allot_alien,pinned_alien_offset)
|
||||
|
||||
#define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
|
||||
|
||||
#define DECLARE_ALIEN_PRIMITIVE(name, type, from, to) \
|
||||
DECLARE_PRIMITIVE(alien_##name) \
|
||||
DECLARE_PRIMITIVE(set_alien_##name)
|
||||
DECLARE_PRIMITIVE(alien_##name) \
|
||||
DECLARE_PRIMITIVE(set_alien_##name)
|
||||
|
||||
EACH_PRIMITIVE(DECLARE_PRIMITIVE)
|
||||
EACH_ALIEN_PRIMITIVE(DECLARE_ALIEN_PRIMITIVE)
|
||||
|
|
|
@ -170,15 +170,17 @@ void slot_visitor<Visitor>::visit_roots()
|
|||
template<typename Visitor>
|
||||
void slot_visitor<Visitor>::visit_contexts()
|
||||
{
|
||||
context *ctx = parent->ctx;
|
||||
|
||||
while(ctx)
|
||||
std::set<context *>::const_iterator begin = parent->active_contexts.begin();
|
||||
std::set<context *>::const_iterator end = parent->active_contexts.end();
|
||||
while(begin != end)
|
||||
{
|
||||
visit_stack_elements(ctx->datastack_region,(cell *)ctx->datastack);
|
||||
visit_stack_elements(ctx->retainstack_region,(cell *)ctx->retainstack);
|
||||
context *ctx = *begin;
|
||||
|
||||
visit_stack_elements(ctx->datastack_seg,(cell *)ctx->datastack);
|
||||
visit_stack_elements(ctx->retainstack_seg,(cell *)ctx->retainstack);
|
||||
visit_object_array(ctx->context_objects,ctx->context_objects + context_object_count);
|
||||
|
||||
ctx = ctx->next;
|
||||
begin++;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
@ -5,6 +5,7 @@ namespace factor
|
|||
|
||||
factor_vm::factor_vm() :
|
||||
nursery(0,0),
|
||||
callback_id(0),
|
||||
c_to_factor_func(NULL),
|
||||
profiling_p(false),
|
||||
gc_off(false),
|
||||
|
@ -17,4 +18,9 @@ factor_vm::factor_vm() :
|
|||
primitive_reset_dispatch_stats();
|
||||
}
|
||||
|
||||
factor_vm::~factor_vm()
|
||||
{
|
||||
delete_contexts();
|
||||
}
|
||||
|
||||
}
|
||||
|
|
52
vm/vm.hpp
52
vm/vm.hpp
|
@ -6,11 +6,14 @@ struct code_root;
|
|||
|
||||
struct factor_vm
|
||||
{
|
||||
// First five fields accessed directly by assembler. See vm.factor
|
||||
// First 5 fields accessed directly by compiler. See basis/vm/vm.factor
|
||||
|
||||
/* Current stacks */
|
||||
/* Current context */
|
||||
context *ctx;
|
||||
|
||||
|
||||
/* Spare context -- for callbacks */
|
||||
context *spare_ctx;
|
||||
|
||||
/* New objects are allocated here */
|
||||
nursery_space nursery;
|
||||
|
||||
|
@ -23,10 +26,19 @@ struct factor_vm
|
|||
cell special_objects[special_object_count];
|
||||
|
||||
/* Data stack and retain stack sizes */
|
||||
cell ds_size, rs_size;
|
||||
cell datastack_size, retainstack_size, callstack_size;
|
||||
|
||||
/* Pooling unused contexts to make callbacks cheaper */
|
||||
context *unused_contexts;
|
||||
/* Stack of callback IDs */
|
||||
std::vector<int> callback_ids;
|
||||
|
||||
/* Next callback ID */
|
||||
int callback_id;
|
||||
|
||||
/* Pooling unused contexts to make context allocation cheaper */
|
||||
std::vector<context *> unused_contexts;
|
||||
|
||||
/* Active contexts, for tracing by the GC */
|
||||
std::set<context *> active_contexts;
|
||||
|
||||
/* Canonical truth value. In Factor, 't' */
|
||||
cell true_object;
|
||||
|
@ -96,11 +108,13 @@ struct factor_vm
|
|||
u64 last_nano_count;
|
||||
|
||||
// contexts
|
||||
context *alloc_context();
|
||||
void dealloc_context(context *old_context);
|
||||
void nest_stacks();
|
||||
void unnest_stacks();
|
||||
void init_stacks(cell ds_size_, cell rs_size_);
|
||||
context *new_context();
|
||||
void delete_context(context *old_context);
|
||||
void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_);
|
||||
void delete_contexts();
|
||||
void begin_callback();
|
||||
void end_callback();
|
||||
void primitive_current_callback();
|
||||
void primitive_context_object();
|
||||
void primitive_set_context_object();
|
||||
bool stack_to_array(cell bottom, cell top);
|
||||
|
@ -111,16 +125,15 @@ struct factor_vm
|
|||
void primitive_set_retainstack();
|
||||
void primitive_check_datastack();
|
||||
void primitive_load_locals();
|
||||
void primitive_current_context();
|
||||
void primitive_start_context();
|
||||
void primitive_delete_context();
|
||||
|
||||
template<typename Iterator> void iterate_active_frames(Iterator &iter)
|
||||
template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
|
||||
{
|
||||
context *ctx = this->ctx;
|
||||
|
||||
while(ctx)
|
||||
{
|
||||
iterate_callstack(ctx,iter);
|
||||
ctx = ctx->next;
|
||||
}
|
||||
std::set<context *>::const_iterator begin = active_contexts.begin();
|
||||
std::set<context *>::const_iterator end = active_contexts.end();
|
||||
while(begin != end) iterate_callstack(*begin++,iter);
|
||||
}
|
||||
|
||||
// run
|
||||
|
@ -694,6 +707,7 @@ struct factor_vm
|
|||
#endif
|
||||
|
||||
factor_vm();
|
||||
~factor_vm();
|
||||
|
||||
};
|
||||
|
||||
|
|
Loading…
Reference in New Issue