From 51fd5e34e8fb74fddf99336abc5945c452f98125 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 1 Apr 2010 18:48:25 -0500 Subject: [PATCH 01/10] Fix bootstrap on windows --- basis/io/pipes/windows/nt/nt.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/nt/nt.factor index f87a98ab91..d58e5e3d5f 100644 --- a/basis/io/pipes/windows/nt/nt.factor +++ b/basis/io/pipes/windows/nt/nt.factor @@ -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 From 1b4b1a180c67e4ca4d4cd5007b1796082e7282a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 20:05:32 -0400 Subject: [PATCH 02/10] Some minor pointless optimizations --- basis/boxes/boxes.factor | 6 +-- .../concurrency/conditions/conditions.factor | 8 ++-- basis/concurrency/mailboxes/mailboxes.factor | 21 +++++---- basis/concurrency/messaging/messaging.factor | 20 +++++---- basis/dlists/dlists.factor | 2 +- basis/heaps/heaps.factor | 2 +- basis/threads/threads.factor | 44 +++++++------------ 7 files changed, 47 insertions(+), 56 deletions(-) diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 811c5addb0..a159e1402b 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -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 diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 4a1c7d3370..2fb75226eb 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -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 diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index e245f93bd5..163873575c 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -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 new >>threads - >>data ; + >>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 diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 37965309e8..3f55b0969b 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -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 drop ] keep - ] ?if ; +GENERIC: mailbox-of ( thread -- mailbox ) + +M: thread mailbox-of + dup mailbox>> + [ { mailbox } declare ] + [ [ >>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 ; diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 44140d3109..53e134fad9 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -29,7 +29,7 @@ TUPLE: dlist : ( -- search-deque ) 20 ; -M: dlist deque-empty? front>> not ; +M: dlist deque-empty? front>> not ; inline M: dlist-node node-value obj>> ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 677daca69d..28d18cb53a 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -35,7 +35,7 @@ TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; M: heap heap-empty? ( heap -- ? ) - data>> empty? ; + data>> empty? ; inline M: heap heap-size ( heap -- n ) data>> length ; diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 117e941aa7..404c8112fb 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -80,23 +80,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 ; - > 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 +96,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 +110,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 +137,19 @@ DEFER: stop >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 +161,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 ; From eceabbc57e7ecd1ad6a406db4e65ed538185f169 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 20:06:18 -0400 Subject: [PATCH 03/10] compiler: new set-special-object intrinsic; more efficient special-object intrinsic --- .../cfg/alias-analysis/alias-analysis.factor | 8 +++--- .../cfg/instructions/instructions.factor | 14 +++++------ .../compiler/cfg/intrinsics/intrinsics.factor | 1 + .../compiler/cfg/intrinsics/misc/misc.factor | 25 +++++++++++++------ basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/tests/alien.factor | 11 +++++--- basis/cpu/architecture/architecture.factor | 6 +++-- basis/cpu/ppc/ppc.factor | 16 +++++------- basis/cpu/x86/32/32.factor | 9 ++++--- basis/cpu/x86/64/64.factor | 13 ++++++---- basis/cpu/x86/x86.factor | 15 +++++++---- 11 files changed, 72 insertions(+), 48 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 24433ad594..44326c179f 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -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 ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 678ce76860..c015cb640b 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -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 diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 4ebc818b83..2b2ae7d160 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -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+ ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index 9731d2f6f5..da77bcaa09 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -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 ( -- ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d82ced8a1d..4208fec0a7 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -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 diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 692dbee4c5..ceac1b094c 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -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-test >double-rect< ] unit-test +[ + 1.0 2.0 3.0 4.0 + double-rect-callback double-rect-test + >double-rect< +] unit-test STRUCT: test_struct_14 { x1 double } diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index b617746a06..ad1a4be2eb 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -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 -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index dbc313052f..3fd0552a99 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -58,11 +58,7 @@ 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-ptr ( dst field -- ) - [ vm-reg ] dip vm-field-offset ADDI ; +M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ; GENERIC: loc-reg ( loc -- reg ) @@ -385,7 +381,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 ; @@ -604,14 +600,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 +673,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 ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 09f1ecb32b..8b97eb9351 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -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 ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 04f64f96b6..bea5d4da1f 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -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 ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index dbb112bf4b..acd2e1358d 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -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 From 2cab0bb86cc8cc6a48ca4dca1f2f0c141448e7f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 22:39:46 -0400 Subject: [PATCH 04/10] cpu.ppc: stick old stack pointer in a register for use by callbacks --- basis/cpu/ppc/bootstrap.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 83be0150d8..f7a1917d0e 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -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 From 044171e6b9296245cc8741fc0c4e9513eec0b328 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 21:41:13 -0500 Subject: [PATCH 05/10] cpu.ppc: fix optimizing compiler backend --- basis/cpu/ppc/ppc.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 3fd0552a99..cf8a832386 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -60,6 +60,8 @@ CONSTANT: vm-reg 15 M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ; +M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ; + GENERIC: loc-reg ( loc -- reg ) M: ds-loc loc-reg drop ds-reg ; @@ -563,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 -- ) { @@ -745,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 ; From 0c0935dfc182e6289da084cd6b78c2bafaa670e6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 1 Apr 2010 22:24:46 -0500 Subject: [PATCH 06/10] Fix typo in webkit demo --- extra/webkit-demo/webkit-demo.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor index eb24d035dc..8f89b1b4ae 100644 --- a/extra/webkit-demo/webkit-demo.factor +++ b/extra/webkit-demo/webkit-demo.factor @@ -13,7 +13,7 @@ IMPORT: WebView WebView -> alloc rect f f -> initWithFrame:frameName:groupName: ; -CONSTANT: window-style ( -- n ) +CONSTANT: window-style flags{ NSClosableWindowMask NSMiniaturizableWindowMask From 0faa3bcf4a24dd8da0cff04d76bfbdb6be31378a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 1 Apr 2010 22:12:45 -0400 Subject: [PATCH 07/10] vm: pre-allocate context alien --- basis/cpu/x86/32/32.factor | 1 + basis/cpu/x86/32/bootstrap.factor | 6 ++--- basis/cpu/x86/64/64.factor | 1 + basis/cpu/x86/64/bootstrap.factor | 5 ++-- .../known-words/known-words.factor | 1 - basis/threads/threads.factor | 11 +++++--- core/bootstrap/primitives.factor | 1 - vm/contexts.cpp | 26 ++++++++++++------- vm/contexts.hpp | 3 ++- vm/primitives.hpp | 1 - vm/vm.hpp | 4 +-- 11 files changed, 34 insertions(+), 26 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 8b97eb9351..97f0cfb668 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -244,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 -- ) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index a428a66ace..293d99fe93 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index bea5d4da1f..7e1c5c1f48 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -231,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 -- ) diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 4cd2d8104b..6c0d50f1b7 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -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 diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 01f3ff77c0..15895184df 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -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 diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 404c8112fb..330b4abd6c 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -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 ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 52ee1e14b4..8a412b8a14 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -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 )) } diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 9364f2e362..25fe0e5280 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -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 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)); -} - } diff --git a/vm/contexts.hpp b/vm/contexts.hpp index f3aba0e5a6..85338ca91d 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -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); } diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 7e95a3bad5..ff0947912c 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -43,7 +43,6 @@ namespace factor _(code_room) \ _(compact_gc) \ _(compute_identity_hashcode) \ - _(context) \ _(context_object) \ _(context_object_for) \ _(current_callback) \ diff --git a/vm/vm.hpp b/vm/vm.hpp index ad74a8e090..cf2f0ca433 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -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 void iterate_active_callstacks(Iterator &iter) { From d9d12ab8fb5af2fedfeb99b08b4536cbd0ffe480 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 00:03:26 -0400 Subject: [PATCH 08/10] vm: don't try loading Factor VM DLL anymore --- vm/os-genunix.hpp | 1 - vm/os-macosx.hpp | 1 - vm/os-unix.cpp | 2 +- vm/os-windows-nt.hpp | 4 ++-- 4 files changed, 3 insertions(+), 5 deletions(-) diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index c6123eca56..a40e891a6e 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -2,7 +2,6 @@ namespace factor { #define VM_C_API extern "C" -#define NULL_DLL NULL void early_init(); const char *vm_executable_path(); diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index 4d4499461d..27eba77215 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -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(); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 60ac00fb39..034dfcbf5f 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -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) diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index c5e721c56d..869205b67e 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -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 @@ -28,7 +28,7 @@ typedef char symbol_char; #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type #endif -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); +VM_C_API exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) // SSE traps raise these exception codes, which are defined in internal NT headers // but not winbase.h From fa9b6e086b94be5f1670cd1fa226f4ff67a3c147 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 00:22:16 -0400 Subject: [PATCH 09/10] vm: oops --- vm/os-windows-nt.hpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 869205b67e..f274d7813f 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -28,7 +28,7 @@ typedef char symbol_char; #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type #endif -VM_C_API exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) +FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); // SSE traps raise these exception codes, which are defined in internal NT headers // but not winbase.h From 279ff3a7d311b00dd85d1701f32bd91f52b2353e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 00:36:45 -0400 Subject: [PATCH 10/10] vm: smaller default callstack size on OpenBSD --- vm/factor.cpp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/vm/factor.cpp b/vm/factor.cpp index e726ebf6da..983e12bdcd 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -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;