Merge branch 'master' of git://factorcode.org/git/factor into abi-symbols
Conflicts: basis/compiler/tests/alien.factorrelease
Joe Groff
commit
3e0d86f355
22
Nmakefile
22
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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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+ ] }
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
|
|
|||
|
|
@ -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> 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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -6,22 +6,24 @@ concurrency.conditions accessors debugger debugger.threads
|
|||
locals fry ;
|
||||
IN: concurrency.mailboxes
|
||||
|
||||
TUPLE: mailbox threads data ;
|
||||
TUPLE: mailbox { threads dlist } { data dlist } ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
mailbox new
|
||||
<dlist> >>threads
|
||||
<dlist> >>data ;
|
||||
<dlist> >>data ; inline
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
data>> deque-empty? ;
|
||||
data>> deque-empty? ; inline
|
||||
|
||||
: mailbox-put ( obj mailbox -- )
|
||||
GENERIC: mailbox-put ( obj mailbox -- )
|
||||
|
||||
M: mailbox mailbox-put
|
||||
[ data>> push-front ]
|
||||
[ threads>> notify-all ] bi yield ;
|
||||
|
||||
: wait-for-mailbox ( mailbox timeout -- )
|
||||
[ threads>> ] dip "mailbox" wait ;
|
||||
[ threads>> ] dip "mailbox" wait ; inline
|
||||
|
||||
:: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
|
||||
mailbox data>> pred dlist-any? [
|
||||
|
|
@ -34,16 +36,17 @@ TUPLE: mailbox threads data ;
|
|||
2dup wait-for-mailbox block-if-empty
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
] if ; inline recursive
|
||||
|
||||
: mailbox-peek ( mailbox -- obj )
|
||||
data>> peek-back ;
|
||||
|
||||
: mailbox-get-timeout ( mailbox timeout -- obj )
|
||||
block-if-empty data>> pop-back ;
|
||||
GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
|
||||
|
||||
M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
|
||||
|
||||
: mailbox-get ( mailbox -- obj )
|
||||
f mailbox-get-timeout ;
|
||||
f mailbox-get-timeout ; inline
|
||||
|
||||
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
||||
block-if-empty
|
||||
|
|
|
|||
|
|
@ -1,20 +1,22 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
|
||||
! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel threads concurrency.mailboxes continuations
|
||||
namespaces assocs accessors summary fry ;
|
||||
USING: kernel kernel.private threads concurrency.mailboxes
|
||||
continuations namespaces assocs accessors summary fry ;
|
||||
IN: concurrency.messaging
|
||||
|
||||
GENERIC: send ( message thread -- )
|
||||
|
||||
: mailbox-of ( thread -- mailbox )
|
||||
dup mailbox>> [ ] [
|
||||
<mailbox> [ >>mailbox drop ] keep
|
||||
] ?if ;
|
||||
GENERIC: mailbox-of ( thread -- mailbox )
|
||||
|
||||
M: thread mailbox-of
|
||||
dup mailbox>>
|
||||
[ { mailbox } declare ]
|
||||
[ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
|
||||
|
||||
M: thread send ( message thread -- )
|
||||
check-registered mailbox-of mailbox-put ;
|
||||
mailbox-of mailbox-put ;
|
||||
|
||||
: my-mailbox ( -- mailbox ) self mailbox-of ;
|
||||
: my-mailbox ( -- mailbox ) self mailbox-of ; inline
|
||||
|
||||
: receive ( -- message )
|
||||
my-mailbox mailbox-get ?linked ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <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?
|
||||
|
|
|
|||
|
|
@ -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 <reversed> [ POP ] each
|
||||
|
||||
frame-reg POP
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ TUPLE: dlist
|
|||
: <hashed-dlist> ( -- search-deque )
|
||||
20 <hashtable> <dlist> <search-deque> ;
|
||||
|
||||
M: dlist deque-empty? front>> not ;
|
||||
M: dlist deque-empty? front>> not ; inline
|
||||
|
||||
M: dlist-node node-value obj>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ TUPLE: max-heap < heap ;
|
|||
: <max-heap> ( -- max-heap ) max-heap <heap> ;
|
||||
|
||||
M: heap heap-empty? ( heap -- ? )
|
||||
data>> empty? ;
|
||||
data>> empty? ; inline
|
||||
|
||||
M: heap heap-size ( heap -- n )
|
||||
data>> length ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -11,17 +11,20 @@ IN: threads
|
|||
|
||||
! Wrap sub-primitives; we don't want them inlined into callers
|
||||
! since their behavior depends on what frames are on the callstack
|
||||
: context ( -- context )
|
||||
2 context-object ; inline
|
||||
|
||||
: set-context ( obj context -- obj' )
|
||||
(set-context) ;
|
||||
(set-context) ; inline
|
||||
|
||||
: start-context ( obj quot: ( obj -- * ) -- obj' )
|
||||
(start-context) ;
|
||||
(start-context) ; inline
|
||||
|
||||
: set-context-and-delete ( obj context -- * )
|
||||
(set-context-and-delete) ;
|
||||
(set-context-and-delete) ; inline
|
||||
|
||||
: start-context-and-delete ( obj quot: ( obj -- * ) -- * )
|
||||
(start-context-and-delete) ;
|
||||
(start-context-and-delete) ; inline
|
||||
|
||||
! Context introspection
|
||||
: namestack-for ( context -- namestack )
|
||||
|
|
@ -80,23 +83,13 @@ sleep-entry ;
|
|||
: thread-registered? ( thread -- ? )
|
||||
id>> threads key? ;
|
||||
|
||||
ERROR: already-stopped thread ;
|
||||
|
||||
: check-unregistered ( thread -- thread )
|
||||
dup thread-registered? [ already-stopped ] when ;
|
||||
|
||||
ERROR: not-running thread ;
|
||||
|
||||
: check-registered ( thread -- thread )
|
||||
dup thread-registered? [ not-running ] unless ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: register-thread ( thread -- )
|
||||
check-unregistered dup id>> threads set-at ;
|
||||
dup id>> threads set-at ;
|
||||
|
||||
: unregister-thread ( thread -- )
|
||||
check-registered id>> threads delete-at ;
|
||||
id>> threads delete-at ;
|
||||
|
||||
: set-self ( thread -- ) 63 set-special-object ; inline
|
||||
|
||||
|
|
@ -106,7 +99,7 @@ PRIVATE>
|
|||
65 special-object { dlist } declare ; inline
|
||||
|
||||
: sleep-queue ( -- heap )
|
||||
66 special-object { dlist } declare ; inline
|
||||
66 special-object { min-heap } declare ; inline
|
||||
|
||||
: new-thread ( quot name class -- thread )
|
||||
new
|
||||
|
|
@ -120,16 +113,13 @@ PRIVATE>
|
|||
\ thread new-thread ;
|
||||
|
||||
: resume ( thread -- )
|
||||
f >>state
|
||||
check-registered run-queue push-front ;
|
||||
f >>state run-queue push-front ;
|
||||
|
||||
: resume-now ( thread -- )
|
||||
f >>state
|
||||
check-registered run-queue push-back ;
|
||||
f >>state run-queue push-back ;
|
||||
|
||||
: resume-with ( obj thread -- )
|
||||
f >>state
|
||||
check-registered 2array run-queue push-front ;
|
||||
f >>state 2array run-queue push-front ;
|
||||
|
||||
: sleep-time ( -- nanos/f )
|
||||
{
|
||||
|
|
@ -150,22 +140,19 @@ DEFER: stop
|
|||
<PRIVATE
|
||||
|
||||
: schedule-sleep ( thread dt -- )
|
||||
[ check-registered dup ] dip sleep-queue heap-push*
|
||||
>>sleep-entry drop ;
|
||||
dupd sleep-queue heap-push* >>sleep-entry drop ;
|
||||
|
||||
: expire-sleep? ( heap -- ? )
|
||||
dup heap-empty?
|
||||
: expire-sleep? ( -- ? )
|
||||
sleep-queue dup heap-empty?
|
||||
[ drop f ] [ heap-peek nip nano-count <= ] if ;
|
||||
|
||||
: expire-sleep ( thread -- )
|
||||
f >>sleep-entry resume ;
|
||||
|
||||
: expire-sleep-loop ( -- )
|
||||
sleep-queue
|
||||
[ dup expire-sleep? ]
|
||||
[ dup heap-pop drop expire-sleep ]
|
||||
while
|
||||
drop ;
|
||||
[ expire-sleep? ]
|
||||
[ sleep-queue heap-pop drop expire-sleep ]
|
||||
while ;
|
||||
|
||||
CONSTANT: [start]
|
||||
[
|
||||
|
|
@ -177,7 +164,9 @@ CONSTANT: [start]
|
|||
|
||||
: no-runnable-threads ( -- ) die ;
|
||||
|
||||
: (next) ( obj thread -- obj' )
|
||||
GENERIC: (next) ( obj thread -- obj' )
|
||||
|
||||
M: thread (next)
|
||||
dup runnable>>
|
||||
[ context>> box> set-context ]
|
||||
[ t >>runnable drop [start] start-context ] if ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )) }
|
||||
|
|
|
|||
|
|
@ -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 }" }
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -575,19 +575,51 @@ HELP: if
|
|||
{ $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
|
||||
"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: io kernel math ;"
|
||||
"10 3 < [ \"Math is broken\" print ] [ \"Math is good\" print ] if"
|
||||
"Math is good"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: when
|
||||
{ $values { "?" "a generalized boolean" } { "true" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel math prettyprint ;"
|
||||
"-5 dup 0 < [ 3 + ] when ."
|
||||
"-2"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: unless
|
||||
{ $values { "?" "a generalized boolean" } { "false" quotation } }
|
||||
{ $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation."
|
||||
$nl
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
|
||||
"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: kernel math prettyprint sequences ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
"CONSTANT: american-cities {"
|
||||
" \"San Francisco\""
|
||||
" \"Los Angeles\""
|
||||
" \"New York\""
|
||||
"}"
|
||||
""
|
||||
": add-tax ( price city -- price' )"
|
||||
" american-cities member? [ 1.1 * ] unless ;"
|
||||
""
|
||||
"123 \"Ottawa\" add-tax ."
|
||||
"135.3"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: if*
|
||||
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..b )" } } { "false" { $quotation "( ..a -- ..b )" } } }
|
||||
|
|
@ -596,7 +628,31 @@ $nl
|
|||
"If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
|
||||
$nl
|
||||
"The following two lines are equivalent:"
|
||||
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
|
||||
{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } }
|
||||
{ $examples
|
||||
"Notice how in this example, the same value is tested by the conditional, and then used in the true branch; the false branch does not need to drop the value because of how " { $link if* } " works:"
|
||||
{ $example
|
||||
"USING: assocs io kernel math.parser ;"
|
||||
"IN: scratchpad"
|
||||
""
|
||||
": curry-price ( meat -- price )
|
||||
{
|
||||
{ \"Beef\" 10 }
|
||||
{ \"Chicken\" 12 }
|
||||
{ \"Lamb\" 13 }
|
||||
} at ;
|
||||
|
||||
: order-curry ( meat -- )
|
||||
curry-price [
|
||||
\"Your order will be \" write
|
||||
number>string write
|
||||
\" dollars.\" write
|
||||
] [ \"Invalid order.\" print ] if* ;"
|
||||
""
|
||||
"\"Deer\" order-curry"
|
||||
"Invalid order."
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: when*
|
||||
{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ IMPORT: WebView
|
|||
WebView -> alloc
|
||||
rect f f -> initWithFrame:frameName:groupName: ;
|
||||
|
||||
CONSTANT: window-style ( -- n )
|
||||
CONSTANT: window-style
|
||||
flags{
|
||||
NSClosableWindowMask
|
||||
NSMiniaturizableWindowMask
|
||||
|
|
|
|||
|
|
@ -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<array> 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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
namespace factor
|
||||
{
|
||||
|
||||
struct must_start_gc_again {};
|
||||
|
||||
template<typename TargetGeneration, typename Policy> struct data_workhorse {
|
||||
factor_vm *parent;
|
||||
TargetGeneration *target;
|
||||
|
|
@ -27,8 +29,7 @@ template<typename TargetGeneration, typename Policy> 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);
|
||||
|
|
|
|||
|
|
@ -108,9 +108,16 @@ context *factor_vm::new_context()
|
|||
return new_context;
|
||||
}
|
||||
|
||||
void factor_vm::init_context(context *ctx)
|
||||
{
|
||||
ctx->context_objects[OBJ_CONTEXT] = allot_alien(ctx);
|
||||
}
|
||||
|
||||
context *new_context(factor_vm *parent)
|
||||
{
|
||||
return parent->new_context();
|
||||
context *new_context = parent->new_context();
|
||||
parent->init_context(new_context);
|
||||
return new_context;
|
||||
}
|
||||
|
||||
void factor_vm::delete_context(context *old_context)
|
||||
|
|
@ -124,16 +131,22 @@ VM_C_API void delete_context(factor_vm *parent, context *old_context)
|
|||
parent->delete_context(old_context);
|
||||
}
|
||||
|
||||
void factor_vm::begin_callback()
|
||||
cell factor_vm::begin_callback(cell quot_)
|
||||
{
|
||||
data_root<object> quot(quot_,this);
|
||||
|
||||
ctx->reset();
|
||||
spare_ctx = new_context();
|
||||
callback_ids.push_back(callback_id++);
|
||||
|
||||
init_context(ctx);
|
||||
|
||||
return quot.value();
|
||||
}
|
||||
|
||||
void begin_callback(factor_vm *parent)
|
||||
cell begin_callback(factor_vm *parent, cell quot)
|
||||
{
|
||||
parent->begin_callback();
|
||||
return parent->begin_callback(quot);
|
||||
}
|
||||
|
||||
void factor_vm::end_callback()
|
||||
|
|
@ -296,9 +309,4 @@ void factor_vm::primitive_load_locals()
|
|||
ctx->retainstack += sizeof(cell) * count;
|
||||
}
|
||||
|
||||
void factor_vm::primitive_context()
|
||||
{
|
||||
ctx->push(allot_alien(ctx));
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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) {}
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
84
vm/gc.cpp
84
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();
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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());
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@
|
|||
#include <fcntl.h>
|
||||
#include <limits.h>
|
||||
#include <math.h>
|
||||
#include <setjmp.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
|
|
|
|||
|
|
@ -2,7 +2,6 @@ namespace factor
|
|||
{
|
||||
|
||||
#define VM_C_API extern "C"
|
||||
#define NULL_DLL NULL
|
||||
|
||||
void early_init();
|
||||
const char *vm_executable_path();
|
||||
|
|
|
|||
|
|
@ -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();
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -43,7 +43,6 @@ namespace factor
|
|||
_(code_room) \
|
||||
_(compact_gc) \
|
||||
_(compute_identity_hashcode) \
|
||||
_(context) \
|
||||
_(context_object) \
|
||||
_(context_object_for) \
|
||||
_(current_callback) \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
.386
|
||||
.model flat
|
||||
exception_handler proto
|
||||
.safeseh exception_handler
|
||||
end
|
||||
|
|
@ -112,10 +112,11 @@ struct factor_vm
|
|||
|
||||
// contexts
|
||||
context *new_context();
|
||||
void init_context(context *ctx);
|
||||
void delete_context(context *old_context);
|
||||
void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_);
|
||||
void delete_contexts();
|
||||
void begin_callback();
|
||||
cell begin_callback(cell quot);
|
||||
void end_callback();
|
||||
void primitive_current_callback();
|
||||
void primitive_context_object();
|
||||
|
|
@ -135,7 +136,6 @@ struct factor_vm
|
|||
void primitive_set_retainstack();
|
||||
void primitive_check_datastack();
|
||||
void primitive_load_locals();
|
||||
void primitive_context();
|
||||
|
||||
template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
|
||||
{
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue