From 51fd5e34e8fb74fddf99336abc5945c452f98125 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 1 Apr 2010 18:48:25 -0500 Subject: [PATCH 01/31] 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/31] 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/31] 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/31] 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/31] 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/31] 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/31] 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/31] 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/31] 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/31] 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; From fa49520cbf019f7e02b0879f0bdfd73308cbfacd Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 1 Apr 2010 21:59:02 -0700 Subject: [PATCH 11/31] update nmakefile to statically link VM to exe just like GNUmakefile --- Nmakefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Nmakefile b/Nmakefile index a73a59d0f5..0d815b6161 100755 --- a/Nmakefile +++ b/Nmakefile @@ -6,7 +6,7 @@ LINK_FLAGS = /nologo shell32.lib CL_FLAGS = /nologo /O2 /W3 !ENDIF -EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res +EXE_OBJS = vm\main-windows-nt.obj vm\factor.res DLL_OBJS = vm\os-windows-nt.obj \ vm\os-windows.obj \ @@ -63,7 +63,7 @@ DLL_OBJS = vm\os-windows-nt.obj \ .rs.res: rc $< -all: factor.com factor.exe libfactor-ffi-test.dll +all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll libfactor-ffi-test.dll: vm/ffi_test.obj link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj @@ -71,11 +71,11 @@ libfactor-ffi-test.dll: vm/ffi_test.obj factor.dll.lib: $(DLL_OBJS) link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS) -factor.com: $(EXE_OBJS) - link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) +factor.com: $(EXE_OBJS) $(DLL_OBJS) + link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS) -factor.exe: $(EXE_OBJS) - link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) +factor.exe: $(EXE_OBJS) $(DLL_OBJS) + link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS) clean: del vm\*.obj From d24ce84dded12eb2bd1155dfa3868cfa3872a23b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 14:09:58 -0400 Subject: [PATCH 12/31] vm: larger default callstack on PowerPC --- vm/factor.cpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/factor.cpp b/vm/factor.cpp index 983e12bdcd..89da7a2db7 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -15,8 +15,8 @@ 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); +#ifdef FACTOR_PPC + p->callstack_size = 256 * sizeof(cell); #else p->callstack_size = 128 * sizeof(cell); #endif From b740a1fe5d34c872f58e9dac2491d3b7715adcdd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 14:10:55 -0400 Subject: [PATCH 13/31] vm: use C++ exceptions instead of longjmp(), to make Windows crash more --- vm/collector.hpp | 5 +-- vm/gc.cpp | 84 ++++++++++++++++++++++++++---------------------- vm/gc.hpp | 1 - vm/master.hpp | 1 - 4 files changed, 49 insertions(+), 42 deletions(-) diff --git a/vm/collector.hpp b/vm/collector.hpp index ece4926c28..0b8b473e8b 100644 --- a/vm/collector.hpp +++ b/vm/collector.hpp @@ -1,6 +1,8 @@ namespace factor { +struct must_start_gc_again {}; + template struct data_workhorse { factor_vm *parent; TargetGeneration *target; @@ -27,8 +29,7 @@ template struct data_workhorse { { cell size = untagged->size(); object *newpointer = target->allot(size); - /* XXX not exception-safe */ - if(!newpointer) longjmp(parent->current_gc->gc_unwind,1); + if(!newpointer) throw must_start_gc_again(); memcpy(newpointer,untagged,size); untagged->forward_to(newpointer); diff --git a/vm/gc.cpp b/vm/gc.cpp index a57f338c44..e01a05aa5b 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -135,49 +135,57 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p) /* Keep trying to GC higher and higher generations until we don't run out of space */ - if(setjmp(current_gc->gc_unwind)) + for(;;) { - /* We come back here if a generation is full */ - start_gc_again(); - } - - current_gc->event->op = current_gc->op; - - switch(current_gc->op) - { - case collect_nursery_op: - collect_nursery(); - break; - case collect_aging_op: - collect_aging(); - if(data->high_fragmentation_p()) + try { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; - collect_full(trace_contexts_p); + current_gc->event->op = current_gc->op; + + switch(current_gc->op) + { + case collect_nursery_op: + collect_nursery(); + break; + case collect_aging_op: + collect_aging(); + if(data->high_fragmentation_p()) + { + current_gc->op = collect_full_op; + current_gc->event->op = collect_full_op; + collect_full(trace_contexts_p); + } + break; + case collect_to_tenured_op: + collect_to_tenured(); + if(data->high_fragmentation_p()) + { + current_gc->op = collect_full_op; + current_gc->event->op = collect_full_op; + collect_full(trace_contexts_p); + } + break; + case collect_full_op: + collect_full(trace_contexts_p); + break; + case collect_compact_op: + collect_compact(trace_contexts_p); + break; + case collect_growing_heap_op: + collect_growing_heap(requested_bytes,trace_contexts_p); + break; + default: + critical_error("Bad GC op",current_gc->op); + break; + } + + break; } - break; - case collect_to_tenured_op: - collect_to_tenured(); - if(data->high_fragmentation_p()) + catch(const must_start_gc_again e) { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; - collect_full(trace_contexts_p); + /* We come back here if a generation is full */ + start_gc_again(); + continue; } - break; - case collect_full_op: - collect_full(trace_contexts_p); - break; - case collect_compact_op: - collect_compact(trace_contexts_p); - break; - case collect_growing_heap_op: - collect_growing_heap(requested_bytes,trace_contexts_p); - break; - default: - critical_error("Bad GC op",current_gc->op); - break; } end_gc(); diff --git a/vm/gc.hpp b/vm/gc.hpp index 5224dec3e2..5129ced909 100755 --- a/vm/gc.hpp +++ b/vm/gc.hpp @@ -45,7 +45,6 @@ struct gc_event { struct gc_state { gc_op op; u64 start_time; - jmp_buf gc_unwind; gc_event *event; explicit gc_state(gc_op op_, factor_vm *parent); diff --git a/vm/master.hpp b/vm/master.hpp index 9879fa607a..a111a86b69 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -16,7 +16,6 @@ #include #include #include -#include #include #include #include From 68073831f9585fb31d99645866c19b4668cf3106 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 14:14:25 -0400 Subject: [PATCH 14/31] mason.common: increase timeout because Windows is damn slow --- extra/mason/common/common.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 912cd48c79..db68a558e0 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -17,8 +17,8 @@ SYMBOL: current-git-id : short-running-process ( command -- ) #! Give network operations and shell commands at most - #! 15 minutes to complete, to catch hangs. - >process 15 minutes >>timeout try-output-process ; + #! 30 minutes to complete, to catch hangs. + >process 30 minutes >>timeout try-output-process ; HOOK: really-delete-tree os ( path -- ) From de4343eaf7e14260b288632764f4108261eabd2c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 15:42:29 -0400 Subject: [PATCH 15/31] vm: re-organize context structure --- basis/vm/vm.factor | 4 ++-- vm/contexts.hpp | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index b0f2c945f7..b4c5734810 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -11,10 +11,10 @@ STRUCT: context { datastack cell } { retainstack cell } { callstack-save cell } -{ context-objects cell[10] } { datastack-region void* } { retainstack-region void* } -{ callstack-region void* } ; +{ callstack-region void* } +{ context-objects cell[10] } ; : context-field-offset ( field -- offset ) context offset-of ; inline diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 85338ca91d..582fab173f 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -28,14 +28,14 @@ struct context { /* C callstack pointer */ cell callstack_save; - /* context-specific special objects, accessed by context-object and - set-context-object primitives */ - cell context_objects[context_object_count]; - segment *datastack_seg; segment *retainstack_seg; segment *callstack_seg; + /* context-specific special objects, accessed by context-object and + set-context-object primitives */ + cell context_objects[context_object_count]; + context(cell datastack_size, cell retainstack_size, cell callstack_size); ~context(); From f86c9439e9bf29fb9d3109a2acd7b835d5f9e3b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Apr 2010 15:58:47 -0400 Subject: [PATCH 16/31] windows.errors: redundant USING: list entry --- basis/windows/errors/errors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index a22b6ec007..a3dbaf40ff 100755 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -1,7 +1,7 @@ USING: alien.data kernel locals math math.bitwise windows.kernel32 sequences byte-arrays unicode.categories io.encodings.string io.encodings.utf16n alien.strings -arrays literals windows.types specialized-arrays literals ; +arrays literals windows.types specialized-arrays ; SPECIALIZED-ARRAY: TCHAR IN: windows.errors From be024c228c15b2cceb64314e2637ca1a4d0b2230 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Apr 2010 19:10:21 -0400 Subject: [PATCH 17/31] continuations: faster with-datastack --- core/continuations/continuations-docs.factor | 2 +- core/continuations/continuations.factor | 17 ++++++++--------- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 3710680269..8775e599a6 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -235,7 +235,7 @@ HELP: save-error $low-level-note ; HELP: with-datastack -{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } +{ $values { "stack" sequence } { "quot" quotation } { "new-stack" sequence } } { $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index cfceb1f715..196a12d0d2 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,10 +1,17 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces make math splitting sorting quotations assocs combinators combinators.private accessors words ; IN: continuations +: with-datastack ( stack quot -- new-stack ) + [ + [ [ datastack ] dip swap [ { } like set-datastack ] dip ] dip + swap [ call datastack ] dip + swap [ set-datastack ] dip + ] (( stack quot -- new-stack )) call-effect-unsafe ; + SYMBOL: error SYMBOL: error-continuation SYMBOL: error-thread @@ -90,14 +97,6 @@ SYMBOL: return-continuation : return ( -- * ) return-continuation get continue ; -: with-datastack ( stack quot -- newstack ) - [ - [ - [ [ { } like set-datastack ] dip call datastack ] dip - continue-with - ] (( stack quot continuation -- * )) call-effect-unsafe - ] callcc1 2nip ; - GENERIC: compute-restarts ( error -- seq ) Date: Sat, 3 Apr 2010 20:24:33 -0400 Subject: [PATCH 18/31] Get green threads working on Windows - store stack base and limit in TIB - set up a frame-based structured exception handler in each context's callstack - boot.x86.32.image has now been replaced by boot.winnt-x86.32.image and boot.unix-x86.32.image --- Nmakefile | 2 +- basis/bootstrap/image/image.factor | 9 ++-- basis/compiler/constants/constants.factor | 5 +++ basis/cpu/x86/32/bootstrap.factor | 25 ++++++++--- basis/cpu/x86/32/unix/bootstrap.factor | 14 ++++++ basis/cpu/x86/32/winnt/bootstrap.factor | 54 +++++++++++++++++++++++ basis/cpu/x86/64/bootstrap.factor | 5 +++ basis/cpu/x86/bootstrap.factor | 8 +++- basis/threads/threads-tests.factor | 3 ++ core/bootstrap/primitives.factor | 3 +- vm/callbacks.cpp | 20 +++++++-- vm/code_blocks.cpp | 5 +++ vm/cpu-x86.hpp | 2 +- vm/instruction_operands.hpp | 5 +++ vm/os-windows-nt.cpp | 25 +++-------- vm/os-windows-nt.hpp | 8 +--- vm/vm.hpp | 2 +- 17 files changed, 151 insertions(+), 44 deletions(-) create mode 100644 basis/cpu/x86/32/unix/bootstrap.factor create mode 100644 basis/cpu/x86/32/winnt/bootstrap.factor mode change 100644 => 100755 vm/callbacks.cpp mode change 100644 => 100755 vm/cpu-x86.hpp diff --git a/Nmakefile b/Nmakefile index 0d815b6161..9df7a6a1ee 100755 --- a/Nmakefile +++ b/Nmakefile @@ -2,7 +2,7 @@ LINK_FLAGS = /nologo /DEBUG shell32.lib CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG !ELSE -LINK_FLAGS = /nologo shell32.lib +LINK_FLAGS = /nologo /safeseh:no shell32.lib CL_FLAGS = /nologo /O2 /W3 !ENDIF diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 141a77d2b2..62240f73ce 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -15,10 +15,11 @@ generalizations ; IN: bootstrap.image : arch ( os cpu -- arch ) + [ dup "winnt" = "winnt" "unix" ? ] dip { - { "ppc" [ "-ppc" append ] } - { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] } - [ nip ] + { "ppc" [ drop "-ppc" append ] } + { "x86.32" [ nip "-x86.32" append ] } + { "x86.64" [ nip "-x86.64" append ] } } case ; : my-arch ( -- arch ) @@ -32,7 +33,7 @@ IN: bootstrap.image : images ( -- seq ) { - "x86.32" + "winnt-x86.32" "unix-x86.32" "winnt-x86.64" "unix-x86.64" "linux-ppc" "macosx-ppc" } ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 9769b72801..ac0fcff0ff 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -34,6 +34,10 @@ CONSTANT: deck-bits 18 : context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline : context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline : context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline +: context-callstack-seg-offset ( -- n ) 7 bootstrap-cells ; inline +: segment-start-offset ( -- n ) 0 bootstrap-cells ; inline +: segment-size-offset ( -- n ) 1 bootstrap-cells ; inline +: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 @@ -61,6 +65,7 @@ CONSTANT: rt-megamorphic-cache-hits 8 CONSTANT: rt-vm 9 CONSTANT: rt-cards-offset 10 CONSTANT: rt-decks-offset 11 +CONSTANT: rt-exception-handler 12 : rc-absolute? ( n -- ? ) ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 293d99fe93..9b1a1de23d 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -108,6 +108,14 @@ IN: bootstrap.x86 \ (call) define-combinator-primitive [ + ! Load ds and rs registers + jit-load-vm + jit-load-context + jit-restore-context + + ! Windows-specific setup + ctx-reg jit-update-seh + ! Clear x87 stack, but preserve rounding mode and exception flags ESP 2 SUB ESP [] FNSTCW @@ -122,11 +130,6 @@ IN: bootstrap.x86 ! Unwind stack frames ESP EDX MOV - ! Load ds and rs registers - jit-load-vm - jit-load-context - jit-restore-context - jit-jump-quot ] \ unwind-native-frames define-sub-primitive @@ -253,6 +256,9 @@ IN: bootstrap.x86 ! Load new stack pointer ESP ctx-reg context-callstack-top-offset [+] MOV + ! Windows-specific setup + ctx-reg jit-update-tib + ! Load new ds, rs registers jit-restore-context ; @@ -266,6 +272,9 @@ IN: bootstrap.x86 ! Make the new context active EAX jit-switch-context + ! Windows-specific setup + ctx-reg jit-update-seh + ! Twiddle stack for return ESP 4 ADD @@ -293,6 +302,12 @@ IN: bootstrap.x86 ds-reg 4 ADD ds-reg [] EAX MOV + ! Windows-specific setup + jit-install-seh + + ! Push a fake return address + 0 PUSH + ! Jump to initial quotation EAX EBX [] MOV jit-jump-quot ; diff --git a/basis/cpu/x86/32/unix/bootstrap.factor b/basis/cpu/x86/32/unix/bootstrap.factor new file mode 100644 index 0000000000..1e3bee4961 --- /dev/null +++ b/basis/cpu/x86/32/unix/bootstrap.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: cpu.x86.assembler cpu.x86.assembler.operands kernel +layouts parser sequences ; +IN: bootstrap.x86 + +: jit-save-tib ( -- ) ; +: jit-restore-tib ( -- ) ; +: jit-update-tib ( ctx-reg -- ) drop ; +: jit-install-seh ( -- ) ESP bootstrap-cell ADD ; +: jit-update-seh ( ctx-reg -- ) drop ; + +<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> +call diff --git a/basis/cpu/x86/32/winnt/bootstrap.factor b/basis/cpu/x86/32/winnt/bootstrap.factor new file mode 100644 index 0000000000..b8ee1dacaf --- /dev/null +++ b/basis/cpu/x86/32/winnt/bootstrap.factor @@ -0,0 +1,54 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private compiler.constants +cpu.x86.assembler cpu.x86.assembler.operands kernel layouts +locals parser sequences ; +IN: bootstrap.x86 + +: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ; +: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ; +: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ; + +: jit-save-tib ( -- ) + tib-exception-list-offset [] FS PUSH + tib-stack-base-offset [] FS PUSH + tib-stack-limit-offset [] FS PUSH ; + +: jit-restore-tib ( -- ) + tib-stack-limit-offset [] FS POP + tib-stack-base-offset [] FS POP + tib-exception-list-offset [] FS POP ; + +:: jit-update-tib ( ctx-reg -- ) + ! There's a redundant load here because we're not allowed + ! to clobber ctx-reg. Clobbers EAX. + ! Save callstack base in TIB + EAX ctx-reg context-callstack-seg-offset [+] MOV + EAX EAX segment-end-offset [+] MOV + tib-stack-base-offset [] EAX FS MOV + ! Save callstack limit in TIB + EAX ctx-reg context-callstack-seg-offset [+] MOV + EAX EAX segment-start-offset [+] MOV + tib-stack-limit-offset [] EAX FS MOV ; + +: jit-install-seh ( -- ) + ! Create a new exception record and store it in the TIB. + ! Align stack + ESP 3 bootstrap-cells ADD + ! Exception handler address filled in by callback.cpp + 0 PUSH rc-absolute-cell rt-exception-handler jit-rel + ! No next handler + 0 PUSH + ! This is the new exception handler + tib-exception-list-offset [] ESP FS MOV ; + +:: jit-update-seh ( ctx-reg -- ) + ! Load exception record structure that jit-install-seh + ! created from the bottom of the callstack. Clobbers EAX. + EAX ctx-reg context-callstack-bottom-offset [+] MOV + EAX bootstrap-cell ADD + ! Store exception record in TIB. + tib-exception-list-offset [] EAX FS MOV ; + +<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> +call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 6c0d50f1b7..c7f9901d33 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -26,6 +26,11 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) temp0 1 SAR ; : rex-length ( -- n ) 1 ; +: jit-save-tib ( -- ) ; +: jit-restore-tib ( -- ) ; +: jit-update-tib ( ctx-reg -- ) drop ; +: jit-install-seh ( -- ) ESP bootstrap-cell ADD ; + : jit-call ( name -- ) RAX 0 MOV rc-absolute-cell jit-dlsym RAX CALL ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 961f0c9977..80b56f9f91 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -20,6 +20,8 @@ big-endian off ! Save all non-volatile registers nv-regs [ PUSH ] each + jit-save-tib + ! Load VM into vm-reg vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel @@ -36,7 +38,9 @@ big-endian off ! Load Factor callstack pointer stack-reg nv-reg context-callstack-bottom-offset [+] MOV - stack-reg bootstrap-cell ADD + + nv-reg jit-update-tib + jit-install-seh ! Call into Factor code nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel @@ -55,6 +59,8 @@ big-endian off vm-reg vm-context-offset [+] nv-reg MOV ! Restore non-volatile registers + jit-restore-tib + nv-regs [ POP ] each frame-reg POP diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 742ecaa1f7..01578d4e64 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -56,3 +56,6 @@ yield [ "x" tget "p" get fulfill ] in-thread [ f ] [ "p" get ?promise ] unit-test + +! Test system traps inside threads +[ ] [ [ dup ] in-thread yield ] unit-test diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 8a412b8a14..87963848bf 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -18,7 +18,8 @@ H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file architecture get { - { "x86.32" "x86/32" } + { "winnt-x86.32" "x86/32/winnt" } + { "unix-x86.32" "x86/32/unix" } { "winnt-x86.64" "x86/64/winnt" } { "unix-x86.64" "x86/64/unix" } { "linux-ppc" "ppc/linux" } diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp old mode 100644 new mode 100755 index 6c8165f5c4..fbf36c7cea --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -38,7 +38,12 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va void callback_heap::update(code_block *stub) { - store_callback_operand(stub,1,(cell)callback_entry_point(stub)); +#ifdef WIN32 + cell index = 2; +#else + cell index = 1; +#endif + store_callback_operand(stub,index,(cell)callback_entry_point(stub)); stub->flush_icache(); } @@ -64,12 +69,21 @@ code_block *callback_heap::add(cell owner, cell return_rewind) /* Store VM pointer */ store_callback_operand(stub,0,(cell)parent); - store_callback_operand(stub,2,(cell)parent); + +#ifdef WIN32 + store_callback_operand(stub,1,(cell)&exception_handler); + cell index = 1; +#else + cell index = 0; +#endif + + /* Store VM pointer */ + store_callback_operand(stub,index + 2,(cell)parent); /* On x86, the RET instruction takes an argument which depends on the callback's calling convention */ #if defined(FACTOR_X86) || defined(FACTOR_AMD64) - store_callback_operand(stub,3,return_rewind); + store_callback_operand(stub,index + 3,return_rewind); #endif update(stub); diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 894e49846d..64b218f377 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -225,6 +225,11 @@ void factor_vm::store_external_address(instruction_operand op) case RT_DECKS_OFFSET: op.store_value(decks_offset); break; +#ifdef WINDOWS + case RT_EXCEPTION_HANDLER: + op.store_value(&factor::exception_handler); + break; +#endif default: critical_error("Bad rel type",op.rel_type()); break; diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp old mode 100644 new mode 100755 index bfdcd8afb2..89d7fb792a --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -5,7 +5,7 @@ namespace factor #define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1) -#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell)) +#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell) * 5) inline static void flush_icache(cell start, cell len) {} diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp index dc8aa9d841..66ffddc24e 100644 --- a/vm/instruction_operands.hpp +++ b/vm/instruction_operands.hpp @@ -26,6 +26,10 @@ enum relocation_type { RT_CARDS_OFFSET, /* value of vm->decks_offset */ RT_DECKS_OFFSET, + /* address of exception_handler -- this exists as a separate relocation + type since its used in a situation where relocation arguments cannot + be passed in, and so RT_DLSYM is inappropriate (Windows only) */ + RT_EXCEPTION_HANDLER, }; enum relocation_class { @@ -105,6 +109,7 @@ struct relocation_entry { case RT_MEGAMORPHIC_CACHE_HITS: case RT_CARDS_OFFSET: case RT_DECKS_OFFSET: + case RT_EXCEPTION_HANDLER: return 0; default: critical_error("Bad rel type",rel_type()); diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 2d5881252a..4f90d7f641 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -48,11 +48,8 @@ void sleep_nanos(u64 nsec) Sleep((DWORD)(nsec/1000000)); } -LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) +LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { - PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; - CONTEXT *c = (CONTEXT*)pe->ContextRecord; - c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP); signal_callstack_top = (stack_frame *)c->ESP; @@ -81,35 +78,23 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) MXCSR(c) &= 0xffffffc0; c->EIP = (cell)factor::fp_signal_handler_impl; break; - case 0x40010006: - /* If the Widcomm bluetooth stack is installed, the BTTray.exe - process injects code into running programs. For some reason this - results in random SEH exceptions with this (undocumented) - exception code being raised. The workaround seems to be ignoring - this altogether, since that is what happens if SEH is not - enabled. Don't really have any idea what this exception means. */ - break; default: signal_number = e->ExceptionCode; c->EIP = (cell)factor::misc_signal_handler_impl; break; } - return EXCEPTION_CONTINUE_EXECUTION; + + return ExceptionContinueExecution; } -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe) +LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { - return current_vm()->exception_handler(pe); + return current_vm()->exception_handler(e,frame,c,dispatch); } void factor_vm::c_to_factor_toplevel(cell quot) { - if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler)) - fatal_error("AddVectoredExceptionHandler failed", 0); - c_to_factor(quot); - - RemoveVectoredExceptionHandler((void *)factor::exception_handler); } void factor_vm::open_console() diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index f274d7813f..d84ac97298 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -22,13 +22,7 @@ typedef char symbol_char; #define FACTOR_DLL NULL -#ifdef _MSC_VER - #define FACTOR_STDCALL(return_type) return_type __stdcall -#else - #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type -#endif - -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); +LONG 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 diff --git a/vm/vm.hpp b/vm/vm.hpp index cf2f0ca433..36ec3260d6 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -706,7 +706,7 @@ struct factor_vm #if defined(WINNT) void open_console(); - LONG exception_handler(PEXCEPTION_POINTERS pe); + LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); #endif #else // UNIX From b16d91576cc94dc52edf1ad90d29cc7af8d5132e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Apr 2010 21:11:04 -0400 Subject: [PATCH 19/31] cpu.x86.64: fix typo that caused bootstrap crash --- basis/cpu/x86/64/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index c7f9901d33..a82c8c17e2 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -29,7 +29,7 @@ IN: bootstrap.x86 : jit-save-tib ( -- ) ; : jit-restore-tib ( -- ) ; : jit-update-tib ( ctx-reg -- ) drop ; -: jit-install-seh ( -- ) ESP bootstrap-cell ADD ; +: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ; : jit-call ( name -- ) RAX 0 MOV rc-absolute-cell jit-dlsym From 52736dd94ff4ddf3196d8a57c1a73809b210cbb3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 12:20:56 -0400 Subject: [PATCH 20/31] mason.child: fix unit test for boot image renaming --- extra/mason/child/child-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 6fedac87bd..f8046ac8e5 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -33,7 +33,7 @@ USING: mason.child mason.config tools.test namespaces io kernel sequences ; ] with-scope ] unit-test -[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [ +[ { "./factor.com" "-i=boot.winnt-x86.32.image" "-no-user-init" } ] [ [ "winnt" target-os set "x86.32" target-cpu set From d70cf197f268e9863538a20603f93eb1adbb13a4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 13:53:17 -0500 Subject: [PATCH 21/31] vm: fix compile error --- vm/code_blocks.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 64b218f377..de103cda12 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -227,7 +227,7 @@ void factor_vm::store_external_address(instruction_operand op) break; #ifdef WINDOWS case RT_EXCEPTION_HANDLER: - op.store_value(&factor::exception_handler); + op.store_value((cell)&factor::exception_handler); break; #endif default: From 6e40b77a9fb33b96fce62757100006aee427cba3 Mon Sep 17 00:00:00 2001 From: Sheepson Apprentice Date: Sun, 4 Apr 2010 14:30:29 -0500 Subject: [PATCH 22/31] When curl fails with a 404 error, don't write this error to disk --- build-support/factor.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-support/factor.sh b/build-support/factor.sh index 3a5fb4e253..38bdc8183c 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -68,7 +68,7 @@ set_downloader() { if [[ $? -ne 0 ]] ; then DOWNLOADER=wget else - DOWNLOADER="curl -O" + DOWNLOADER="curl -f -O" fi } From cd05b1007dda4b68b625ab9d345c435d492e18e4 Mon Sep 17 00:00:00 2001 From: Sheepson Apprentice Date: Sun, 4 Apr 2010 14:39:59 -0500 Subject: [PATCH 23/31] Support unix-x86.32 and winnt-x86.32 boot images in factor.sh --- build-support/factor.sh | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index 38bdc8183c..68d138c3ef 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -291,9 +291,15 @@ set_build_info() { elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=winnt-x86.64 MAKE_TARGET=winnt-x86-64 + elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then + MAKE_IMAGE_TARGET=winnt-x86.32 + MAKE_TARGET=winnt-x86-32 elif [[ $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=unix-x86.64 MAKE_TARGET=$OS-x86-64 + elif [[ $ARCH == x86 && $WORD == 32 ]] ; then + MAKE_IMAGE_TARGET=unix-x86.32 + MAKE_TARGET=$OS-x86-32 else MAKE_IMAGE_TARGET=$ARCH.$WORD MAKE_TARGET=$OS-$ARCH-$WORD From ce16c4ec2cfa309f71b4db91fc014e6f7ce7bbdf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 17:46:36 -0400 Subject: [PATCH 24/31] vm: fix callback heap code on 64-bit Windows --- vm/callbacks.cpp | 60 ++++++++++++++++++++++++++++++++++-------------- vm/callbacks.hpp | 4 ++++ 2 files changed, 47 insertions(+), 17 deletions(-) diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp index fbf36c7cea..38479a3cb4 100755 --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -19,7 +19,25 @@ void factor_vm::init_callbacks(cell size) callbacks = new callback_heap(size,this); } -void callback_heap::store_callback_operand(code_block *stub, cell index, cell value) +bool callback_heap::setup_seh_p() +{ +#if defined(WINDOWS) && defined(FACTOR_X86) + return true; +#else + return false; +#endif +} + +bool callback_heap::return_takes_param_p() +{ +#if defined(FACTOR_X86) || defined(FACTOR_AMD64) + return true; +#else + return false; +#endif +} + +instruction_operand callback_heap::callback_operand(code_block *stub, cell index) { tagged code_template(parent->special_objects[CALLBACK_STUB]); @@ -33,17 +51,23 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va offset); instruction_operand op(rel,stub,0); - op.store_value(value); + + return op; +} + +void callback_heap::store_callback_operand(code_block *stub, cell index) +{ + parent->store_external_address(callback_operand(stub,index)); +} + +void callback_heap::store_callback_operand(code_block *stub, cell index, cell value) +{ + callback_operand(stub,index).store_value(value); } void callback_heap::update(code_block *stub) { -#ifdef WIN32 - cell index = 2; -#else - cell index = 1; -#endif - store_callback_operand(stub,index,(cell)callback_entry_point(stub)); + store_callback_operand(stub,setup_seh_p() ? 2 : 1,(cell)callback_entry_point(stub)); stub->flush_icache(); } @@ -70,21 +94,23 @@ code_block *callback_heap::add(cell owner, cell return_rewind) /* Store VM pointer */ store_callback_operand(stub,0,(cell)parent); -#ifdef WIN32 - store_callback_operand(stub,1,(cell)&exception_handler); - cell index = 1; -#else - cell index = 0; -#endif + cell index; + + if(setup_seh_p()) + { + store_callback_operand(stub,1); + index = 1; + } + else + index = 0; /* Store VM pointer */ store_callback_operand(stub,index + 2,(cell)parent); /* On x86, the RET instruction takes an argument which depends on the callback's calling convention */ -#if defined(FACTOR_X86) || defined(FACTOR_AMD64) - store_callback_operand(stub,index + 3,return_rewind); -#endif + if(return_takes_param_p()) + store_callback_operand(stub,index + 3,return_rewind); update(stub); diff --git a/vm/callbacks.hpp b/vm/callbacks.hpp index 607984ad23..a0ab3d6bf9 100644 --- a/vm/callbacks.hpp +++ b/vm/callbacks.hpp @@ -38,6 +38,10 @@ struct callback_heap { return w->entry_point; } + bool setup_seh_p(); + bool return_takes_param_p(); + instruction_operand callback_operand(code_block *stub, cell index); + void store_callback_operand(code_block *stub, cell index); void store_callback_operand(code_block *stub, cell index, cell value); void update(code_block *stub); From c0af678c5bc13c8f096609223ae81a8c8a4afa90 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Apr 2010 19:42:57 -0400 Subject: [PATCH 25/31] cpu.x86.assembler: add support for absolute addressing on x86-64; [RIP+] now behaves like [] did, and [] now does absolute addressing just like in 32-bit mode --- basis/cpu/x86/64/64.factor | 4 ++-- basis/cpu/x86/64/bootstrap.factor | 2 +- basis/cpu/x86/assembler/assembler-tests.factor | 10 ++++++++-- basis/cpu/x86/assembler/assembler.factor | 16 ++++++++++------ basis/cpu/x86/assembler/operands/operands.factor | 14 ++++++++------ 5 files changed, 29 insertions(+), 17 deletions(-) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 7e1c5c1f48..4dfb250348 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -55,13 +55,13 @@ M: x86.64 %vm-field-ptr ( dst offset -- ) : param@ ( n -- op ) reserved-stack-space + stack@ ; M: x86.64 %prologue ( n -- ) - temp-reg -7 [] LEA + temp-reg -7 [RIP+] LEA dup PUSH temp-reg PUSH stack-reg swap 3 cells - SUB ; M: x86.64 %prepare-jump - pic-tail-reg xt-tail-pic-offset [] LEA ; + pic-tail-reg xt-tail-pic-offset [RIP+] LEA ; : load-cards-offset ( dst -- ) 0 MOV rc-absolute-cell rel-cards-offset ; diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index a82c8c17e2..69734df225 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -47,7 +47,7 @@ IN: bootstrap.x86 ] jit-prolog jit-define [ - temp3 5 [] LEA + temp3 5 [RIP+] LEA 0 JMP rc-relative rt-entry-point-pic-tail jit-rel ] jit-word-jump jit-define diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 0a6ae5a484..8ed789f392 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -1,5 +1,5 @@ USING: cpu.x86.assembler cpu.x86.assembler.operands -kernel tools.test namespaces make ; +kernel tools.test namespaces make layouts ; IN: cpu.x86.assembler.tests [ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test @@ -164,5 +164,11 @@ IN: cpu.x86.assembler.tests [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test -[ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test +bootstrap-cell 4 = [ + [ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test +] when +bootstrap-cell 8 = [ + [ { 72 137 13 123 0 0 0 } ] [ [ 123 [RIP+] RCX MOV ] { } make ] unit-test + [ { 101 72 137 12 37 123 0 0 0 } ] [ [ 123 [] GS RCX MOV ] { } make ] unit-test +] when diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 32eeaaad1d..b91083dad1 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff. +! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io.binary kernel combinators kernel.private math -math.bitwise locals namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.operands -cpu.x86.assembler.operands.private ; +USING: arrays io.binary kernel combinators +combinators.short-circuit math math.bitwise locals namespaces +make sequences words system layouts math.order accessors +cpu.x86.assembler.operands cpu.x86.assembler.operands.private ; QUALIFIED: sequences IN: cpu.x86.assembler @@ -22,7 +22,11 @@ IN: cpu.x86.assembler GENERIC: sib-present? ( op -- ? ) M: indirect sib-present? - [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ; + { + [ base>> { ESP RSP R12 } member? ] + [ index>> ] + [ scale>> ] + } 1|| ; M: register sib-present? drop f ; diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor index bd9a3f6cdd..e8d98cde17 100644 --- a/basis/cpu/x86/assembler/operands/operands.factor +++ b/basis/cpu/x86/assembler/operands/operands.factor @@ -1,13 +1,9 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff. +! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words math accessors sequences namespaces assocs layouts cpu.x86.assembler.syntax ; IN: cpu.x86.assembler.operands -! In 32-bit mode, { 1234 } is absolute indirect addressing. -! In 64-bit mode, { 1234 } is RIP-relative. -! Beware! - REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ; ALIAS: AH SPL @@ -90,7 +86,13 @@ M: object operand-64? drop f ; PRIVATE> : [] ( reg/displacement -- indirect ) - dup integer? [ [ f f f ] dip ] [ f f f ] if ; + dup integer? + [ [ f f bootstrap-cell 8 = 0 f ? ] dip ] + [ f f f ] + if ; + +: [RIP+] ( displacement -- indirect ) + [ f f f ] dip ; : [+] ( reg displacement -- indirect ) dup integer? From 9b44451682caa17361b68b25be2a85135bb79652 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Apr 2010 14:49:32 -0500 Subject: [PATCH 26/31] Safe SEH is better than abstinence --- Nmakefile | 8 +++++++- vm/os-windows-nt.cpp | 2 +- vm/os-windows-nt.hpp | 2 +- vm/safeseh.asm | 5 +++++ 4 files changed, 14 insertions(+), 3 deletions(-) create mode 100755 vm/safeseh.asm diff --git a/Nmakefile b/Nmakefile index 9df7a6a1ee..dc28e1884c 100755 --- a/Nmakefile +++ b/Nmakefile @@ -2,10 +2,12 @@ LINK_FLAGS = /nologo /DEBUG shell32.lib CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG !ELSE -LINK_FLAGS = /nologo /safeseh:no shell32.lib +LINK_FLAGS = /nologo /safeseh shell32.lib CL_FLAGS = /nologo /O2 /W3 !ENDIF +ML_FLAGS = /nologo /safeseh + EXE_OBJS = vm\main-windows-nt.obj vm\factor.res DLL_OBJS = vm\os-windows-nt.obj \ @@ -47,6 +49,7 @@ DLL_OBJS = vm\os-windows-nt.obj \ vm\profiler.obj \ vm\quotations.obj \ vm\run.obj \ + vm\safeseh.obj \ vm\strings.obj \ vm\to_tenured_collector.obj \ vm\tuples.obj \ @@ -60,6 +63,9 @@ DLL_OBJS = vm\os-windows-nt.obj \ .c.obj: cl $(CL_FLAGS) /Fo$@ /c $< +.asm.obj: + ml $(ML_FLAGS) /Fo$@ /c $< + .rs.res: rc $< diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 4f90d7f641..711b2a8445 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -87,7 +87,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, return ExceptionContinueExecution; } -LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) +extern "C" LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { return current_vm()->exception_handler(e,frame,c,dispatch); } diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index d84ac97298..2ba75ccf54 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -22,7 +22,7 @@ typedef char symbol_char; #define FACTOR_DLL NULL -LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); +extern "C" LONG 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 diff --git a/vm/safeseh.asm b/vm/safeseh.asm new file mode 100755 index 0000000000..fb706c1331 --- /dev/null +++ b/vm/safeseh.asm @@ -0,0 +1,5 @@ +.386 +.model flat +exception_handler proto +.safeseh exception_handler +end From ff0e084f94f4a58a433756bca7b696f4ce4e3bdf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Apr 2010 15:48:09 -0500 Subject: [PATCH 27/31] vm: dllexport exception_handler for great justice --- vm/os-windows-nt.cpp | 2 +- vm/os-windows-nt.hpp | 2 +- vm/platform.hpp | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 711b2a8445..b7f86233a1 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -87,7 +87,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, return ExceptionContinueExecution; } -extern "C" LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) +VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { return current_vm()->exception_handler(e,frame,c,dispatch); } diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index 2ba75ccf54..60990c0986 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -22,7 +22,7 @@ typedef char symbol_char; #define FACTOR_DLL NULL -extern "C" LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); +VM_C_API LONG 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 diff --git a/vm/platform.hpp b/vm/platform.hpp index a71aae1e89..e5a07a05d4 100755 --- a/vm/platform.hpp +++ b/vm/platform.hpp @@ -3,8 +3,8 @@ #include "os-windows-ce.hpp" #include "os-windows.hpp" #elif defined(WINNT) - #include "os-windows-nt.hpp" #include "os-windows.hpp" + #include "os-windows-nt.hpp" #if defined(FACTOR_AMD64) #include "os-windows-nt.64.hpp" From 9ec94f242d95de50048cb91169647dd58c7008e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Apr 2010 03:07:03 -0500 Subject: [PATCH 28/31] Dont use literals twice --- basis/windows/winsock/winsock.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index 49a3d6e9fa..4dd7d7385c 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel literals math sequences windows.types windows.kernel32 windows.errors math.bitwise io.encodings.utf16n -classes.struct windows.com.syntax init literals ; +classes.struct windows.com.syntax init ; FROM: alien.c-types => short ; IN: windows.winsock From eac2849833289dd4e4604ab5ccf13885e265a2c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Apr 2010 17:57:18 -0500 Subject: [PATCH 29/31] Temporary fix for directx bindings until I revert flags{ patch or parsing words get redone --- .../directx/d3d9types/d3d9types.factor | 60 +++++++++---------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/basis/windows/directx/d3d9types/d3d9types.factor b/basis/windows/directx/d3d9types/d3d9types.factor index 618d3c79e5..a9485a8fcf 100644 --- a/basis/windows/directx/d3d9types/d3d9types.factor +++ b/basis/windows/directx/d3d9types/d3d9types.factor @@ -759,25 +759,25 @@ CONSTANT: D3DSHADER_ADDRMODE_FORCE_DWORD HEX: 7fffffff CONSTANT: D3DVS_SWIZZLE_SHIFT 16 CONSTANT: D3DVS_SWIZZLE_MASK HEX: 00FF0000 -: D3DVS_X_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT shift ; inline -: D3DVS_X_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT shift ; inline -: D3DVS_X_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT shift ; inline -: D3DVS_X_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT shift ; inline +CONSTANT: D3DVS_X_X $[ 0 16 shift ] +CONSTANT: D3DVS_X_Y $[ 1 16 shift ] +CONSTANT: D3DVS_X_Z $[ 2 16 shift ] +CONSTANT: D3DVS_X_W $[ 3 16 shift ] -: D3DVS_Y_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline -: D3DVS_Y_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline -: D3DVS_Y_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline -: D3DVS_Y_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline +CONSTANT: D3DVS_Y_X $[ 0 16 2 + shift ] +CONSTANT: D3DVS_Y_Y $[ 1 16 2 + shift ] +CONSTANT: D3DVS_Y_Z $[ 2 16 2 + shift ] +CONSTANT: D3DVS_Y_W $[ 3 16 2 + shift ] -: D3DVS_Z_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline -: D3DVS_Z_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline -: D3DVS_Z_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline -: D3DVS_Z_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline +CONSTANT: D3DVS_Z_X $[ 0 16 4 + shift ] +CONSTANT: D3DVS_Z_Y $[ 1 16 4 + shift ] +CONSTANT: D3DVS_Z_Z $[ 2 16 4 + shift ] +CONSTANT: D3DVS_Z_W $[ 3 16 4 + shift ] -: D3DVS_W_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline -: D3DVS_W_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline -: D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline -: D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline +CONSTANT: D3DVS_W_X $[ 0 16 6 + shift ] +CONSTANT: D3DVS_W_Y $[ 1 16 6 + shift ] +CONSTANT: D3DVS_W_Z $[ 2 16 6 + shift ] +CONSTANT: D3DVS_W_W $[ 3 16 6 + shift ] CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W } @@ -787,20 +787,20 @@ CONSTANT: D3DSP_SRCMOD_SHIFT 24 CONSTANT: D3DSP_SRCMOD_MASK HEX: 0F000000 TYPEDEF: int D3DSHADER_PARAM_SRCMOD_TYPE -: D3DSPSM_NONE ( -- n ) 0 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_NEG ( -- n ) 1 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_BIAS ( -- n ) 2 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_BIASNEG ( -- n ) 3 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_SIGN ( -- n ) 4 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_SIGNNEG ( -- n ) 5 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_COMP ( -- n ) 6 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_X2 ( -- n ) 7 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_X2NEG ( -- n ) 8 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_DZ ( -- n ) 9 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_DW ( -- n ) 10 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_ABS ( -- n ) 11 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_ABSNEG ( -- n ) 12 D3DSP_SRCMOD_SHIFT shift ; inline -: D3DSPSM_NOT ( -- n ) 13 D3DSP_SRCMOD_SHIFT shift ; inline +CONSTANT: D3DSPSM_NONE $[ 0 24 shift ] +CONSTANT: D3DSPSM_NEG $[ 1 24 shift ] +CONSTANT: D3DSPSM_BIAS $[ 2 24 shift ] +CONSTANT: D3DSPSM_BIASNEG $[ 3 24 shift ] +CONSTANT: D3DSPSM_SIGN $[ 4 24 shift ] +CONSTANT: D3DSPSM_SIGNNEG $[ 5 24 shift ] +CONSTANT: D3DSPSM_COMP $[ 6 24 shift ] +CONSTANT: D3DSPSM_X2 $[ 7 24 shift ] +CONSTANT: D3DSPSM_X2NEG $[ 8 24 shift ] +CONSTANT: D3DSPSM_DZ $[ 9 24 shift ] +CONSTANT: D3DSPSM_DW $[ 10 24 shift ] +CONSTANT: D3DSPSM_ABS $[ 11 24 shift ] +CONSTANT: D3DSPSM_ABSNEG $[ 12 24 shift ] +CONSTANT: D3DSPSM_NOT $[ 13 24 shift ] CONSTANT: D3DSPSM_FORCE_DWORD HEX: 7fffffff : D3DPS_VERSION ( major minor -- n ) From d6fb134d5f8108a0d53d771e28cf3c446d3b1d3a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Apr 2010 17:19:43 -0400 Subject: [PATCH 30/31] kernel: add examples for if, when, unless and if* --- core/kernel/kernel-docs.factor | 64 +++++++++++++++++++++++++++++++--- 1 file changed, 60 insertions(+), 4 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 064978f99b..f977a0487b 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -575,19 +575,51 @@ HELP: if { $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation." $nl -"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ; +"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } +{ $examples + { $example + "USING: io kernel math ;" + "10 3 < [ \"Math is broken\" print ] [ \"Math is good\" print ] if" + "Math is good" + } +} ; HELP: when { $values { "?" "a generalized boolean" } { "true" quotation } } { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation." $nl -"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; +"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } +{ $examples + { $example + "USING: kernel math prettyprint ;" + "-5 dup 0 < [ 3 + ] when ." + "-2" + } +} ; HELP: unless { $values { "?" "a generalized boolean" } { "false" quotation } } { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation." $nl -"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ; +"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } +{ $examples + { $example + "USING: kernel math prettyprint sequences ;" + "IN: scratchpad" + "" + "CONSTANT: american-cities {" + " \"San Francisco\"" + " \"Los Angeles\"" + " \"New York\"" + "}" + "" + ": add-tax ( price city -- price' )" + " american-cities member? [ 1.1 * ] unless ;" + "" + "123 \"Ottawa\" add-tax ." + "135.3" + } +} ; HELP: if* { $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..b )" } } { "false" { $quotation "( ..a -- ..b )" } } } @@ -596,7 +628,31 @@ $nl "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called." $nl "The following two lines are equivalent:" -{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ; +{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } +{ $examples + "Notice how in this example, the same value is tested by the conditional, and then used in the true branch; the false branch does not need to drop the value because of how " { $link if* } " works:" + { $example + "USING: assocs io kernel math.parser ;" + "IN: scratchpad" + "" + ": curry-price ( meat -- price ) + { + { \"Beef\" 10 } + { \"Chicken\" 12 } + { \"Lamb\" 13 } + } at ; + +: order-curry ( meat -- ) + curry-price [ + \"Your order will be \" write + number>string write + \" dollars.\" write + ] [ \"Invalid order.\" print ] if* ;" + "" + "\"Deer\" order-curry" + "Invalid order." + } +} ; HELP: when* { $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } } From 430a05dcea92d6a0148a1437246ebff69a8f1333 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Apr 2010 19:06:51 -0400 Subject: [PATCH 31/31] Store stack bounds in TIB on win64 to make C++ exceptions work --- Nmakefile | 2 +- basis/cpu/x86/32/bootstrap.factor | 3 -- basis/cpu/x86/32/unix/bootstrap.factor | 14 +++----- basis/cpu/x86/32/winnt/bootstrap.factor | 46 ++++++++----------------- basis/cpu/x86/64/bootstrap.factor | 12 ++----- basis/cpu/x86/64/unix/bootstrap.factor | 5 +-- basis/cpu/x86/64/winnt/bootstrap.factor | 13 +++++-- basis/cpu/x86/unix/bootstrap.factor | 13 +++++++ basis/cpu/x86/winnt/bootstrap.factor | 32 +++++++++++++++++ 9 files changed, 81 insertions(+), 59 deletions(-) create mode 100644 basis/cpu/x86/unix/bootstrap.factor create mode 100644 basis/cpu/x86/winnt/bootstrap.factor diff --git a/Nmakefile b/Nmakefile index dc28e1884c..02d2b5f1ed 100755 --- a/Nmakefile +++ b/Nmakefile @@ -1,5 +1,5 @@ !IF DEFINED(DEBUG) -LINK_FLAGS = /nologo /DEBUG shell32.lib +LINK_FLAGS = /nologo /safeseh /DEBUG shell32.lib CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG !ELSE LINK_FLAGS = /nologo /safeseh shell32.lib diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 9b1a1de23d..b2cd241df1 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -330,6 +330,3 @@ IN: bootstrap.x86 jit-delete-current-context jit-start-context ] \ (start-context-and-delete) define-sub-primitive - -<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> -call diff --git a/basis/cpu/x86/32/unix/bootstrap.factor b/basis/cpu/x86/32/unix/bootstrap.factor index 1e3bee4961..56d18511e4 100644 --- a/basis/cpu/x86/32/unix/bootstrap.factor +++ b/basis/cpu/x86/32/unix/bootstrap.factor @@ -1,14 +1,8 @@ ! Copyright (C) 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: cpu.x86.assembler cpu.x86.assembler.operands kernel -layouts parser sequences ; +USING: kernel parser sequences ; IN: bootstrap.x86 -: jit-save-tib ( -- ) ; -: jit-restore-tib ( -- ) ; -: jit-update-tib ( ctx-reg -- ) drop ; -: jit-install-seh ( -- ) ESP bootstrap-cell ADD ; -: jit-update-seh ( ctx-reg -- ) drop ; - -<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> -call +<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call +<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call +<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/32/winnt/bootstrap.factor b/basis/cpu/x86/32/winnt/bootstrap.factor index b8ee1dacaf..5628632e6c 100644 --- a/basis/cpu/x86/32/winnt/bootstrap.factor +++ b/basis/cpu/x86/32/winnt/bootstrap.factor @@ -5,50 +5,32 @@ cpu.x86.assembler cpu.x86.assembler.operands kernel layouts locals parser sequences ; IN: bootstrap.x86 -: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ; -: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ; -: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ; +: tib-segment ( -- ) FS ; +: tib-temp ( -- reg ) EAX ; -: jit-save-tib ( -- ) - tib-exception-list-offset [] FS PUSH - tib-stack-base-offset [] FS PUSH - tib-stack-limit-offset [] FS PUSH ; - -: jit-restore-tib ( -- ) - tib-stack-limit-offset [] FS POP - tib-stack-base-offset [] FS POP - tib-exception-list-offset [] FS POP ; - -:: jit-update-tib ( ctx-reg -- ) - ! There's a redundant load here because we're not allowed - ! to clobber ctx-reg. Clobbers EAX. - ! Save callstack base in TIB - EAX ctx-reg context-callstack-seg-offset [+] MOV - EAX EAX segment-end-offset [+] MOV - tib-stack-base-offset [] EAX FS MOV - ! Save callstack limit in TIB - EAX ctx-reg context-callstack-seg-offset [+] MOV - EAX EAX segment-start-offset [+] MOV - tib-stack-limit-offset [] EAX FS MOV ; +<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call : jit-install-seh ( -- ) ! Create a new exception record and store it in the TIB. + ! Clobbers tib-temp. ! Align stack ESP 3 bootstrap-cells ADD ! Exception handler address filled in by callback.cpp - 0 PUSH rc-absolute-cell rt-exception-handler jit-rel + tib-temp 0 MOV rc-absolute-cell rt-exception-handler jit-rel + tib-temp PUSH ! No next handler 0 PUSH ! This is the new exception handler - tib-exception-list-offset [] ESP FS MOV ; + tib-exception-list-offset [] ESP tib-segment MOV ; :: jit-update-seh ( ctx-reg -- ) ! Load exception record structure that jit-install-seh - ! created from the bottom of the callstack. Clobbers EAX. - EAX ctx-reg context-callstack-bottom-offset [+] MOV - EAX bootstrap-cell ADD + ! created from the bottom of the callstack. + ! Clobbers tib-temp. + tib-temp ctx-reg context-callstack-bottom-offset [+] MOV + tib-temp bootstrap-cell ADD ! Store exception record in TIB. - tib-exception-list-offset [] EAX FS MOV ; + tib-exception-list-offset [] tib-temp tib-segment MOV ; -<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> -call +<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call +<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 69734df225..68c3d8b702 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -26,11 +26,6 @@ IN: bootstrap.x86 : fixnum>slot@ ( -- ) temp0 1 SAR ; : rex-length ( -- n ) 1 ; -: jit-save-tib ( -- ) ; -: jit-restore-tib ( -- ) ; -: jit-update-tib ( ctx-reg -- ) drop ; -: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ; - : jit-call ( name -- ) RAX 0 MOV rc-absolute-cell jit-dlsym RAX CALL ; @@ -238,7 +233,9 @@ IN: bootstrap.x86 RSP ctx-reg context-callstack-top-offset [+] MOV ! Load new ds, rs registers - jit-restore-context ; + jit-restore-context + + ctx-reg jit-update-tib ; : jit-pop-context-and-param ( -- ) arg1 ds-reg [] MOV @@ -293,6 +290,3 @@ IN: bootstrap.x86 jit-delete-current-context jit-start-context ] \ (start-context-and-delete) define-sub-primitive - -<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> -call diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor index d19b5306a0..cffb12902c 100644 --- a/basis/cpu/x86/64/unix/bootstrap.factor +++ b/basis/cpu/x86/64/unix/bootstrap.factor @@ -12,5 +12,6 @@ IN: bootstrap.x86 : arg3 ( -- reg ) RDX ; : arg4 ( -- reg ) RCX ; -<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> -call +<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call +<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call +<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor index 113a13918f..f816980e57 100644 --- a/basis/cpu/x86/64/winnt/bootstrap.factor +++ b/basis/cpu/x86/64/winnt/bootstrap.factor @@ -5,6 +5,8 @@ vocabs sequences cpu.x86.assembler parser cpu.x86.assembler.operands ; IN: bootstrap.x86 +DEFER: stack-reg + : stack-frame-size ( -- n ) 8 bootstrap-cells ; : nv-regs ( -- seq ) { RBX RSI RDI R12 R13 R14 R15 } ; : arg1 ( -- reg ) RCX ; @@ -12,5 +14,12 @@ IN: bootstrap.x86 : arg3 ( -- reg ) R8 ; : arg4 ( -- reg ) R9 ; -<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> -call +: tib-segment ( -- ) GS ; +: tib-temp ( -- reg ) R11 ; + +: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ; +: jit-update-seh ( ctx-reg -- ) drop ; + +<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call +<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call +<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call diff --git a/basis/cpu/x86/unix/bootstrap.factor b/basis/cpu/x86/unix/bootstrap.factor new file mode 100644 index 0000000000..20dd738ac6 --- /dev/null +++ b/basis/cpu/x86/unix/bootstrap.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: cpu.x86.assembler cpu.x86.assembler.operands kernel +layouts ; +IN: bootstrap.x86 + +DEFER: stack-reg + +: jit-save-tib ( -- ) ; +: jit-restore-tib ( -- ) ; +: jit-update-tib ( ctx-reg -- ) drop ; +: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ; +: jit-update-seh ( ctx-reg -- ) drop ; diff --git a/basis/cpu/x86/winnt/bootstrap.factor b/basis/cpu/x86/winnt/bootstrap.factor new file mode 100644 index 0000000000..b81c1eb604 --- /dev/null +++ b/basis/cpu/x86/winnt/bootstrap.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: bootstrap.image.private compiler.constants +cpu.x86.assembler cpu.x86.assembler.operands kernel layouts +locals parser sequences ; +IN: bootstrap.x86 + +: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ; +: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ; +: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ; + +: jit-save-tib ( -- ) + tib-exception-list-offset [] tib-segment PUSH + tib-stack-base-offset [] tib-segment PUSH + tib-stack-limit-offset [] tib-segment PUSH ; + +: jit-restore-tib ( -- ) + tib-stack-limit-offset [] tib-segment POP + tib-stack-base-offset [] tib-segment POP + tib-exception-list-offset [] tib-segment POP ; + +:: jit-update-tib ( ctx-reg -- ) + ! There's a redundant load here because we're not allowed + ! to clobber ctx-reg. Clobbers tib-temp. + ! Save callstack base in TIB + tib-temp ctx-reg context-callstack-seg-offset [+] MOV + tib-temp tib-temp segment-end-offset [+] MOV + tib-stack-base-offset [] tib-temp tib-segment MOV + ! Save callstack limit in TIB + tib-temp ctx-reg context-callstack-seg-offset [+] MOV + tib-temp tib-temp segment-start-offset [+] MOV + tib-stack-limit-offset [] tib-temp tib-segment MOV ;