steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of factorcode.org:/git/factor

release
Joe Groff 2010-03-26 20:09:38 -07:00
parent dbebe044c9 e6a15c0b33
commit d3767a7f27
42 changed files with 841 additions and 680 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/bootstrap/image/image.factor
View File

@ -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

4
basis/command-line/command-line-docs.factor
View File

@ -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:"

6
basis/compiler/alien/alien.factor
View File

@ -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 )

5
basis/compiler/codegen/codegen.factor
View File

@ -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 ;

2
basis/compiler/constants/constants.factor
View File

@ -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

17
basis/compiler/tests/alien.factor
View File

@ -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 ( ) ;

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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" } } ] [

17
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -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

8
basis/cpu/architecture/architecture.factor
View File

@ -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 )

10
basis/cpu/ppc/bootstrap.factor
View File

@ -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
]

10
basis/cpu/ppc/ppc.factor
View File

@ -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 {

22
basis/cpu/x86/32/32.factor
View File

@ -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

46
basis/cpu/x86/32/bootstrap.factor
View File

@ -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

34
basis/cpu/x86/64/64.factor
View File

@ -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 ;

56
basis/cpu/x86/64/bootstrap.factor
View File

@ -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

54
basis/cpu/x86/bootstrap.factor
View File

@ -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
[

3
basis/cpu/x86/x86.factor
View File

@ -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 ;

39
basis/stack-checker/known-words/known-words.factor
View File

@ -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

8
basis/vm/vm.factor
View File

@ -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 }

23
core/alien/alien.factor
View File

@ -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

5
core/bootstrap/primitives.factor
View File

@ -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" (( ? -- )) }

15
core/lexer/lexer.factor
View File

@ -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 )

514
core/parser/parser-tests.factor
View File

@ -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( -- )

4
core/syntax/syntax.factor
View File

@ -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:" [

2
extra/websites/concatenative/page.css
View File

@ -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;

3
vm/callbacks.cpp
View File

@ -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);

2
vm/callstack.cpp
View File

@ -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;
}

2
vm/callstack.hpp
View File

@ -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;
}

2
vm/code_block_visitor.hpp
View File

@ -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
View File

@ -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);
}
}

36
vm/contexts.hpp
View File

@ -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);
}

2
vm/cpu-ppc.hpp
View File

@ -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,...

2
vm/cpu-x86.hpp
View File

@ -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:

2
vm/data_heap.cpp
View File

@ -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 */

8
vm/debug.cpp
View File

@ -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)

8
vm/errors.cpp
View File

@ -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);

21
vm/factor.cpp
View File

@ -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)

2
vm/image.hpp
View File

@ -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;

290
vm/primitives.hpp
View File

@ -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)

14
vm/slot_visitor.hpp
View File

@ -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++;
}
}

6
vm/vm.cpp
View File

@ -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
View File

@ -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();
};