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-04-01 21:59:10 -07:00
parent fa49520cbf 279ff3a7d3
commit 3ea0a490fb
34 changed files with 176 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/boxes/boxes.factor
View File

@ -11,7 +11,7 @@ ERROR: box-full box ;
: >box ( value box -- ) : >box ( value box -- )
dup occupied>> dup occupied>>
[ box-full ] [ t >>occupied (>>value) ] if ; [ box-full ] [ t >>occupied (>>value) ] if ; inline
ERROR: box-empty box ; ERROR: box-empty box ;
@ -19,10 +19,10 @@ ERROR: box-empty box ;
dup occupied>> [ box-empty ] unless ; inline dup occupied>> [ box-empty ] unless ; inline
: box> ( box -- value ) : box> ( box -- value )
check-box [ f ] change-value f >>occupied drop ; check-box [ f ] change-value f >>occupied drop ; inline
: ?box ( box -- value/f ? ) : ?box ( box -- value/f ? )
dup occupied>> [ box> t ] [ drop f f ] if ; dup occupied>> [ box> t ] [ drop f f ] if ; inline
: if-box? ( box quot -- ) : if-box? ( box quot -- )
[ ?box ] dip [ drop ] if ; inline [ ?box ] dip [ drop ] if ; inline

8
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -202,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot insn-slot# slot>> constant ;
M: ##set-slot-imm insn-slot# slot>> ; M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field-ptr insn-slot# field-name>> ; M: ##vm-field insn-slot# offset>> ;
M: ##set-vm-field insn-slot# offset>> ;
M: ##slot insn-object obj>> resolve ; M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ; M: ##alien-global insn-object drop \ ##alien-global ;
M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ; M: ##vm-field insn-object drop \ ##vm-field ;
M: ##set-vm-field insn-object drop \ ##vm-field ;
: init-alias-analysis ( insns -- insns' ) : init-alias-analysis ( insns -- insns' )
H{ } clone histories set H{ } clone histories set
@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
0 ac-counter set 0 ac-counter set
next-ac heap-ac set next-ac heap-ac set
\ ##vm-field-ptr set-new-ac \ ##vm-field set-new-ac
\ ##alien-global set-new-ac \ ##alien-global set-new-ac
dup local-live-in [ set-heap-ac ] each ; dup local-live-in [ set-heap-ac ] each ;

14
basis/compiler/cfg/instructions/instructions.factor
View File

@ -660,13 +660,13 @@ INSN: ##alien-global
def: dst/int-rep def: dst/int-rep
literal: symbol library ; literal: symbol library ;
INSN: ##vm-field-ptr
def: dst/int-rep
literal: field-name ;
INSN: ##vm-field INSN: ##vm-field
def: dst/int-rep def: dst/int-rep
literal: field-name ; literal: offset ;
INSN: ##set-vm-field
use: src/int-rep
literal: offset ;
! FFI ! FFI
INSN: ##alien-invoke INSN: ##alien-invoke
@ -835,8 +835,8 @@ UNION: ##allocation
##box-displaced-alien ; ##box-displaced-alien ;
! For alias analysis ! For alias analysis
UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ; UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ; UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that kill all live vregs but cannot trigger GC ! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn UNION: partial-sync-insn

1
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -32,6 +32,7 @@ IN: compiler.cfg.intrinsics
{ kernel.private:tag [ drop emit-tag ] } { kernel.private:tag [ drop emit-tag ] }
{ kernel.private:context-object [ emit-context-object ] } { kernel.private:context-object [ emit-context-object ] }
{ kernel.private:special-object [ emit-special-object ] } { kernel.private:special-object [ emit-special-object ] }
{ kernel.private:set-special-object [ emit-set-special-object ] }
{ kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] } { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] } { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ math.private:fixnum+ [ drop emit-fixnum+ ] } { math.private:fixnum+ [ drop emit-fixnum+ ] }

25
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -1,30 +1,39 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces layouts sequences kernel math accessors USING: namespaces layouts sequences kernel math accessors
compiler.tree.propagation.info compiler.cfg.stacks compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.instructions compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.builder.blocks compiler.cfg.builder.blocks
compiler.cfg.utilities ; compiler.cfg.utilities ;
FROM: vm => context-field-offset ; FROM: vm => context-field-offset vm-field-offset ;
IN: compiler.cfg.intrinsics.misc IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- ) : emit-tag ( -- )
ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
: special-object-offset ( n -- offset )
cells "special-objects" vm-field-offset + ;
: emit-special-object ( node -- ) : emit-special-object ( node -- )
dup node-input-infos first literal>> [ dup node-input-infos first literal>> [
"special-objects" ^^vm-field-ptr ds-drop
ds-drop swap 0 ^^slot-imm special-object-offset ^^vm-field
ds-push ds-push
] [ emit-primitive ] ?if ; ] [ emit-primitive ] ?if ;
: context-object-offset ( -- n ) : emit-set-special-object ( node -- )
"context-objects" context-field-offset cell /i ; dup node-input-infos second literal>> [
ds-drop
[ ds-pop ] dip special-object-offset ##set-vm-field
] [ emit-primitive ] ?if ;
: context-object-offset ( n -- n )
cells "context-objects" context-field-offset + ;
: emit-context-object ( node -- ) : emit-context-object ( node -- )
dup node-input-infos first literal>> [ dup node-input-infos first literal>> [
"ctx" ^^vm-field "ctx" vm-field-offset ^^vm-field
ds-drop swap context-object-offset + 0 ^^slot-imm ds-push ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
] [ emit-primitive ] ?if ; ] [ emit-primitive ] ?if ;
: emit-identity-hashcode ( -- ) : emit-identity-hashcode ( -- )

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

@ -210,8 +210,8 @@ CODEGEN: ##compare-imm %compare-imm
CODEGEN: ##compare-float-ordered %compare-float-ordered CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context CODEGEN: ##save-context %save-context
CODEGEN: ##vm-field-ptr %vm-field-ptr
CODEGEN: ##vm-field %vm-field CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: _fixnum-add %fixnum-add CODEGEN: _fixnum-add %fixnum-add
CODEGEN: _fixnum-sub %fixnum-sub CODEGEN: _fixnum-sub %fixnum-sub

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

@ -432,14 +432,17 @@ STRUCT: double-rect
void { void* void* double-rect } "cdecl" void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ; [ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' ) : double-rect-test ( arg callback -- arg' )
f f rot [ f f ] 2dip
double-rect-callback
void { void* void* double-rect } "cdecl" alien-indirect void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ; "example" get-global ;
[ 1.0 2.0 3.0 4.0 ] [ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test [
1.0 2.0 3.0 4.0 <double-rect>
double-rect-callback double-rect-test
>double-rect<
] unit-test
STRUCT: test_struct_14 STRUCT: test_struct_14
{ x1 double } { x1 double }

8
basis/concurrency/conditions/conditions.factor
View File

@ -4,10 +4,10 @@ USING: deques threads kernel arrays sequences alarms fry ;
IN: concurrency.conditions IN: concurrency.conditions
: notify-1 ( deque -- ) : notify-1 ( deque -- )
dup deque-empty? [ drop ] [ pop-back resume-now ] if ; dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline
: notify-all ( deque -- ) : notify-all ( deque -- )
[ resume-now ] slurp-deque ; [ resume-now ] slurp-deque ; inline
: queue-timeout ( queue timeout -- alarm ) : queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the #! Add an alarm which removes the current thread from the
@ -23,7 +23,7 @@ IN: concurrency.conditions
ERROR: wait-timeout ; ERROR: wait-timeout ;
: queue ( queue -- ) : queue ( queue -- )
[ self ] dip push-front ; [ self ] dip push-front ; inline
: wait ( queue timeout status -- ) : wait ( queue timeout status -- )
over [ over [
@ -31,4 +31,4 @@ ERROR: wait-timeout ;
[ wait-timeout ] [ cancel-alarm ] if [ wait-timeout ] [ cancel-alarm ] if
] [ ] [
[ drop queue ] dip suspend drop [ drop queue ] dip suspend drop
] if ; ] if ; inline

21
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -6,22 +6,24 @@ concurrency.conditions accessors debugger debugger.threads
locals fry ; locals fry ;
IN: concurrency.mailboxes IN: concurrency.mailboxes
TUPLE: mailbox threads data ; TUPLE: mailbox { threads dlist } { data dlist } ;
: <mailbox> ( -- mailbox ) : <mailbox> ( -- mailbox )
mailbox new mailbox new
<dlist> >>threads <dlist> >>threads
<dlist> >>data ; <dlist> >>data ; inline
: mailbox-empty? ( mailbox -- bool ) : mailbox-empty? ( mailbox -- bool )
data>> deque-empty? ; data>> deque-empty? ; inline
: mailbox-put ( obj mailbox -- ) GENERIC: mailbox-put ( obj mailbox -- )
M: mailbox mailbox-put
[ data>> push-front ] [ data>> push-front ]
[ threads>> notify-all ] bi yield ; [ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- ) : wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ; [ threads>> ] dip "mailbox" wait ; inline
:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... ) :: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
mailbox data>> pred dlist-any? [ mailbox data>> pred dlist-any? [
@ -34,16 +36,17 @@ TUPLE: mailbox threads data ;
2dup wait-for-mailbox block-if-empty 2dup wait-for-mailbox block-if-empty
] [ ] [
drop drop
] if ; ] if ; inline recursive
: mailbox-peek ( mailbox -- obj ) : mailbox-peek ( mailbox -- obj )
data>> peek-back ; data>> peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj ) GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
block-if-empty data>> pop-back ;
M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj ) : mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ; f mailbox-get-timeout ; inline
: mailbox-get-all-timeout ( mailbox timeout -- array ) : mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty block-if-empty

20
basis/concurrency/messaging/messaging.factor
View File

@ -1,20 +1,22 @@
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. ! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel threads concurrency.mailboxes continuations USING: kernel kernel.private threads concurrency.mailboxes
namespaces assocs accessors summary fry ; continuations namespaces assocs accessors summary fry ;
IN: concurrency.messaging IN: concurrency.messaging
GENERIC: send ( message thread -- ) GENERIC: send ( message thread -- )
: mailbox-of ( thread -- mailbox ) GENERIC: mailbox-of ( thread -- mailbox )
dup mailbox>> [ ] [
<mailbox> [ >>mailbox drop ] keep M: thread mailbox-of
] ?if ; dup mailbox>>
[ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
M: thread send ( message thread -- ) M: thread send ( message thread -- )
check-registered mailbox-of mailbox-put ; mailbox-of mailbox-put ;
: my-mailbox ( -- mailbox ) self mailbox-of ; : my-mailbox ( -- mailbox ) self mailbox-of ; inline
: receive ( -- message ) : receive ( -- message )
my-mailbox mailbox-get ?linked ; my-mailbox mailbox-get ?linked ;

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

@ -447,8 +447,10 @@ HOOK: %set-alien-double cpu ( ptr offset value -- )
HOOK: %set-alien-vector cpu ( ptr offset value rep -- ) HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- ) HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field cpu ( dst fieldname -- ) HOOK: %vm-field cpu ( dst offset -- )
HOOK: %vm-field-ptr cpu ( dst fieldname -- ) HOOK: %set-vm-field cpu ( src offset -- )
: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- ) HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src slot temp1 temp2 -- ) HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )

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

@ -76,9 +76,12 @@ CONSTANT: nv-reg 17
432 save-at ; 432 save-at ;
[ [
! Save old stack pointer
11 1 MR
! Create stack frame ! Create stack frame
0 MFLR 0 MFLR
1 1 callback-frame-size neg STWU 1 1 callback-frame-size SUBI
0 1 callback-frame-size lr-save + STW 0 1 callback-frame-size lr-save + STW
! Save all non-volatile registers ! Save all non-volatile registers
@ -86,6 +89,10 @@ CONSTANT: nv-reg 17
nv-fp-regs [ 8 * 80 + save-fp ] each-index nv-fp-regs [ 8 * 80 + save-fp ] each-index
nv-vec-regs [ 16 * 224 + save-vec ] each-index nv-vec-regs [ 16 * 224 + save-vec ] each-index
! Stick old stack pointer in a non-volatile register so that
! callbacks can access their arguments
nv-reg 11 MR
! Load VM into vm-reg ! Load VM into vm-reg
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
@ -126,7 +133,7 @@ CONSTANT: nv-reg 17
! Tear down stack frame and return ! Tear down stack frame and return
0 1 callback-frame-size lr-save + LWZ 0 1 callback-frame-size lr-save + LWZ
1 1 0 LWZ 1 1 callback-frame-size ADDI
0 MTLR 0 MTLR
BLR BLR
] callback-stub jit-define ] callback-stub jit-define

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

@ -58,11 +58,9 @@ CONSTANT: vm-reg 15
: %load-vm-addr ( reg -- ) vm-reg MR ; : %load-vm-addr ( reg -- ) vm-reg MR ;
M: ppc %vm-field ( dst field -- ) M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
[ vm-reg ] dip vm-field-offset LWZ ;
M: ppc %vm-field-ptr ( dst field -- ) M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
[ vm-reg ] dip vm-field-offset ADDI ;
GENERIC: loc-reg ( loc -- reg ) GENERIC: loc-reg ( loc -- reg )
@ -385,7 +383,7 @@ M: ppc %set-alien-float -rot STFS ;
M: ppc %set-alien-double -rot STFD ; M: ppc %set-alien-double -rot STFD ;
: load-zone-ptr ( reg -- ) : load-zone-ptr ( reg -- )
"nursery" %vm-field-ptr ; vm-reg "nursery" vm-field-offset ADDI ;
: load-allot-ptr ( nursery-ptr allot-ptr -- ) : load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ; [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
@ -567,8 +565,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
} case ; } case ;
: next-param@ ( n -- reg x ) : next-param@ ( n -- reg x )
2 1 stack-frame get total-size>> LWZ [ 17 ] dip param@ ;
[ 2 ] dip param@ ;
: store-to-frame ( src n rep -- ) : store-to-frame ( src n rep -- )
{ {
@ -604,14 +601,14 @@ M: ppc %push-stack ( -- )
int-regs return-reg ds-reg 0 STW ; int-regs return-reg ds-reg 0 STW ;
M: ppc %push-context-stack ( -- ) M: ppc %push-context-stack ( -- )
11 "ctx" %vm-field 11 %context
12 11 "datastack" context-field-offset LWZ 12 11 "datastack" context-field-offset LWZ
12 12 4 ADDI 12 12 4 ADDI
12 11 "datastack" context-field-offset STW 12 11 "datastack" context-field-offset STW
int-regs return-reg 12 0 STW ; int-regs return-reg 12 0 STW ;
M: ppc %pop-context-stack ( -- ) M: ppc %pop-context-stack ( -- )
11 "ctx" %vm-field 11 %context
12 11 "datastack" context-field-offset LWZ 12 11 "datastack" context-field-offset LWZ
int-regs return-reg 12 0 LWZ int-regs return-reg 12 0 LWZ
12 12 4 SUBI 12 12 4 SUBI
@ -677,12 +674,12 @@ M: ppc %box-large-struct ( n c-type -- )
"from_value_struct" f %alien-invoke ; "from_value_struct" f %alien-invoke ;
M:: ppc %restore-context ( temp1 temp2 -- ) M:: ppc %restore-context ( temp1 temp2 -- )
temp1 "ctx" %vm-field temp1 %context
ds-reg temp1 "datastack" context-field-offset LWZ ds-reg temp1 "datastack" context-field-offset LWZ
rs-reg temp1 "retainstack" context-field-offset LWZ ; rs-reg temp1 "retainstack" context-field-offset LWZ ;
M:: ppc %save-context ( temp1 temp2 -- ) M:: ppc %save-context ( temp1 temp2 -- )
temp1 "ctx" %vm-field temp1 %context
1 temp1 "callstack-top" context-field-offset STW 1 temp1 "callstack-top" context-field-offset STW
ds-reg temp1 "datastack" context-field-offset STW ds-reg temp1 "datastack" context-field-offset STW
rs-reg temp1 "retainstack" context-field-offset STW ; rs-reg temp1 "retainstack" context-field-offset STW ;
@ -749,14 +746,14 @@ M: ppc %alien-callback ( quot -- )
M: ppc %end-callback ( -- ) M: ppc %end-callback ( -- )
3 %load-vm-addr 3 %load-vm-addr
"unnest_context" f %alien-invoke ; "end_callback" f %alien-invoke ;
M: ppc %end-callback-value ( ctype -- ) M: ppc %end-callback-value ( ctype -- )
! Save top of data stack ! Save top of data stack
12 ds-reg 0 LWZ 16 ds-reg 0 LWZ
%end-callback %end-callback
! Restore top of data stack ! Restore top of data stack
3 12 MR 3 16 MR
! Unbox former top of data stack to return registers ! Unbox former top of data stack to return registers
unbox-return ; unbox-return ;

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

@ -28,10 +28,13 @@ M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ; 0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 %vm-field ( dst field -- ) M: x86.32 %vm-field ( dst field -- )
[ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %set-vm-field ( dst field -- )
[ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %vm-field-ptr ( dst field -- ) M: x86.32 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ; [ 0 MOV ] dip rc-absolute-cell rel-vm ;
: local@ ( n -- op ) : local@ ( n -- op )
stack-frame get extra-stack-space dup 16 assert= + stack@ ; stack-frame get extra-stack-space dup 16 assert= + stack@ ;
@ -166,7 +169,7 @@ M: x86.32 %pop-stack ( n -- )
EAX swap ds-reg reg-stack MOV ; EAX swap ds-reg reg-stack MOV ;
M: x86.32 %pop-context-stack ( -- ) M: x86.32 %pop-context-stack ( -- )
temp-reg "ctx" %vm-field temp-reg %context
EAX temp-reg "datastack" context-field-offset [+] MOV EAX temp-reg "datastack" context-field-offset [+] MOV
EAX EAX [] MOV EAX EAX [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ; temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@ -241,6 +244,7 @@ M: x86.32 %alien-indirect ( -- )
M: x86.32 %begin-callback ( -- ) M: x86.32 %begin-callback ( -- )
0 save-vm-ptr 0 save-vm-ptr
ESP 4 [+] 0 MOV
"begin_callback" f %alien-invoke ; "begin_callback" f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- ) M: x86.32 %alien-callback ( quot -- )

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

@ -82,11 +82,9 @@ IN: bootstrap.x86
[ [
jit-load-vm jit-load-vm
ESP [] vm-reg MOV 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 EAX EBP 8 [+] MOV
ESP 4 [+] EAX MOV
"begin_callback" jit-call
jit-load-vm jit-load-vm
jit-load-context jit-load-context

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

@ -43,11 +43,14 @@ M: x86.64 machine-registers
M: x86.64 %mov-vm-ptr ( reg -- ) M: x86.64 %mov-vm-ptr ( reg -- )
vm-reg MOV ; vm-reg MOV ;
M: x86.64 %vm-field ( dst field -- ) M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip vm-field-offset [+] MOV ; [ vm-reg ] dip [+] MOV ;
M: x86.64 %vm-field-ptr ( dst field -- ) M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip vm-field-offset [+] LEA ; [ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr ( dst offset -- )
[ vm-reg ] dip [+] LEA ;
: param@ ( n -- op ) reserved-stack-space + stack@ ; : param@ ( n -- op ) reserved-stack-space + stack@ ;
@ -111,7 +114,7 @@ M: x86.64 %pop-stack ( n -- )
param-reg-0 swap ds-reg reg-stack MOV ; param-reg-0 swap ds-reg reg-stack MOV ;
M: x86.64 %pop-context-stack ( -- ) M: x86.64 %pop-context-stack ( -- )
temp-reg "ctx" %vm-field temp-reg %context
param-reg-0 temp-reg "datastack" context-field-offset [+] MOV param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
param-reg-0 param-reg-0 [] MOV param-reg-0 param-reg-0 [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ; temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@ -228,6 +231,7 @@ M: x86.64 %alien-indirect ( -- )
M: x86.64 %begin-callback ( -- ) M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
"begin_callback" f %alien-invoke ; "begin_callback" f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- ) M: x86.64 %alien-callback ( quot -- )

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

@ -76,8 +76,7 @@ IN: bootstrap.x86
: jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ; : jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
[ [
nv-reg arg1 MOV arg2 arg1 MOV
arg1 vm-reg MOV arg1 vm-reg MOV
"begin_callback" jit-call "begin_callback" jit-call
@ -85,7 +84,7 @@ IN: bootstrap.x86
jit-restore-context jit-restore-context
! call the quotation ! call the quotation
arg1 nv-reg MOV arg1 return-reg MOV
jit-call-quot jit-call-quot
jit-save-context jit-save-context

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

@ -423,8 +423,13 @@ M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
HOOK: %mov-vm-ptr cpu ( reg -- ) HOOK: %mov-vm-ptr cpu ( reg -- )
HOOK: %vm-field-ptr cpu ( reg offset -- )
: load-zone-offset ( nursery-ptr -- )
"nursery" vm-field-offset %vm-field-ptr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- ) : load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ; [ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- ) : inc-allot-ptr ( nursery-ptr n -- )
[ [] ] dip data-alignment get align ADD ; [ [] ] dip data-alignment get align ADD ;
@ -456,7 +461,7 @@ M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ; M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
M:: x86 %check-nursery ( label size temp1 temp2 -- ) M:: x86 %check-nursery ( label size temp1 temp2 -- )
temp1 "nursery" %vm-field-ptr temp1 load-zone-offset
! Load 'here' into temp2 ! Load 'here' into temp2
temp2 temp1 [] MOV temp2 temp1 [] MOV
temp2 size ADD temp2 size ADD
@ -477,7 +482,7 @@ M: x86 %push-stack ( -- )
ds-reg [] int-regs return-reg MOV ; ds-reg [] int-regs return-reg MOV ;
M: x86 %push-context-stack ( -- ) M: x86 %push-context-stack ( -- )
temp-reg "ctx" %vm-field temp-reg %context
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
temp-reg temp-reg "datastack" context-field-offset [+] MOV temp-reg temp-reg "datastack" context-field-offset [+] MOV
temp-reg [] int-regs return-reg MOV ; temp-reg [] int-regs return-reg MOV ;
@ -1403,7 +1408,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
M:: x86 %restore-context ( temp1 temp2 -- ) M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor. #! Load Factor stack pointers on entry from C to Factor.
temp1 "ctx" %vm-field temp1 %context
ds-reg temp1 "datastack" context-field-offset [+] MOV ds-reg temp1 "datastack" context-field-offset [+] MOV
rs-reg temp1 "retainstack" context-field-offset [+] MOV ; rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
@ -1411,7 +1416,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
#! Save Factor stack pointers in case the C code calls a #! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace #! callback which does a GC, which must reliably trace
#! all roots. #! all roots.
temp1 "ctx" %vm-field temp1 %context
temp2 stack-reg cell neg [+] LEA temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV temp1 "callstack-top" context-field-offset [+] temp2 MOV
temp1 "datastack" context-field-offset [+] ds-reg MOV temp1 "datastack" context-field-offset [+] ds-reg MOV

2
basis/dlists/dlists.factor
View File

@ -29,7 +29,7 @@ TUPLE: dlist
: <hashed-dlist> ( -- search-deque ) : <hashed-dlist> ( -- search-deque )
20 <hashtable> <dlist> <search-deque> ; 20 <hashtable> <dlist> <search-deque> ;
M: dlist deque-empty? front>> not ; M: dlist deque-empty? front>> not ; inline
M: dlist-node node-value obj>> ; M: dlist-node node-value obj>> ;

2
basis/heaps/heaps.factor
View File

@ -35,7 +35,7 @@ TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ; : <max-heap> ( -- max-heap ) max-heap <heap> ;
M: heap heap-empty? ( heap -- ? ) M: heap heap-empty? ( heap -- ? )
data>> empty? ; data>> empty? ; inline
M: heap heap-size ( heap -- n ) M: heap heap-size ( heap -- n )
data>> length ; data>> length ;

2
basis/io/pipes/windows/nt/nt.factor
View File

@ -3,7 +3,7 @@
USING: alien alien.c-types arrays destructors io io.backend.windows libc USING: alien alien.c-types arrays destructors io io.backend.windows libc
windows.types math.bitwise windows.kernel32 windows namespaces windows.types math.bitwise windows.kernel32 windows namespaces
make kernel sequences windows.errors assocs math.parser system make kernel sequences windows.errors assocs math.parser system
random combinators accessors io.pipes io.ports ; random combinators accessors io.pipes io.ports literals ;
IN: io.pipes.windows.nt IN: io.pipes.windows.nt
! This code is based on ! This code is based on

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

@ -355,7 +355,6 @@ M: bad-executable summary
\ code-room { } { byte-array } define-primitive \ code-room make-flushable \ code-room { } { byte-array } define-primitive \ code-room make-flushable
\ compact-gc { } { } define-primitive \ compact-gc { } { } define-primitive
\ compute-identity-hashcode { object } { } define-primitive \ compute-identity-hashcode { object } { } define-primitive
\ context { } { c-ptr } define-primitive \ context make-flushable
\ context-object { fixnum } { object } define-primitive \ context-object make-flushable \ context-object { fixnum } { object } define-primitive \ context-object make-flushable
\ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable \ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable
\ current-callback { } { fixnum } define-primitive \ current-callback make-flushable \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable

55
basis/threads/threads.factor
View File

@ -11,17 +11,20 @@ IN: threads
! Wrap sub-primitives; we don't want them inlined into callers ! Wrap sub-primitives; we don't want them inlined into callers
! since their behavior depends on what frames are on the callstack ! since their behavior depends on what frames are on the callstack
: context ( -- context )
2 context-object ; inline
: set-context ( obj context -- obj' ) : set-context ( obj context -- obj' )
(set-context) ; (set-context) ; inline
: start-context ( obj quot: ( obj -- * ) -- obj' ) : start-context ( obj quot: ( obj -- * ) -- obj' )
(start-context) ; (start-context) ; inline
: set-context-and-delete ( obj context -- * ) : set-context-and-delete ( obj context -- * )
(set-context-and-delete) ; (set-context-and-delete) ; inline
: start-context-and-delete ( obj quot: ( obj -- * ) -- * ) : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
(start-context-and-delete) ; (start-context-and-delete) ; inline
! Context introspection ! Context introspection
: namestack-for ( context -- namestack ) : namestack-for ( context -- namestack )
@ -80,23 +83,13 @@ sleep-entry ;
: thread-registered? ( thread -- ? ) : thread-registered? ( thread -- ? )
id>> threads key? ; id>> threads key? ;
ERROR: already-stopped thread ;
: check-unregistered ( thread -- thread )
dup thread-registered? [ already-stopped ] when ;
ERROR: not-running thread ;
: check-registered ( thread -- thread )
dup thread-registered? [ not-running ] unless ;
<PRIVATE <PRIVATE
: register-thread ( thread -- ) : register-thread ( thread -- )
check-unregistered dup id>> threads set-at ; dup id>> threads set-at ;
: unregister-thread ( thread -- ) : unregister-thread ( thread -- )
check-registered id>> threads delete-at ; id>> threads delete-at ;
: set-self ( thread -- ) 63 set-special-object ; inline : set-self ( thread -- ) 63 set-special-object ; inline
@ -106,7 +99,7 @@ PRIVATE>
65 special-object { dlist } declare ; inline 65 special-object { dlist } declare ; inline
: sleep-queue ( -- heap ) : sleep-queue ( -- heap )
66 special-object { dlist } declare ; inline 66 special-object { min-heap } declare ; inline
: new-thread ( quot name class -- thread ) : new-thread ( quot name class -- thread )
new new
@ -120,16 +113,13 @@ PRIVATE>
\ thread new-thread ; \ thread new-thread ;
: resume ( thread -- ) : resume ( thread -- )
f >>state f >>state run-queue push-front ;
check-registered run-queue push-front ;
: resume-now ( thread -- ) : resume-now ( thread -- )
f >>state f >>state run-queue push-back ;
check-registered run-queue push-back ;
: resume-with ( obj thread -- ) : resume-with ( obj thread -- )
f >>state f >>state 2array run-queue push-front ;
check-registered 2array run-queue push-front ;
: sleep-time ( -- nanos/f ) : sleep-time ( -- nanos/f )
{ {
@ -150,22 +140,19 @@ DEFER: stop
<PRIVATE <PRIVATE
: schedule-sleep ( thread dt -- ) : schedule-sleep ( thread dt -- )
[ check-registered dup ] dip sleep-queue heap-push* dupd sleep-queue heap-push* >>sleep-entry drop ;
>>sleep-entry drop ;
: expire-sleep? ( heap -- ? ) : expire-sleep? ( -- ? )
dup heap-empty? sleep-queue dup heap-empty?
[ drop f ] [ heap-peek nip nano-count <= ] if ; [ drop f ] [ heap-peek nip nano-count <= ] if ;
: expire-sleep ( thread -- ) : expire-sleep ( thread -- )
f >>sleep-entry resume ; f >>sleep-entry resume ;
: expire-sleep-loop ( -- ) : expire-sleep-loop ( -- )
sleep-queue [ expire-sleep? ]
[ dup expire-sleep? ] [ sleep-queue heap-pop drop expire-sleep ]
[ dup heap-pop drop expire-sleep ] while ;
while
drop ;
CONSTANT: [start] CONSTANT: [start]
[ [
@ -177,7 +164,9 @@ CONSTANT: [start]
: no-runnable-threads ( -- ) die ; : no-runnable-threads ( -- ) die ;
: (next) ( obj thread -- obj' ) GENERIC: (next) ( obj thread -- obj' )
M: thread (next)
dup runnable>> dup runnable>>
[ context>> box> set-context ] [ context>> box> set-context ]
[ t >>runnable drop [start] start-context ] if ; [ t >>runnable drop [start] start-context ] if ;

1
core/bootstrap/primitives.factor
View File

@ -538,7 +538,6 @@ tuple
{ "system-micros" "system" "primitive_system_micros" (( -- us )) } { "system-micros" "system" "primitive_system_micros" (( -- us )) }
{ "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
{ "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) } { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
{ "context" "threads.private" "primitive_context" (( -- context )) }
{ "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) } { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
{ "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) } { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) }
{ "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) } { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) }

2
extra/webkit-demo/webkit-demo.factor
View File

@ -13,7 +13,7 @@ IMPORT: WebView
WebView -> alloc WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ; rect f f -> initWithFrame:frameName:groupName: ;
CONSTANT: window-style ( -- n ) CONSTANT: window-style
flags{ flags{
NSClosableWindowMask NSClosableWindowMask
NSMiniaturizableWindowMask NSMiniaturizableWindowMask

26
vm/contexts.cpp
View File

@ -108,9 +108,16 @@ context *factor_vm::new_context()
return new_context; return new_context;
} }
void factor_vm::init_context(context *ctx)
{
ctx->context_objects[OBJ_CONTEXT] = allot_alien(ctx);
}
context *new_context(factor_vm *parent) context *new_context(factor_vm *parent)
{ {
return parent->new_context(); context *new_context = parent->new_context();
parent->init_context(new_context);
return new_context;
} }
void factor_vm::delete_context(context *old_context) void factor_vm::delete_context(context *old_context)
@ -124,16 +131,22 @@ VM_C_API void delete_context(factor_vm *parent, context *old_context)
parent->delete_context(old_context); parent->delete_context(old_context);
} }
void factor_vm::begin_callback() cell factor_vm::begin_callback(cell quot_)
{ {
data_root<object> quot(quot_,this);
ctx->reset(); ctx->reset();
spare_ctx = new_context(); spare_ctx = new_context();
callback_ids.push_back(callback_id++); callback_ids.push_back(callback_id++);
init_context(ctx);
return quot.value();
} }
void begin_callback(factor_vm *parent) cell begin_callback(factor_vm *parent, cell quot)
{ {
parent->begin_callback(); return parent->begin_callback(quot);
} }
void factor_vm::end_callback() void factor_vm::end_callback()
@ -296,9 +309,4 @@ void factor_vm::primitive_load_locals()
ctx->retainstack += sizeof(cell) * count; ctx->retainstack += sizeof(cell) * count;
} }
void factor_vm::primitive_context()
{
ctx->push(allot_alien(ctx));
}
} }

3
vm/contexts.hpp
View File

@ -6,6 +6,7 @@ static const cell context_object_count = 10;
enum context_object { enum context_object {
OBJ_NAMESTACK, OBJ_NAMESTACK,
OBJ_CATCHSTACK, OBJ_CATCHSTACK,
OBJ_CONTEXT,
}; };
static const cell stack_reserved = 1024; static const cell stack_reserved = 1024;
@ -71,7 +72,7 @@ struct context {
VM_C_API context *new_context(factor_vm *parent); VM_C_API context *new_context(factor_vm *parent);
VM_C_API void delete_context(factor_vm *parent, context *old_context); VM_C_API void delete_context(factor_vm *parent, context *old_context);
VM_C_API void begin_callback(factor_vm *parent); VM_C_API cell begin_callback(factor_vm *parent, cell quot);
VM_C_API void end_callback(factor_vm *parent); VM_C_API void end_callback(factor_vm *parent);
} }

5
vm/factor.cpp
View File

@ -14,7 +14,12 @@ void factor_vm::default_parameters(vm_parameters *p)
p->datastack_size = 32 * sizeof(cell); p->datastack_size = 32 * sizeof(cell);
p->retainstack_size = 32 * sizeof(cell); p->retainstack_size = 32 * sizeof(cell);
#ifdef __OpenBSD__
p->callstack_size = 32 * sizeof(cell);
#else
p->callstack_size = 128 * sizeof(cell); p->callstack_size = 128 * sizeof(cell);
#endif
p->code_size = 8 * sizeof(cell); p->code_size = 8 * sizeof(cell);
p->young_size = sizeof(cell) / 4; p->young_size = sizeof(cell) / 4;

1
vm/os-genunix.hpp
View File

@ -2,7 +2,6 @@ namespace factor
{ {
#define VM_C_API extern "C" #define VM_C_API extern "C"
#define NULL_DLL NULL
void early_init(); void early_init();
const char *vm_executable_path(); const char *vm_executable_path();

1
vm/os-macosx.hpp
View File

@ -3,7 +3,6 @@ namespace factor
#define VM_C_API extern "C" __attribute__((visibility("default"))) #define VM_C_API extern "C" __attribute__((visibility("default")))
#define FACTOR_OS_STRING "macosx" #define FACTOR_OS_STRING "macosx"
#define NULL_DLL NULL
void early_init(); void early_init();

2
vm/os-unix.cpp
View File

@ -46,7 +46,7 @@ void sleep_nanos(u64 nsec)
void factor_vm::init_ffi() void factor_vm::init_ffi()
{ {
null_dll = dlopen(NULL_DLL,RTLD_LAZY); null_dll = dlopen(NULL,RTLD_LAZY);
} }
void factor_vm::ffi_dlopen(dll *dll) void factor_vm::ffi_dlopen(dll *dll)

2
vm/os-windows-nt.hpp
View File

@ -20,7 +20,7 @@ typedef char symbol_char;
#define FACTOR_OS_STRING "winnt" #define FACTOR_OS_STRING "winnt"
#define FACTOR_DLL L"factor.dll" #define FACTOR_DLL NULL
#ifdef _MSC_VER #ifdef _MSC_VER
#define FACTOR_STDCALL(return_type) return_type __stdcall #define FACTOR_STDCALL(return_type) return_type __stdcall

1
vm/primitives.hpp
View File

@ -43,7 +43,6 @@ namespace factor
_(code_room) \ _(code_room) \
_(compact_gc) \ _(compact_gc) \
_(compute_identity_hashcode) \ _(compute_identity_hashcode) \
_(context) \
_(context_object) \ _(context_object) \
_(context_object_for) \ _(context_object_for) \
_(current_callback) \ _(current_callback) \

4
vm/vm.hpp
View File

@ -112,10 +112,11 @@ struct factor_vm
// contexts // contexts
context *new_context(); context *new_context();
void init_context(context *ctx);
void delete_context(context *old_context); void delete_context(context *old_context);
void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_); void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_);
void delete_contexts(); void delete_contexts();
void begin_callback(); cell begin_callback(cell quot);
void end_callback(); void end_callback();
void primitive_current_callback(); void primitive_current_callback();
void primitive_context_object(); void primitive_context_object();
@ -135,7 +136,6 @@ struct factor_vm
void primitive_set_retainstack(); void primitive_set_retainstack();
void primitive_check_datastack(); void primitive_check_datastack();
void primitive_load_locals(); void primitive_load_locals();
void primitive_context();
template<typename Iterator> void iterate_active_callstacks(Iterator &iter) template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
{ {