!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 \
vm\profiler.obj \
vm\quotations.obj \
vm\run.obj \
+ vm\safeseh.obj \
vm\strings.obj \
vm\to_tenured_collector.obj \
vm\tuples.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
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
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 )
: images ( -- seq )
{
- "x86.32"
+ "winnt-x86.32" "unix-x86.32"
"winnt-x86.64" "unix-x86.64"
"linux-ppc" "macosx-ppc"
} ;
\r
: >box ( value box -- )\r
dup occupied>>\r
- [ box-full ] [ t >>occupied (>>value) ] if ;\r
+ [ box-full ] [ t >>occupied (>>value) ] if ; inline\r
\r
ERROR: box-empty box ;\r
\r
dup occupied>> [ box-empty ] unless ; inline\r
\r
: box> ( box -- value )\r
- check-box [ f ] change-value f >>occupied drop ;\r
+ check-box [ f ] change-value f >>occupied drop ; inline\r
\r
: ?box ( box -- value/f ? )\r
- dup occupied>> [ box> t ] [ drop f f ] if ;\r
+ dup occupied>> [ box> t ] [ drop f f ] if ; inline\r
\r
: if-box? ( box quot -- )\r
[ ?box ] dip [ drop ] if ; inline\r
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
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 ;
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
##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
{ 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+ ] }
-! 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 ( -- )
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
: 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
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? ;
[ "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> double-rect-test >double-rect< ] unit-test
+[
+ 1.0 2.0 3.0 4.0 <double-rect>
+ double-rect-callback double-rect-test
+ >double-rect<
+] unit-test
STRUCT: test_struct_14
{ x1 double }
IN: concurrency.conditions\r
\r
: notify-1 ( deque -- )\r
- dup deque-empty? [ drop ] [ pop-back resume-now ] if ;\r
+ dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline\r
\r
: notify-all ( deque -- )\r
- [ resume-now ] slurp-deque ;\r
+ [ resume-now ] slurp-deque ; inline\r
\r
: queue-timeout ( queue timeout -- alarm )\r
#! Add an alarm which removes the current thread from the\r
ERROR: wait-timeout ;\r
\r
: queue ( queue -- )\r
- [ self ] dip push-front ;\r
+ [ self ] dip push-front ; inline\r
\r
: wait ( queue timeout status -- )\r
over [\r
[ wait-timeout ] [ cancel-alarm ] if\r
] [\r
[ drop queue ] dip suspend drop\r
- ] if ;\r
+ ] if ; inline\r
locals fry ;
IN: concurrency.mailboxes
-TUPLE: mailbox threads data ;
+TUPLE: mailbox { threads dlist } { data dlist } ;
: <mailbox> ( -- mailbox )
mailbox new
<dlist> >>threads
- <dlist> >>data ;
+ <dlist> >>data ; inline
: mailbox-empty? ( mailbox -- bool )
- data>> deque-empty? ;
+ data>> deque-empty? ; inline
-: mailbox-put ( obj mailbox -- )
+GENERIC: mailbox-put ( obj mailbox -- )
+
+M: mailbox mailbox-put
[ data>> push-front ]
[ threads>> notify-all ] bi yield ;
: wait-for-mailbox ( mailbox timeout -- )
- [ threads>> ] dip "mailbox" wait ;
+ [ threads>> ] dip "mailbox" wait ; inline
:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
mailbox data>> pred dlist-any? [
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
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.\r
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel threads concurrency.mailboxes continuations\r
-namespaces assocs accessors summary fry ;\r
+USING: kernel kernel.private threads concurrency.mailboxes\r
+continuations namespaces assocs accessors summary fry ;\r
IN: concurrency.messaging\r
\r
GENERIC: send ( message thread -- )\r
\r
-: mailbox-of ( thread -- mailbox )\r
- dup mailbox>> [ ] [\r
- <mailbox> [ >>mailbox drop ] keep\r
- ] ?if ;\r
+GENERIC: mailbox-of ( thread -- mailbox )\r
+\r
+M: thread mailbox-of\r
+ dup mailbox>>\r
+ [ { mailbox } declare ]\r
+ [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline\r
\r
M: thread send ( message thread -- )\r
- check-registered mailbox-of mailbox-put ;\r
+ mailbox-of mailbox-put ;\r
\r
-: my-mailbox ( -- mailbox ) self mailbox-of ;\r
+: my-mailbox ( -- mailbox ) self mailbox-of ; inline\r
\r
: receive ( -- message )\r
my-mailbox mailbox-get ?linked ;\r
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 -- )
432 save-at ;\r
\r
[\r
+ ! Save old stack pointer\r
+ 11 1 MR\r
+\r
! Create stack frame\r
0 MFLR\r
- 1 1 callback-frame-size neg STWU\r
+ 1 1 callback-frame-size SUBI\r
0 1 callback-frame-size lr-save + STW\r
\r
! Save all non-volatile registers\r
nv-fp-regs [ 8 * 80 + save-fp ] each-index\r
nv-vec-regs [ 16 * 224 + save-vec ] each-index\r
\r
+ ! Stick old stack pointer in a non-volatile register so that\r
+ ! callbacks can access their arguments\r
+ nv-reg 11 MR\r
+\r
! Load VM into vm-reg\r
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
\r
\r
! Tear down stack frame and return\r
0 1 callback-frame-size lr-save + LWZ\r
- 1 1 0 LWZ\r
+ 1 1 callback-frame-size ADDI\r
0 MTLR\r
BLR\r
] callback-stub jit-define\r
: %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 )
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 ;
} 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 -- )
{
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
"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 ;
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 ;
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@ ;
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 ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
+ ESP 4 [+] 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
[
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
\ (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
! 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
! 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 ;
! Make the new context active
EAX jit-switch-context
+ ! Windows-specific setup
+ ctx-reg jit-update-seh
+
! Twiddle stack for return
ESP 4 ADD
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 ;
jit-delete-current-context
jit-start-context
] \ (start-context-and-delete) define-sub-primitive
-
-<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
-call
--- /dev/null
+! 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
--- /dev/null
+! 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
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 ;
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 ;
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 -- )
] 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
: jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
[
- nv-reg arg1 MOV
-
+ arg2 arg1 MOV
arg1 vm-reg MOV
"begin_callback" jit-call
jit-restore-context
! call the quotation
- arg1 nv-reg MOV
+ arg1 return-reg MOV
jit-call-quot
jit-save-context
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
jit-delete-current-context
jit-start-context
] \ (start-context-and-delete) define-sub-primitive
-
-<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
-call
: 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
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 ;
: 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
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
[ { 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
-! 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
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 ;
-! 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
PRIVATE>
: [] ( reg/displacement -- indirect )
- dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
+ dup integer?
+ [ [ f f bootstrap-cell 8 = 0 f ? ] dip <indirect> ]
+ [ f f f <indirect> ]
+ if ;
+
+: [RIP+] ( displacement -- indirect )
+ [ f f f ] dip <indirect> ;
: [+] ( reg displacement -- indirect )
dup integer?
! 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
! 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
vm-reg vm-context-offset [+] nv-reg MOV
! Restore non-volatile registers
+ jit-restore-tib
+
nv-regs <reversed> [ POP ] each
frame-reg POP
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
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 ;
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
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 ;
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 ;
#! 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
: <hashed-dlist> ( -- search-deque )
20 <hashtable> <dlist> <search-deque> ;
-M: dlist deque-empty? front>> not ;
+M: dlist deque-empty? front>> not ; inline
M: dlist-node node-value obj>> ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
M: heap heap-empty? ( heap -- ? )
- data>> empty? ;
+ data>> empty? ; inline
M: heap heap-size ( heap -- n )
data>> length ;
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
\ 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
[ "x" tget "p" get fulfill ] in-thread
[ f ] [ "p" get ?promise ] unit-test
+
+! Test system traps inside threads
+[ ] [ [ dup ] in-thread yield ] unit-test
! 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 )
: thread-registered? ( thread -- ? )
id>> threads key? ;
-ERROR: already-stopped thread ;
-
-: check-unregistered ( thread -- thread )
- dup thread-registered? [ already-stopped ] when ;
-
-ERROR: not-running thread ;
-
-: check-registered ( thread -- thread )
- dup thread-registered? [ not-running ] unless ;
-
<PRIVATE
: register-thread ( thread -- )
- check-unregistered dup id>> threads set-at ;
+ dup id>> threads set-at ;
: unregister-thread ( thread -- )
- check-registered id>> threads delete-at ;
+ id>> threads delete-at ;
: set-self ( thread -- ) 63 set-special-object ; inline
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
\ 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 )
{
<PRIVATE
: schedule-sleep ( thread dt -- )
- [ check-registered dup ] dip sleep-queue heap-push*
- >>sleep-entry drop ;
+ dupd sleep-queue heap-push* >>sleep-entry drop ;
-: expire-sleep? ( heap -- ? )
- dup heap-empty?
+: expire-sleep? ( -- ? )
+ sleep-queue dup heap-empty?
[ drop f ] [ heap-peek nip nano-count <= ] if ;
: expire-sleep ( thread -- )
f >>sleep-entry resume ;
: expire-sleep-loop ( -- )
- sleep-queue
- [ dup expire-sleep? ]
- [ dup heap-pop drop expire-sleep ]
- while
- drop ;
+ [ expire-sleep? ]
+ [ sleep-queue heap-pop drop expire-sleep ]
+ while ;
CONSTANT: [start]
[
: 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 ;
{ 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
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
-
-: 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
-
-: 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
-
-: 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_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 ]
+
+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 ]
+
+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 ]
+
+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 }
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 )
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
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
if [[ $? -ne 0 ]] ; then
DOWNLOADER=wget
else
- DOWNLOADER="curl -O"
+ DOWNLOADER="curl -f -O"
fi
}
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
"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" }
{ "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 )) }
$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 }" }
-! 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
: 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 )
<PRIVATE
{ $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 )" } } }
"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 -- ... )" } } }
] 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
: 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 -- )
WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ;
-CONSTANT: window-style ( -- n )
+CONSTANT: window-style
flags{
NSClosableWindowMask
NSMiniaturizableWindowMask
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<array> code_template(parent->special_objects[CALLBACK_STUB]);
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();
}
/* 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);
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);
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;
namespace factor
{
+struct must_start_gc_again {};
+
template<typename TargetGeneration, typename Policy> struct data_workhorse {
factor_vm *parent;
TargetGeneration *target;
{
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);
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)
parent->delete_context(old_context);
}
-void factor_vm::begin_callback()
+cell factor_vm::begin_callback(cell quot_)
{
+ data_root<object> quot(quot_,this);
+
ctx->reset();
spare_ctx = new_context();
callback_ids.push_back(callback_id++);
+
+ init_context(ctx);
+
+ return quot.value();
}
-void begin_callback(factor_vm *parent)
+cell begin_callback(factor_vm *parent, cell quot)
{
- parent->begin_callback();
+ return parent->begin_callback(quot);
}
void factor_vm::end_callback()
ctx->retainstack += sizeof(cell) * count;
}
-void factor_vm::primitive_context()
-{
- ctx->push(allot_alien(ctx));
-}
-
}
enum context_object {
OBJ_NAMESTACK,
OBJ_CATCHSTACK,
+ OBJ_CONTEXT,
};
static const cell stack_reserved = 1024;
/* 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();
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);
}
#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) {}
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;
/* 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();
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);
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 {
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());
#include <fcntl.h>
#include <limits.h>
#include <math.h>
-#include <setjmp.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
{
#define VM_C_API extern "C"
-#define NULL_DLL NULL
void early_init();
const char *vm_executable_path();
#define VM_C_API extern "C" __attribute__((visibility("default")))
#define FACTOR_OS_STRING "macosx"
-#define NULL_DLL NULL
void early_init();
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)
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;
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()
#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
#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"
_(code_room) \
_(compact_gc) \
_(compute_identity_hashcode) \
- _(context) \
_(context_object) \
_(context_object_for) \
_(current_callback) \
--- /dev/null
+.386\r
+.model flat\r
+exception_handler proto\r
+.safeseh exception_handler\r
+end\r
// 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();
void primitive_set_retainstack();
void primitive_check_datastack();
void primitive_load_locals();
- void primitive_context();
template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
{
#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
projects / factor.git / commitdiff