diff --git a/Nmakefile b/Nmakefile index a73a59d0f5..02d2b5f1ed 100755 --- a/Nmakefile +++ b/Nmakefile @@ -1,12 +1,14 @@ !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 shell32.lib +LINK_FLAGS = /nologo /safeseh shell32.lib CL_FLAGS = /nologo /O2 /W3 !ENDIF -EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res +ML_FLAGS = /nologo /safeseh + +EXE_OBJS = vm\main-windows-nt.obj vm\factor.res DLL_OBJS = vm\os-windows-nt.obj \ vm\os-windows.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,10 +63,13 @@ DLL_OBJS = vm\os-windows-nt.obj \ .c.obj: cl $(CL_FLAGS) /Fo$@ /c $< +.asm.obj: + ml $(ML_FLAGS) /Fo$@ /c $< + .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 +77,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 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/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/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 4ffe062090..ffccf9f118 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/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/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index c54ce443d6..5793482a27 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -445,13 +445,17 @@ STRUCT: double-rect [ "example" set-global 2drop ] alien-callback ; : double-rect-test ( arg -- arg' ) - f f rot + [ f f ] 2dip double-rect-callback 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/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/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 6f3865497b..7abf1673d4 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/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 diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index dd9252129a..551693d5c7 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -58,11 +58,9 @@ CONSTANT: vm-reg 15 : %load-vm-addr ( reg -- ) vm-reg MR ; -M: ppc %vm-field ( dst field -- ) - [ vm-reg ] dip vm-field-offset LWZ ; +M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ; -M: ppc %vm-field-ptr ( dst field -- ) - [ vm-reg ] dip vm-field-offset ADDI ; +M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ; GENERIC: loc-reg ( loc -- reg ) @@ -385,7 +383,7 @@ M: ppc %set-alien-float -rot STFS ; M: ppc %set-alien-double -rot STFD ; : load-zone-ptr ( reg -- ) - "nursery" %vm-field-ptr ; + vm-reg "nursery" vm-field-offset ADDI ; : load-allot-ptr ( nursery-ptr allot-ptr -- ) [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ; @@ -567,8 +565,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) } case ; : next-param@ ( n -- reg x ) - 2 1 stack-frame get total-size>> LWZ - [ 2 ] dip param@ ; + [ 17 ] dip param@ ; : store-to-frame ( src n rep -- ) { @@ -604,14 +601,14 @@ M: ppc %push-stack ( -- ) int-regs return-reg ds-reg 0 STW ; M: ppc %push-context-stack ( -- ) - 11 "ctx" %vm-field + 11 %context 12 11 "datastack" context-field-offset LWZ 12 12 4 ADDI 12 11 "datastack" context-field-offset STW int-regs return-reg 12 0 STW ; M: ppc %pop-context-stack ( -- ) - 11 "ctx" %vm-field + 11 %context 12 11 "datastack" context-field-offset LWZ int-regs return-reg 12 0 LWZ 12 12 4 SUBI @@ -677,12 +674,12 @@ M: ppc %box-large-struct ( n c-type -- ) "from_value_struct" f %alien-invoke ; M:: ppc %restore-context ( temp1 temp2 -- ) - temp1 "ctx" %vm-field + temp1 %context ds-reg temp1 "datastack" context-field-offset LWZ rs-reg temp1 "retainstack" context-field-offset LWZ ; M:: ppc %save-context ( temp1 temp2 -- ) - temp1 "ctx" %vm-field + temp1 %context 1 temp1 "callstack-top" context-field-offset STW ds-reg temp1 "datastack" context-field-offset STW rs-reg temp1 "retainstack" context-field-offset STW ; @@ -751,14 +748,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 ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 02f9380e01..20fd65fdac 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -29,10 +29,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@ ; @@ -182,7 +185,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 ; @@ -257,6 +260,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..b2cd241df1 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 @@ -110,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 @@ -124,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 @@ -255,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 ; @@ -268,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 @@ -295,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 ; @@ -317,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 new file mode 100644 index 0000000000..56d18511e4 --- /dev/null +++ b/basis/cpu/x86/32/unix/bootstrap.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel parser sequences ; +IN: bootstrap.x86 + +<< "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 new file mode 100644 index 0000000000..5628632e6c --- /dev/null +++ b/basis/cpu/x86/32/winnt/bootstrap.factor @@ -0,0 +1,36 @@ +! 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-segment ( -- ) FS ; +: tib-temp ( -- reg ) EAX ; + +<< "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 + 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 tib-segment MOV ; + +:: jit-update-seh ( ctx-reg -- ) + ! Load exception record structure that jit-install-seh + ! 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 [] tib-temp tib-segment MOV ; + +<< "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/64.factor b/basis/cpu/x86/64/64.factor index 87578dd8db..432d210bec 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -43,20 +43,23 @@ 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 ; 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 ; @@ -109,7 +112,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 ; @@ -226,6 +229,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..68c3d8b702 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -42,7 +42,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 @@ -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 @@ -234,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 @@ -289,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/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? 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/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 ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index a071485de0..028cca48e3 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -425,8 +425,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 ; @@ -458,7 +463,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 @@ -479,7 +484,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 ; @@ -1405,7 +1410,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 ; @@ -1413,7 +1418,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 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/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 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-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/basis/threads/threads.factor b/basis/threads/threads.factor index 117e941aa7..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 ) @@ -80,23 +83,13 @@ sleep-entry ; : thread-registered? ( thread -- ? ) id>> threads key? ; -ERROR: already-stopped thread ; - -: check-unregistered ( thread -- thread ) - dup thread-registered? [ already-stopped ] when ; - -ERROR: not-running thread ; - -: check-registered ( thread -- thread ) - dup thread-registered? [ not-running ] unless ; - > threads set-at ; + dup id>> threads set-at ; : unregister-thread ( thread -- ) - check-registered id>> threads delete-at ; + id>> threads delete-at ; : set-self ( thread -- ) 63 set-special-object ; inline @@ -106,7 +99,7 @@ PRIVATE> 65 special-object { dlist } declare ; inline : sleep-queue ( -- heap ) - 66 special-object { dlist } declare ; inline + 66 special-object { min-heap } declare ; inline : new-thread ( quot name class -- thread ) new @@ -120,16 +113,13 @@ PRIVATE> \ thread new-thread ; : resume ( thread -- ) - f >>state - check-registered run-queue push-front ; + f >>state run-queue push-front ; : resume-now ( thread -- ) - f >>state - check-registered run-queue push-back ; + f >>state run-queue push-back ; : resume-with ( obj thread -- ) - f >>state - check-registered 2array run-queue push-front ; + f >>state 2array run-queue push-front ; : sleep-time ( -- nanos/f ) { @@ -150,22 +140,19 @@ DEFER: stop >sleep-entry drop ; + dupd sleep-queue heap-push* >>sleep-entry drop ; -: expire-sleep? ( heap -- ? ) - dup heap-empty? +: expire-sleep? ( -- ? ) + sleep-queue dup heap-empty? [ drop f ] [ heap-peek nip nano-count <= ] if ; : expire-sleep ( thread -- ) f >>sleep-entry resume ; : expire-sleep-loop ( -- ) - sleep-queue - [ dup expire-sleep? ] - [ dup heap-pop drop expire-sleep ] - while - drop ; + [ expire-sleep? ] + [ sleep-queue heap-pop drop expire-sleep ] + while ; CONSTANT: [start] [ @@ -177,7 +164,9 @@ CONSTANT: [start] : no-runnable-threads ( -- ) die ; -: (next) ( obj thread -- obj' ) +GENERIC: (next) ( obj thread -- obj' ) + +M: thread (next) dup runnable>> [ context>> box> set-context ] [ t >>runnable drop [start] start-context ] if ; 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/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 ) 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 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 diff --git a/build-support/factor.sh b/build-support/factor.sh index 3a5fb4e253..68d138c3ef 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 } @@ -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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 52ee1e14b4..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" } @@ -538,7 +539,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/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 ) string write + \" dollars.\" write + ] [ \"Invalid order.\" print ] if* ;" + "" + "\"Deer\" order-curry" + "Invalid order." + } +} ; HELP: when* { $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } } 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 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 -- ) 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 diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp old mode 100644 new mode 100755 index 6c8165f5c4..38479a3cb4 --- 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,12 +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) { - store_callback_operand(stub,1,(cell)callback_entry_point(stub)); + store_callback_operand(stub,setup_seh_p() ? 2 : 1,(cell)callback_entry_point(stub)); stub->flush_icache(); } @@ -64,13 +93,24 @@ 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); + + 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,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); diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 894e49846d..de103cda12 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((cell)&factor::exception_handler); + break; +#endif default: critical_error("Bad rel type",op.rel_type()); break; 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/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..582fab173f 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; @@ -27,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(); @@ -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/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/factor.cpp b/vm/factor.cpp index e726ebf6da..89da7a2db7 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 FACTOR_PPC + p->callstack_size = 256 * sizeof(cell); +#else p->callstack_size = 128 * sizeof(cell); +#endif p->code_size = 8 * sizeof(cell); p->young_size = sizeof(cell) / 4; 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/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/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 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.cpp b/vm/os-windows-nt.cpp index 2d5881252a..b7f86233a1 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) +VM_C_API 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 c5e721c56d..60990c0986 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -20,15 +20,9 @@ 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 -#else - #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type -#endif - -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); +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" 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/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 diff --git a/vm/vm.hpp b/vm/vm.hpp index ad74a8e090..36ec3260d6 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) { @@ -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