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 -- )
dup occupied>>
[ box-full ] [ t >>occupied (>>value) ] if ;
[ box-full ] [ t >>occupied (>>value) ] if ; inline
ERROR: box-empty box ;
@ -19,10 +19,10 @@ ERROR: box-empty box ;
dup occupied>> [ box-empty ] unless ; inline
: box> ( box -- value )
check-box [ f ] change-value f >>occupied drop ;
check-box [ f ] change-value f >>occupied drop ; inline
: ?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 -- )
[ ?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-imm insn-slot# slot>> ;
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-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
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' )
H{ } clone histories set
@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
0 ac-counter set
next-ac heap-ac set
\ ##vm-field-ptr set-new-ac
\ ##vm-field set-new-ac
\ ##alien-global set-new-ac
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
literal: symbol library ;
INSN: ##vm-field-ptr
def: dst/int-rep
literal: field-name ;
INSN: ##vm-field
def: dst/int-rep
literal: field-name ;
literal: offset ;
INSN: ##set-vm-field
use: src/int-rep
literal: offset ;
! FFI
INSN: ##alien-invoke
@ -835,8 +835,8 @@ UNION: ##allocation
##box-displaced-alien ;
! For alias analysis
UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ;
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that kill all live vregs but cannot trigger GC
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:context-object [ emit-context-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 ] }
{ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
{ 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.
USING: namespaces layouts sequences kernel math accessors
compiler.tree.propagation.info compiler.cfg.stacks
compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.builder.blocks
compiler.cfg.utilities ;
FROM: vm => context-field-offset ;
FROM: vm => context-field-offset vm-field-offset ;
IN: compiler.cfg.intrinsics.misc
: emit-tag ( -- )
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 -- )
dup node-input-infos first literal>> [
"special-objects" ^^vm-field-ptr
ds-drop swap 0 ^^slot-imm
ds-drop
special-object-offset ^^vm-field
ds-push
] [ emit-primitive ] ?if ;
: context-object-offset ( -- n )
"context-objects" context-field-offset cell /i ;
: emit-set-special-object ( node -- )
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 -- )
dup node-input-infos first literal>> [
"ctx" ^^vm-field
ds-drop swap context-object-offset + 0 ^^slot-imm ds-push
"ctx" vm-field-offset ^^vm-field
ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
] [ emit-primitive ] ?if ;
: 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-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
CODEGEN: ##vm-field-ptr %vm-field-ptr
CODEGEN: ##vm-field %vm-field
CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: _fixnum-add %fixnum-add
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"
[ "example" set-global 2drop ] alien-callback ;
: double-rect-test ( arg -- arg' )
f f rot
double-rect-callback
: double-rect-test ( arg callback -- arg' )
[ f f ] 2dip
void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ;
[ 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
{ 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
: 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 -- )
[ resume-now ] slurp-deque ;
[ resume-now ] slurp-deque ; inline
: queue-timeout ( queue timeout -- alarm )
#! Add an alarm which removes the current thread from the
@ -23,7 +23,7 @@ IN: concurrency.conditions
ERROR: wait-timeout ;
: queue ( queue -- )
[ self ] dip push-front ;
[ self ] dip push-front ; inline
: wait ( queue timeout status -- )
over [
@ -31,4 +31,4 @@ ERROR: wait-timeout ;
[ wait-timeout ] [ cancel-alarm ] if
] [
[ 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 ;
IN: concurrency.mailboxes
TUPLE: mailbox threads data ;
TUPLE: mailbox { threads dlist } { data dlist } ;
: <mailbox> ( -- mailbox )
mailbox new
<dlist> >>threads
<dlist> >>data ;
<dlist> >>data ; inline
: 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 ]
[ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- )
[ threads>> ] dip "mailbox" wait ;
[ threads>> ] dip "mailbox" wait ; inline
:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
mailbox data>> pred dlist-any? [
@ -34,16 +36,17 @@ TUPLE: mailbox threads data ;
2dup wait-for-mailbox block-if-empty
] [
drop
] if ;
] if ; inline recursive
: mailbox-peek ( mailbox -- obj )
data>> peek-back ;
: mailbox-get-timeout ( mailbox timeout -- obj )
block-if-empty data>> pop-back ;
GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
: mailbox-get ( mailbox -- obj )
f mailbox-get-timeout ;
f mailbox-get-timeout ; inline
: mailbox-get-all-timeout ( mailbox timeout -- array )
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.
USING: kernel threads concurrency.mailboxes continuations
namespaces assocs accessors summary fry ;
USING: kernel kernel.private threads concurrency.mailboxes
continuations namespaces assocs accessors summary fry ;
IN: concurrency.messaging
GENERIC: send ( message thread -- )
: mailbox-of ( thread -- mailbox )
dup mailbox>> [ ] [
<mailbox> [ >>mailbox drop ] keep
] ?if ;
GENERIC: mailbox-of ( thread -- mailbox )
M: thread mailbox-of
dup mailbox>>
[ { mailbox } declare ]
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
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 )
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: %alien-global cpu ( dst symbol library -- )
HOOK: %vm-field cpu ( dst fieldname -- )
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %vm-field cpu ( dst offset -- )
HOOK: %set-vm-field cpu ( src offset -- )
: %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
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 ;
[
! Save old stack pointer
11 1 MR
! Create stack frame
0 MFLR
1 1 callback-frame-size neg STWU
1 1 callback-frame-size SUBI
0 1 callback-frame-size lr-save + STW
! Save all non-volatile registers
@ -86,6 +89,10 @@ CONSTANT: nv-reg 17
nv-fp-regs [ 8 * 80 + save-fp ] 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
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
0 1 callback-frame-size lr-save + LWZ
1 1 0 LWZ
1 1 callback-frame-size ADDI
0 MTLR
BLR
] 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 ;
M: ppc %vm-field ( dst field -- )
[ vm-reg ] dip vm-field-offset LWZ ;
M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
M: ppc %vm-field-ptr ( dst field -- )
[ vm-reg ] dip vm-field-offset ADDI ;
M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
GENERIC: loc-reg ( loc -- reg )
@ -385,7 +383,7 @@ M: ppc %set-alien-float -rot STFS ;
M: ppc %set-alien-double -rot STFD ;
: load-zone-ptr ( reg -- )
"nursery" %vm-field-ptr ;
vm-reg "nursery" vm-field-offset ADDI ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
@ -567,8 +565,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
} case ;
: next-param@ ( n -- reg x )
2 1 stack-frame get total-size>> LWZ
[ 2 ] dip param@ ;
[ 17 ] dip param@ ;
: store-to-frame ( src n rep -- )
{
@ -604,14 +601,14 @@ M: ppc %push-stack ( -- )
int-regs return-reg ds-reg 0 STW ;
M: ppc %push-context-stack ( -- )
11 "ctx" %vm-field
11 %context
12 11 "datastack" context-field-offset LWZ
12 12 4 ADDI
12 11 "datastack" context-field-offset STW
int-regs return-reg 12 0 STW ;
M: ppc %pop-context-stack ( -- )
11 "ctx" %vm-field
11 %context
12 11 "datastack" context-field-offset LWZ
int-regs return-reg 12 0 LWZ
12 12 4 SUBI
@ -677,12 +674,12 @@ M: ppc %box-large-struct ( n c-type -- )
"from_value_struct" f %alien-invoke ;
M:: ppc %restore-context ( temp1 temp2 -- )
temp1 "ctx" %vm-field
temp1 %context
ds-reg temp1 "datastack" context-field-offset LWZ
rs-reg temp1 "retainstack" context-field-offset LWZ ;
M:: ppc %save-context ( temp1 temp2 -- )
temp1 "ctx" %vm-field
temp1 %context
1 temp1 "callstack-top" context-field-offset STW
ds-reg temp1 "datastack" 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 ( -- )
3 %load-vm-addr
"unnest_context" f %alien-invoke ;
"end_callback" f %alien-invoke ;
M: ppc %end-callback-value ( ctype -- )
! Save top of data stack
12 ds-reg 0 LWZ
16 ds-reg 0 LWZ
%end-callback
! Restore top of data stack
3 12 MR
3 16 MR
! Unbox former top of data stack to return registers
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 ;
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 -- )
[ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
[ 0 MOV ] dip rc-absolute-cell rel-vm ;
: local@ ( n -- op )
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 ;
M: x86.32 %pop-context-stack ( -- )
temp-reg "ctx" %vm-field
temp-reg %context
EAX temp-reg "datastack" context-field-offset [+] MOV
EAX EAX [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@ -241,6 +244,7 @@ M: x86.32 %alien-indirect ( -- )
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
ESP 4 [+] 0 MOV
"begin_callback" f %alien-invoke ;
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
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
ESP 4 [+] EAX MOV
"begin_callback" jit-call
jit-load-vm
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 -- )
vm-reg MOV ;
M: x86.64 %vm-field ( dst field -- )
[ vm-reg ] dip vm-field-offset [+] MOV ;
M: x86.64 %vm-field ( dst offset -- )
[ vm-reg ] dip [+] MOV ;
M: x86.64 %vm-field-ptr ( dst field -- )
[ vm-reg ] dip vm-field-offset [+] LEA ;
M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr ( dst offset -- )
[ vm-reg ] dip [+] LEA ;
: 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 ;
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 param-reg-0 [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@ -228,6 +231,7 @@ M: x86.64 %alien-indirect ( -- )
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-1 0 MOV
"begin_callback" f %alien-invoke ;
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 ;
[
nv-reg arg1 MOV
arg2 arg1 MOV
arg1 vm-reg MOV
"begin_callback" jit-call
@ -85,7 +84,7 @@ IN: bootstrap.x86
jit-restore-context
! call the quotation
arg1 nv-reg MOV
arg1 return-reg MOV
jit-call-quot
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: %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 -- )
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
[ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
[ [] ] 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 %check-nursery ( label size temp1 temp2 -- )
temp1 "nursery" %vm-field-ptr
temp1 load-zone-offset
! Load 'here' into temp2
temp2 temp1 [] MOV
temp2 size ADD
@ -477,7 +482,7 @@ M: x86 %push-stack ( -- )
ds-reg [] int-regs return-reg MOV ;
M: x86 %push-context-stack ( -- )
temp-reg "ctx" %vm-field
temp-reg %context
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
temp-reg temp-reg "datastack" context-field-offset [+] 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 -- )
#! Load Factor stack pointers on entry from C to Factor.
temp1 "ctx" %vm-field
temp1 %context
ds-reg temp1 "datastack" 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
#! callback which does a GC, which must reliably trace
#! all roots.
temp1 "ctx" %vm-field
temp1 %context
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 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 )
20 <hashtable> <dlist> <search-deque> ;
M: dlist deque-empty? front>> not ;
M: dlist deque-empty? front>> not ; inline
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> ;
M: heap heap-empty? ( heap -- ? )
data>> empty? ;
data>> empty? ; inline
M: heap heap-size ( heap -- n )
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
windows.types math.bitwise windows.kernel32 windows namespaces
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
! 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
\ compact-gc { } { } 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-for { fixnum c-ptr } { object } define-primitive \ context-object-for 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
! since their behavior depends on what frames are on the callstack
: context ( -- context )
2 context-object ; inline
: set-context ( obj context -- obj' )
(set-context) ;
(set-context) ; inline
: start-context ( obj quot: ( obj -- * ) -- obj' )
(start-context) ;
(start-context) ; inline
: 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) ;
(start-context-and-delete) ; inline
! Context introspection
: namestack-for ( context -- namestack )
@ -80,23 +83,13 @@ sleep-entry ;
: thread-registered? ( thread -- ? )
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
: register-thread ( thread -- )
check-unregistered dup id>> threads set-at ;
dup id>> threads set-at ;
: unregister-thread ( thread -- )
check-registered id>> threads delete-at ;
id>> threads delete-at ;
: set-self ( thread -- ) 63 set-special-object ; inline
@ -106,7 +99,7 @@ PRIVATE>
65 special-object { dlist } declare ; inline
: sleep-queue ( -- heap )
66 special-object { dlist } declare ; inline
66 special-object { min-heap } declare ; inline
: new-thread ( quot name class -- thread )
new
@ -120,16 +113,13 @@ PRIVATE>
\ thread new-thread ;
: resume ( thread -- )
f >>state
check-registered run-queue push-front ;
f >>state run-queue push-front ;
: resume-now ( thread -- )
f >>state
check-registered run-queue push-back ;
f >>state run-queue push-back ;
: resume-with ( obj thread -- )
f >>state
check-registered 2array run-queue push-front ;
f >>state 2array run-queue push-front ;
: sleep-time ( -- nanos/f )
{
@ -150,22 +140,19 @@ DEFER: stop
<PRIVATE
: schedule-sleep ( thread dt -- )
[ check-registered dup ] dip sleep-queue heap-push*
>>sleep-entry drop ;
dupd sleep-queue heap-push* >>sleep-entry drop ;
: expire-sleep? ( heap -- ? )
dup heap-empty?
: expire-sleep? ( -- ? )
sleep-queue dup heap-empty?
[ drop f ] [ heap-peek nip nano-count <= ] if ;
: expire-sleep ( thread -- )
f >>sleep-entry resume ;
: expire-sleep-loop ( -- )
sleep-queue
[ dup expire-sleep? ]
[ dup heap-pop drop expire-sleep ]
while
drop ;
[ expire-sleep? ]
[ sleep-queue heap-pop drop expire-sleep ]
while ;
CONSTANT: [start]
[
@ -177,7 +164,9 @@ CONSTANT: [start]
: no-runnable-threads ( -- ) die ;
: (next) ( obj thread -- obj' )
GENERIC: (next) ( obj thread -- obj' )
M: thread (next)
dup runnable>>
[ context>> box> set-context ]
[ 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 )) }
{ "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
{ "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 )) }
{ "datastack-for" "threads.private" "primitive_datastack_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
rect f f -> initWithFrame:frameName:groupName: ;
CONSTANT: window-style ( -- n )
CONSTANT: window-style
flags{
NSClosableWindowMask
NSMiniaturizableWindowMask

26
vm/contexts.cpp
View File

@ -108,9 +108,16 @@ context *factor_vm::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)
{
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)
@ -124,16 +131,22 @@ VM_C_API void delete_context(factor_vm *parent, 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();
spare_ctx = new_context();
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()
@ -296,9 +309,4 @@ void factor_vm::primitive_load_locals()
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 {
OBJ_NAMESTACK,
OBJ_CATCHSTACK,
OBJ_CONTEXT,
};
static const cell stack_reserved = 1024;
@ -71,7 +72,7 @@ struct context {
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 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);
}

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->retainstack_size = 32 * sizeof(cell);
#ifdef __OpenBSD__
p->callstack_size = 32 * sizeof(cell);
#else
p->callstack_size = 128 * sizeof(cell);
#endif
p->code_size = 8 * sizeof(cell);
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 NULL_DLL NULL
void early_init();
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 FACTOR_OS_STRING "macosx"
#define NULL_DLL NULL
void early_init();

2
vm/os-unix.cpp
View File

@ -46,7 +46,7 @@ void sleep_nanos(u64 nsec)
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)

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

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

1
vm/primitives.hpp
View File

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

4
vm/vm.hpp
View File

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