mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
- cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
-
- install_name_tool \
- -change libfactor.dylib \
- @executable_path/../Frameworks/libfactor.dylib \
- Factor.app/Contents/MacOS/factor
$(ENGINE): $(DLL_OBJS)
$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
-factor: $(EXE_OBJS) $(ENGINE)
- $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+factor: $(EXE_OBJS) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
-factor-console: $(EXE_OBJS) $(ENGINE)
- $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+factor-console: $(EXE_OBJS) $(DLL_OBJS)
+ $(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
factor-ffi-test: $(FFI_TEST_LIBRARY)
LINK_FLAGS = /nologo /DEBUG shell32.lib
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
!ELSE
-LINK_FLAGS = /nologo shell32.lib
+LINK_FLAGS = /nologo /safeseh:no shell32.lib
CL_FLAGS = /nologo /O2 /W3
!ENDIF
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = vm\os-windows-nt.obj \
vm\os-windows.obj \
.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
} related-words
HELP: average-month
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
HELP: months-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
{ $description "Returns the number of months in a year." } ;
HELP: days-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
HELP: hours-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
HELP: minutes-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
HELP: seconds-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
HELP: julian-day-number
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? ;
void { void* void* double-rect } "cdecl"
[ "example" set-global 2drop ] alien-callback ;
-: double-rect-test ( arg -- arg' )
- f f rot
- double-rect-callback
+: double-rect-test ( arg callback -- arg' )
+ [ f f ] 2dip
void { void* void* double-rect } "cdecl" alien-indirect
"example" get-global ;
[ 1.0 2.0 3.0 4.0 ]
-[ 1.0 2.0 3.0 4.0 <double-rect> 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
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
+USING: alien.c-types alien.syntax kernel math.bitwise core-foundation
+literals ;
IN: core-foundation.file-descriptors
TYPEDEF: void* CFFileDescriptorRef
) ;
: enable-all-callbacks ( fd -- )
- { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
+ flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack }
CFFileDescriptorEnableCallBacks ;
: <CFFileDescriptor> ( fd callback -- handle )
USING: alien alien.c-types alien.destructors alien.syntax accessors
destructors fry kernel math math.bitwise sequences libc colors
images images.memory core-graphics.types core-foundation.utilities
-opengl.gl ;
+opengl.gl literals ;
IN: core-graphics
! CGImageAlphaInfo
kCGImageAlphaNoneSkipLast
kCGImageAlphaNoneSkipFirst ;
-: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
-: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
+CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f
+CONSTANT: kCGBitmapFloatComponents 256
-: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
-: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
-: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
-: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
-: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
-: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
+CONSTANT: kCGBitmapByteOrderMask HEX: 7000
+CONSTANT: kCGBitmapByteOrderDefault 0
+CONSTANT: kCGBitmapByteOrder16Little 4096
+CONSTANT: kCGBitmapByteOrder32Little 8192
+CONSTANT: kCGBitmapByteOrder16Big 12288
+CONSTANT: kCGBitmapByteOrder32Big 16384
: kCGBitmapByteOrder16Host ( -- n )
little-endian?
<PRIVATE
-: bitmap-flags ( -- flags )
- { kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
+: bitmap-flags ( -- n )
+ kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host bitor ;
: bitmap-color-space ( -- color-space )
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
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
2 vm-reg vm-context-offset STW\r
\r
! Save C callstack pointer\r
- 2 context-callstack-save-offset 1 STW\r
+ 1 2 context-callstack-save-offset STW\r
\r
! Load Factor callstack pointer\r
1 2 context-callstack-bottom-offset LWZ\r
2 MTLR\r
BLRL\r
\r
+ ! Load VM again, pointlessly\r
+ 0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel\r
+\r
! Load C callstack pointer\r
2 vm-reg vm-context-offset LWZ\r
1 2 context-callstack-save-offset LWZ\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
rs-reg ctx-reg context-retainstack-offset STW ;\r
\r
: jit-restore-context ( -- )\r
- jit-load-context\r
ds-reg ctx-reg context-datastack-offset LWZ\r
rs-reg ctx-reg context-retainstack-offset LWZ ;\r
\r
3 6 MR\r
4 vm-reg MR\r
"inline_cache_miss" jit-call\r
+ jit-load-context\r
jit-restore-context ;\r
\r
[ jit-load-return-address jit-inline-cache-miss ]\r
3 vm-reg MR\r
"begin_callback" jit-call\r
\r
+ jit-load-context\r
jit-restore-context\r
\r
! Call quotation\r
+ 3 nv-reg MR\r
jit-call-quot\r
\r
jit-save-context\r
0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm\r
\r
! Load ds and rs registers\r
+ jit-load-context\r
jit-restore-context\r
\r
! We have changed the stack; load return address again\r
: jit-pop-context-and-param ( -- )\r
3 ds-reg 0 LWZ\r
3 3 alien-offset LWZ\r
- 4 ds-reg -8 LWZ\r
- ds-reg ds-reg 16 SUBI ;\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
\r
: jit-push-param ( -- )\r
- ds-reg ds-reg 8 ADDI\r
+ ds-reg ds-reg 4 ADDI\r
4 ds-reg 0 STW ;\r
\r
: jit-set-context ( -- )\r
jit-pop-context-and-param\r
- 4 jit-switch-context\r
+ 3 jit-switch-context\r
jit-push-param ;\r
\r
[ jit-set-context ] \ (set-context) define-sub-primitive\r
\r
: jit-pop-quot-and-param ( -- )\r
3 ds-reg 0 LWZ\r
- 4 ds-reg -8 LWZ\r
- ds-reg ds-reg 16 SUBI ;\r
+ 4 ds-reg -4 LWZ\r
+ ds-reg ds-reg 8 SUBI ;\r
\r
: jit-start-context ( -- )\r
! Create the new context in return-reg\r
3 vm-reg MR\r
"new_context" jit-call\r
+ 6 3 MR\r
\r
jit-pop-quot-and-param\r
\r
- 3 jit-switch-context\r
+ 6 jit-switch-context\r
\r
jit-push-param\r
\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
- temp2 1 stack-frame get total-size>> ADDI
- temp2 temp1 "callstack-bottom" context-field-offset STW
+ 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 %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
-M: ppc %alien-callback ( quot -- )
- 3 4 %restore-context
- 3 swap %load-reference
- 4 3 quot-entry-point-offset LWZ
- 4 MTLR
- BLRL
- 3 4 %save-context ;
-
M: ppc %prepare-alien-indirect ( -- )
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
M: ppc %alien-indirect ( -- )
16 MTLR BLRL ;
-M: ppc %callback-value ( ctype -- )
- ! Save top of data stack
- 3 ds-reg 0 LWZ
- 3 1 0 local@ STW
- 3 %load-vm-addr
- ! Restore data/call/retain stacks
- "unnest_context" f %alien-invoke
- ! Restore top of data stack
- 3 1 0 local@ LWZ
- ! Unbox former top of data stack to return registers
- unbox-return ;
-
M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
4 3 4 LWZ
3 3 0 LWZ ;
-M: ppc %nest-context ( -- )
+M: ppc %begin-callback ( -- )
3 %load-vm-addr
- "nest_context" f %alien-invoke ;
+ "begin_callback" f %alien-invoke ;
+
+M: ppc %alien-callback ( quot -- )
+ 3 4 %restore-context
+ 3 swap %load-reference
+ 4 3 quot-entry-point-offset LWZ
+ 4 MTLR
+ BLRL
+ 3 4 %save-context ;
-M: ppc %unnest-context ( -- )
+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
+ 16 ds-reg 0 LWZ
+ %end-callback
+ ! Restore top of data stack
+ 3 16 MR
+ ! Unbox former top of data stack to return registers
+ unbox-return ;
M: ppc %unbox-small-struct ( size -- )
heap-size cell align cell /i {
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 -- )
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
+ ! ctx-reg is preserved across the call because it is non-volatile
+ ! in the C ABI
jit-load-vm
jit-save-context
! call the primitive
ESP [] vm-reg MOV
0 CALL rc-relative rt-dlsym jit-rel
- ! restore ds, rs registers
jit-restore-context
] jit-primitive jit-define
[
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 ;
--- /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 parser sequences ;
+IN: bootstrap.x86
+
+: jit-save-tib ( -- ) ;
+: jit-restore-tib ( -- ) ;
+: jit-update-tib ( ctx-reg -- ) drop ;
+: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
+: jit-update-seh ( ctx-reg -- ) drop ;
+
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
+call
--- /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 [] FS PUSH
+ tib-stack-base-offset [] FS PUSH
+ tib-stack-limit-offset [] FS PUSH ;
+
+: jit-restore-tib ( -- )
+ tib-stack-limit-offset [] FS POP
+ tib-stack-base-offset [] FS POP
+ tib-exception-list-offset [] FS POP ;
+
+:: jit-update-tib ( ctx-reg -- )
+ ! There's a redundant load here because we're not allowed
+ ! to clobber ctx-reg. Clobbers EAX.
+ ! Save callstack base in TIB
+ EAX ctx-reg context-callstack-seg-offset [+] MOV
+ EAX EAX segment-end-offset [+] MOV
+ tib-stack-base-offset [] EAX FS MOV
+ ! Save callstack limit in TIB
+ EAX ctx-reg context-callstack-seg-offset [+] MOV
+ EAX EAX segment-start-offset [+] MOV
+ tib-stack-limit-offset [] EAX FS MOV ;
+
+: jit-install-seh ( -- )
+ ! Create a new exception record and store it in the TIB.
+ ! Align stack
+ ESP 3 bootstrap-cells ADD
+ ! Exception handler address filled in by callback.cpp
+ 0 PUSH rc-absolute-cell rt-exception-handler jit-rel
+ ! No next handler
+ 0 PUSH
+ ! This is the new exception handler
+ tib-exception-list-offset [] ESP FS MOV ;
+
+:: jit-update-seh ( ctx-reg -- )
+ ! Load exception record structure that jit-install-seh
+ ! created from the bottom of the callstack. Clobbers EAX.
+ EAX ctx-reg context-callstack-bottom-offset [+] MOV
+ EAX bootstrap-cell ADD
+ ! Store exception record in TIB.
+ tib-exception-list-offset [] EAX FS MOV ;
+
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
+call
M: x86.64 %mov-vm-ptr ( reg -- )
vm-reg MOV ;
-M: x86.64 %vm-field ( dst field -- )
- [ vm-reg ] dip vm-field-offset [+] MOV ;
+M: x86.64 %vm-field ( dst offset -- )
+ [ vm-reg ] dip [+] MOV ;
-M: x86.64 %vm-field-ptr ( dst field -- )
- [ vm-reg ] dip vm-field-offset [+] LEA ;
+M: x86.64 %set-vm-field ( src offset -- )
+ [ vm-reg ] dip [+] swap MOV ;
+
+M: x86.64 %vm-field-ptr ( dst offset -- )
+ [ vm-reg ] dip [+] LEA ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
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 -- )
: fixnum>slot@ ( -- ) temp0 1 SAR ;
: rex-length ( -- n ) 1 ;
+: jit-save-tib ( -- ) ;
+: jit-restore-tib ( -- ) ;
+: jit-update-tib ( ctx-reg -- ) drop ;
+: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
+
: jit-call ( name -- )
RAX 0 MOV rc-absolute-cell jit-dlsym
RAX CALL ;
] 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
ctx-reg context-retainstack-offset [+] rs-reg MOV ;
: jit-restore-context ( -- )
- jit-load-context
ds-reg ctx-reg context-datastack-offset [+] MOV
rs-reg ctx-reg context-retainstack-offset [+] MOV ;
[
+ ! ctx-reg is preserved across the call because it is non-volatile
+ ! in the C ABI
jit-save-context
! call the primitive
arg1 vm-reg MOV
: 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-load-context
jit-restore-context
! call the quotation
- arg1 nv-reg MOV
+ arg1 return-reg MOV
jit-call-quot
jit-save-context
vm-reg 0 MOV 0 rc-absolute-cell jit-vm
! Load ds and rs registers
+ jit-load-context
jit-restore-context
! Call quotation
arg1 RBX MOV
arg2 vm-reg MOV
"inline_cache_miss" jit-call
+ jit-load-context
jit-restore-context ;
[ jit-load-return-address jit-inline-cache-miss ]
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
+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 ;
PRIVATE>
+! Segment override prefixes
+: CS ( -- ) HEX: 2e , ;
+: ES ( -- ) HEX: 26 , ;
+: SS ( -- ) HEX: 36 , ;
+: FS ( -- ) HEX: 64 , ;
+: GS ( -- ) HEX: 65 , ;
+
! Moving stuff
GENERIC: PUSH ( op -- )
M: register PUSH f HEX: 50 short-operand ;
-! 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
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: accessors alien.c-types combinators destructors
io.backend.unix kernel math.bitwise sequences
specialized-arrays unix unix.kqueue unix.time assocs
-io.backend.unix.multiplexers classes.struct ;
+io.backend.unix.multiplexers classes.struct literals ;
SPECIALIZED-ARRAY: kevent
IN: io.backend.unix.multiplexers.kqueue
M: kqueue-mx add-input-callback ( thread fd mx -- )
[ call-next-method ] [
- [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ [ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;
M: kqueue-mx add-output-callback ( thread fd mx -- )
[ call-next-method ] [
- [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+ [ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
register-kevent
] 2bi ;
destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc locals math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 windows.types io.backend system accessors
-io.backend.windows.privileges classes.struct windows.errors ;
+io.backend.windows.privileges classes.struct windows.errors literals ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
: (open-process-token) ( handle -- handle )
- { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
+ flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE <c-object>
[ OpenProcessToken win32-error=0/f ] keep *void* ;
: open-process-token ( -- handle )
strings kernel math namespaces sequences windows.errors
windows.kernel32 windows.shell32 windows.types splitting
continuations math.bitwise accessors init sets assocs
-classes.struct classes ;
+classes.struct classes literals ;
IN: io.backend.windows
TUPLE: win32-handle < disposable handle ;
<win32-file> |dispose
dup add-completion ;
-: share-mode ( -- n )
- {
+CONSTANT: share-mode
+ flags{
FILE_SHARE_READ
FILE_SHARE_WRITE
FILE_SHARE_DELETE
- } flags ; foldable
+ }
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat vocabs.loader classes.struct unix.ffi ;
+unix unix.stat vocabs.loader classes.struct unix.ffi literals ;
IN: io.directories.unix
-: touch-mode ( -- n )
- { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
+CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL }
M: unix touch-file ( path -- )
normalize-path
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.ports io.backend.unix math.bitwise
-unix system io.files.unique unix.ffi ;
+unix system io.files.unique unix.ffi literals ;
IN: io.files.unique.unix
-: open-unique-flags ( -- flags )
- { O_RDWR O_CREAT O_EXCL } flags ;
+CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
M: unix (touch-unique-file) ( path -- )
open-unique-flags file-mode open-file close-file ;
io.directories io.files.info io.files.info.unix continuations
kernel io.files.unix math.bitwise calendar accessors
math.functions math unix.users unix.groups arrays sequences
-grouping io.pathnames.private ;
+grouping io.pathnames.private literals ;
IN: io.files.unix.tests
[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
prepare-test-file
[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions perms OCT: 777 = ] unit-test
[ t ] [ test-file user-read? ] unit-test
[ t ] [ test-file user-write? ] unit-test
[ f ] [ test-file file-info other-read? ] unit-test
[ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-EXECUTE } set-file-permissions perms OCT: 771 = ] unit-test
prepare-test-file
! See http://factorcode.org/license.txt for BSD license.
USING: unix byte-arrays kernel io.backend.unix math.bitwise
io.ports io.files io.files.private io.pathnames environment
-destructors system unix.ffi ;
+destructors system unix.ffi literals ;
IN: io.files.unix
M: unix cwd ( -- path )
M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
-: read-flags ( -- n ) O_RDONLY ; inline
+CONSTANT: read-flags flags{ O_RDONLY }
-: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
+: open-read ( path -- fd ) read-flags file-mode open-file ;
M: unix (file-reader) ( path -- stream )
open-read <fd> init-fd <input-port> ;
-: write-flags ( -- n )
- { O_WRONLY O_CREAT O_TRUNC } flags ; inline
+CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC }
: open-write ( path -- fd )
write-flags file-mode open-file ;
M: unix (file-writer) ( path -- stream )
open-write <fd> init-fd <output-port> ;
-: append-flags ( -- n )
- { O_WRONLY O_APPEND O_CREAT } flags ; inline
+CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT }
: open-append ( path -- fd )
[
windows windows.kernel32 windows.time windows.types calendar
combinators math.functions sequences namespaces make words
system destructors accessors math.bitwise continuations
-windows.errors arrays byte-arrays generalizations alien.data ;
+windows.errors arrays byte-arrays generalizations alien.data
+literals ;
IN: io.files.windows
: open-file ( path access-mode create-mode flags -- handle )
] with-destructors ;
: open-r/w ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
OPEN_EXISTING 0 open-file ;
: open-read ( path -- win32-file )
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: open-existing ( path -- win32-file )
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_EXISTING
: maybe-create-file ( path -- win32-file ? )
#! return true if file was just created
- { GENERIC_READ GENERIC_WRITE } flags
+ flags{ GENERIC_READ GENERIC_WRITE }
share-mode
f
OPEN_ALWAYS
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors destructors io.backend.unix io.mmap
+USING: accessors destructors io.backend.unix io.mmap literals
io.mmap.private kernel locals math.bitwise system unix unix.ffi ;
IN: io.mmap.unix
] with-destructors ;
M: unix (mapped-file-r/w)
- { PROT_READ PROT_WRITE } flags
- { MAP_FILE MAP_SHARED } flags
+ flags{ PROT_READ PROT_WRITE }
+ flags{ MAP_FILE MAP_SHARED }
O_RDWR mmap-open ;
M: unix (mapped-file-reader)
- { PROT_READ } flags
- { MAP_FILE MAP_SHARED } flags
+ flags{ PROT_READ }
+ flags{ MAP_FILE MAP_SHARED }
O_RDONLY mmap-open ;
M: unix close-mapped-file ( mmap -- )
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
-accessors locals windows.errors ;
+accessors locals windows.errors literals ;
IN: io.mmap.windows
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
M: windows (mapped-file-r/w)
[
- { GENERIC_WRITE GENERIC_READ } flags
+ flags{ GENERIC_WRITE GENERIC_READ }
OPEN_ALWAYS
- { PAGE_READWRITE SEC_COMMIT } flags
+ flags{ PAGE_READWRITE SEC_COMMIT }
FILE_MAP_ALL_ACCESS mmap-open
-rot <win32-mapped-file>
] with-destructors ;
[
GENERIC_READ
OPEN_ALWAYS
- { PAGE_READONLY SEC_COMMIT } flags
+ flags{ PAGE_READONLY SEC_COMMIT }
FILE_MAP_READ mmap-open
-rot <win32-mapped-file>
] with-destructors ;
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
-system hashtables destructors unix classes.struct ;
+system hashtables destructors unix classes.struct literals ;
FROM: namespaces => set ;
IN: io.monitors.linux
tri ;
: ignore-flags? ( mask -- ? )
- {
+ flags{
IN_DELETE_SELF
IN_MOVE_SELF
IN_UNMOUNT
IN_Q_OVERFLOW
IN_IGNORED
- } flags bitand 0 > ;
+ } bitand 0 > ;
: parse-action ( mask -- changed )
[
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
-io.buffers io.files io.timeouts io.encodings.string
+io.buffers io.files io.timeouts io.encodings.string literals
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames classes.struct ;
IN: io.monitors.windows.nt
share-mode
f
OPEN_EXISTING
- { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
+ flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED }
f
CreateFile opened-file ;
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
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
: create-named-pipe ( name -- handle )
- { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
+ flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED }
PIPE_TYPE_BYTE
1
4096
: open-other-end ( name -- handle )
GENERIC_WRITE
- { FILE_SHARE_READ FILE_SHARE_WRITE } flags
+ flags{ FILE_SHARE_READ FILE_SHARE_WRITE }
default-security-attributes
OPEN_EXISTING
FILE_FLAG_OVERLAPPED
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel multiline ;
+USING: help.markup help.syntax kernel multiline sequences ;
IN: literals
HELP: $
{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
+HELP: flags{
+{ $values { "values" sequence } }
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+ { $example "USING: literals kernel prettyprint ;"
+ "IN: scratchpad"
+ "CONSTANT: x HEX: 1"
+ "flags{ HEX: 20 x BIN: 100 } .h"
+ "25"
+ }
+} ;
+
+
ARTICLE: "literals" "Interpolating code results into literal values"
"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
{ $example """
-USING: kernel literals math tools.test ;
+USING: accessors kernel literals math tools.test ;
IN: literals.tests
<<
: sixty-nine ( -- a b ) 6 9 ;
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test
+
+CONSTANT: a 1
+CONSTANT: b 2
+ALIAS: c b
+ALIAS: d c
+
+CONSTANT: foo flags{ a b d }
+
+[ 3 ] [ foo ] unit-test
+[ 3 ] [ flags{ a b d } ] unit-test
+\ foo def>> must-infer
+
+[ 1 ] [ flags{ 1 } ] unit-test
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
SYNTAX: flags{
- "}" [ parse-word ] map-tokens
- expand-literals
- 0 [ bitor ] reduce suffix! ;
+ \ } [
+ expand-literals
+ 0 [ bitor ] reduce
+ ] parse-literal ;
}
} ;
-HELP: flags
-{ $values { "values" sequence } }
-{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
-{ $examples
- { $example "USING: math.bitwise kernel prettyprint ;"
- "IN: scratchpad"
- "CONSTANT: x HEX: 1"
- "{ HEX: 20 x BIN: 100 } flags .h"
- "25"
- }
-} ;
-
HELP: symbols>flags
{ $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
{ $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
}
"Bitfields:"
{ $subsections
- flags
"math-bitfields"
} ;
USING: accessors math math.bitwise tools.test kernel words
specialized-arrays alien.c-types math.vectors.simd
-sequences destructors libc ;
+sequences destructors libc literals ;
SPECIALIZED-ARRAY: int
IN: math.bitwise.tests
: test-1+ ( x -- y ) 1 + ;
[ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test
-CONSTANT: a 1
-CONSTANT: b 2
-
-: foo ( -- flags ) { a b } flags ;
-
-[ 3 ] [ foo ] unit-test
-[ 3 ] [ { a b } flags ] unit-test
-\ foo def>> must-infer
-
-[ 1 ] [ { 1 } flags ] unit-test
-
[ 8 ] [ 0 3 toggle-bit ] unit-test
[ 0 ] [ 8 3 toggle-bit ] unit-test
: W- ( x y -- z ) - 64 bits ; inline
: W* ( x y -- z ) * 64 bits ; inline
-! flags
-MACRO: flags ( values -- )
- [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
-
: symbols>flags ( symbols assoc -- flag-bits )
[ at ] curry map
0 [ bitor ] reduce ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax combinators kernel
system namespaces assocs parser lexer sequences words
-quotations math.bitwise alien.libraries ;
+quotations math.bitwise alien.libraries literals ;
IN: openssl.libssl
CONSTANT: SSL_SESS_CACHE_CLIENT HEX: 0001
CONSTANT: SSL_SESS_CACHE_SERVER HEX: 0002
-: SSL_SESS_CACHE_BOTH ( -- n )
- { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
+CONSTANT: SSL_SESS_CACHE_BOTH flags{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER }
CONSTANT: SSL_SESS_CACHE_NO_AUTO_CLEAR HEX: 0080
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100
CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200
-: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
- { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
+CONSTANT: SSL_SESS_CACHE_NO_INTERNAL
+ flags{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE }
! ===============================================
! x509_vfy.h
] if ;
: create-crypto-context ( provider type -- handle )
- { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
+ flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET }
(acquire-crypto-context) win32-error=0/f *void* ;
ERROR: acquire-crypto-context-failed provider type ;
\ 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 ;
ARTICLE: "tools.deploy.usage" "Deploy tool usage"
"Once the necessary deployment flags have been set, the application can be deployed:"
-{ $subsections deploy }
+{ $subsections deploy deploy-image-only }
"For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
{ $code "\"hello-ui\" deploy" }
{ $list
HELP: deploy
{ $values { "vocab" "a vocabulary specifier" } }
-{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image as " { $snippet { $emphasis "vocab" } ".image" } "." } ;
+{ $description "Deploys " { $snippet "vocab" } " into a packaged application. This will create a directory containing the Factor VM, a deployed image set up to run the " { $link POSTPONE: MAIN: } " entry point of " { $snippet "vocab" } " at startup, and any " { $link "deploy-resources" } " and shared libraries the application depends on. On Mac OS X, the deployment directory will be a standard " { $snippet ".app" } " bundle executable from Finder. To only generate the Factor image, use " { $link deploy-image-only } "." } ;
+
+HELP: deploy-image-only
+{ $values { "vocab" "a vocabulary specifier" } { "image" "a pathname" } }
+{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image to the location specified by " { $snippet "image" } ". This only builds the Factor image for the vocabulary; to create a complete packaged application, use " { $link deploy } "." } ;
+
+{ deploy deploy-image-only } related-words
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.deploy.backend system vocabs.loader kernel
-combinators ;
+combinators tools.deploy.config.editor ;
IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
+: deploy-image-only ( vocab image -- )
+ [ vm ] 2dip swap dup deploy-config make-deploy-image drop ;
+
{
{ [ os macosx? ] [ "tools.deploy.macosx" ] }
{ [ os winnt? ] [ "tools.deploy.windows" ] }
{ [ os unix? ] [ "tools.deploy.unix" ] }
-} cond require
\ No newline at end of file
+} cond require
"Contents/Info.plist" append-path
write-plist ;
-: copy-dll ( bundle-name -- )
- "Frameworks/libfactor.dylib" copy-bundle-dir ;
-
: copy-nib ( bundle-name -- )
deploy-ui? get [
"Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
: create-app-dir ( vocab bundle-name -- vm )
{
[
- nip {
- [ copy-dll ]
- [ copy-nib ]
- [ "Contents/Resources" append-path make-directories ]
- } cleave
+ nip
+ [ copy-nib ]
+ [ "Contents/Resources" append-path make-directories ]
+ [ "Contents/Frameworks" append-path make-directories ] tri
]
[ copy-icns ]
[ create-app-plist ]
CONSTANT: app-icon-resource-id "APPICON"
-: copy-dll ( bundle-name -- )
- "resource:factor.dll" swap copy-file-into ;
-
:: copy-vm ( executable bundle-name extension -- vm )
vm "." split1-last drop extension append
bundle-name executable ".exe" append append-path
[ copy-file ] keep ;
: create-exe-dir ( vocab bundle-name -- vm )
- dup copy-dll
deploy-console? get ".com" ".exe" ? copy-vm ;
: open-in-explorer ( dir -- )
WNDCLASSEX <struct> f GetModuleHandle
class-name-ptr pick GetClassInfoEx 0 = [
WNDCLASSEX heap-size >>cbSize
- { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+ flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
ui-wndproc >>lpfnWndProc
0 >>cbClsExtra
0 >>cbWndExtra
f ClipCursor drop
1 ShowCursor drop ;
-: fullscreen-flags ( -- n )
- { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
+CONSTANT: fullscreen-flags { WS_CAPTION WS_BORDER WS_THICKFRAME }
: enter-fullscreen ( world -- )
handle>> hWnd>>
[
f
over hwnd>RECT get-RECT-dimensions
- { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
+ flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
SetWindowPos win32-error=0/f
]
[ SW_RESTORE ShowWindow win32-error=0/f ]
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.c-types alien.syntax math math.bitwise classes.struct ;\r
+USING: alien.c-types alien.syntax math math.bitwise classes.struct\r
+literals ;\r
IN: unix.linux.inotify\r
\r
STRUCT: inotify-event\r
CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed\r
CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored\r
\r
-: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close\r
-: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves\r
+CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }\r
+CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }\r
\r
CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory\r
CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link\r
CONSTANT: IN_ISDIR HEX: 40000000 ! event occurred against dir\r
CONSTANT: IN_ONESHOT HEX: 80000000 ! only send event once\r
\r
-: IN_CHANGE_EVENTS ( -- n )\r
- {\r
+CONSTANT: IN_CHANGE_EVENTS \r
+ flags{\r
IN_MODIFY IN_ATTRIB IN_MOVED_FROM\r
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
IN_MOVE_SELF\r
- } flags ; foldable\r
+ }\r
\r
-: IN_ALL_EVENTS ( -- n )\r
- {\r
+CONSTANT: IN_ALL_EVENTS\r
+ flags{\r
IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE\r
IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM\r
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF\r
IN_MOVE_SELF\r
- } flags ; foldable\r
+ }\r
\r
FUNCTION: int inotify_init ( ) ;\r
FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ;\r
USING: alien.c-types io.encodings.utf8 io.encodings.string
kernel sequences unix.stat accessors unix combinators math
grouping system alien.strings math.bitwise alien.syntax
-unix.types classes.struct unix.ffi ;
+unix.types classes.struct unix.ffi literals ;
IN: unix.statfs.macosx
CONSTANT: MNT_RDONLY HEX: 00000001
CONSTANT: MNT_NOATIME HEX: 10000000
ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
-: MNT_VISFLAGMASK ( -- n )
- {
+CONSTANT: MNT_VISFLAGMASK
+ flags{
MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
MNT_NOSUID MNT_NODEV MNT_UNION
MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
- } flags ; inline
+ }
CONSTANT: MNT_UPDATE HEX: 00010000
CONSTANT: MNT_RELOAD HEX: 00040000
CONSTANT: MNT_FORCE HEX: 00080000
-: MNT_CMDFLAGS ( -- n )
- { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
+CONSTANT: MNT_CMDFLAGS flags{ MNT_UPDATE MNT_RELOAD MNT_FORCE }
CONSTANT: VFS_GENERIC 0
CONSTANT: VFS_NUMMNTOPS 1
{ 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
USING: alien.syntax windows.types classes.struct math alien.c-types
-math.bitwise kernel locals windows.kernel32 ;
+math.bitwise kernel locals windows.kernel32 literals ;
IN: windows.directx.d3d9types
TYPEDEF: DWORD D3DCOLOR
CONSTANT: D3DCS_PLANE4 HEX: 00000400
CONSTANT: D3DCS_PLANE5 HEX: 00000800
-: D3DCS_ALL ( -- n )
- { D3DCS_LEFT
- D3DCS_RIGHT
- D3DCS_TOP
- D3DCS_BOTTOM
- D3DCS_FRONT
- D3DCS_BACK
- D3DCS_PLANE0
- D3DCS_PLANE1
- D3DCS_PLANE2
- D3DCS_PLANE3
- D3DCS_PLANE4
- D3DCS_PLANE5 } flags ; inline
+CONSTANT: D3DCS_ALL
+ flags{
+ D3DCS_LEFT
+ D3DCS_RIGHT
+ D3DCS_TOP
+ D3DCS_BOTTOM
+ D3DCS_FRONT
+ D3DCS_BACK
+ D3DCS_PLANE0
+ D3DCS_PLANE1
+ D3DCS_PLANE2
+ D3DCS_PLANE3
+ D3DCS_PLANE4
+ D3DCS_PLANE5
+ }
STRUCT: D3DCLIPSTATUS9
{ ClipUnion DWORD }
: D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
: D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
-: D3DVS_NOSWIZZLE ( -- n )
- { D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W } flags ; inline
+CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W }
CONSTANT: D3DSP_SWIZZLE_SHIFT 16
CONSTANT: D3DSP_SWIZZLE_MASK HEX: 00FF0000
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
- {
+ flags{
FORMAT_MESSAGE_FROM_SYSTEM
FORMAT_MESSAGE_ARGUMENT_ARRAY
- } flags
+ }
f
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax alien.destructors
-kernel windows.types math.bitwise ;
+kernel windows.types math.bitwise literals ;
IN: windows.gdi32
CONSTANT: BI_RGB 0
CONSTANT: TA_RTLREADING 256
CONSTANT: TA_NOUPDATECP 0
CONSTANT: TA_UPDATECP 1
-: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable
+CONSTANT: TA_MASK flags{ TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING }
CONSTANT: VTA_BASELINE 24
CONSTANT: VTA_CENTER 6
ALIAS: VTA_LEFT TA_BOTTOM
CONSTANT: WS_MAXIMIZEBOX HEX: 00010000
! Common window styles
-: WS_OVERLAPPEDWINDOW ( -- n )
- {
+CONSTANT: WS_OVERLAPPEDWINDOW
+ flags{
WS_OVERLAPPED
WS_CAPTION
WS_SYSMENU
WS_THICKFRAME
WS_MINIMIZEBOX
WS_MAXIMIZEBOX
- } flags ; foldable
+ }
-: WS_POPUPWINDOW ( -- n )
- { WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable
+CONSTANT: WS_POPUPWINDOW flags{ WS_POPUP WS_BORDER WS_SYSMENU }
ALIAS: WS_CHILDWINDOW WS_CHILD
CONSTANT: WS_EX_STATICEDGE HEX: 00020000
CONSTANT: WS_EX_APPWINDOW HEX: 00040000
-: WS_EX_OVERLAPPEDWINDOW ( -- n )
- WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
+CONSTANT: WS_EX_OVERLAPPEDWINDOW
+ flags{ WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE }
-: WS_EX_PALETTEWINDOW ( -- n )
- { WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
+CONSTANT: WS_EX_PALETTEWINDOW
+ flags{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST }
CONSTANT: CS_VREDRAW HEX: 0001
CONSTANT: CS_HREDRAW HEX: 0002
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 ;
+classes.struct windows.com.syntax init literals ;
FROM: alien.c-types => short ;
IN: windows.winsock
CONSTANT: AI_CANONNAME 2
CONSTANT: AI_NUMERICHOST 4
-: AI_MASK ( -- n )
- { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
+CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
CONSTANT: NI_NUMERICHOST 1
CONSTANT: NI_NUMERICSERV 2
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math math.bitwise math.vectors
namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
-fry classes.struct ;
+fry classes.struct literals ;
IN: x11.windows
-: create-window-mask ( -- n )
- { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
+CONSTANT: create-window-mask
+ flags{ CWBackPixel CWBorderPixel CWColormap CWEventMask }
: create-colormap ( visinfo -- colormap )
[ dpy get root get ] dip visual>> AllocNone
XCreateColormap ;
-: event-mask ( -- n )
- {
+CONSTANT: event-mask
+ flags{
ExposureMask
StructureNotifyMask
KeyPressMask
EnterWindowMask
LeaveWindowMask
PropertyChangeMask
- } flags ;
+ }
: window-attributes ( visinfo -- attributes )
XSetWindowAttributes <struct>
! and note the section.
USING: accessors kernel arrays alien alien.c-types alien.data
alien.strings alien.syntax classes.struct math math.bitwise words
-sequences namespaces continuations io io.encodings.ascii x11.syntax ;
+sequences namespaces continuations io io.encodings.ascii x11.syntax
+literals ;
FROM: alien.c-types => short ;
IN: x11.xlib
: PAspect ( -- n ) 7 2^ ; inline
: PBaseSize ( -- n ) 8 2^ ; inline
: PWinGravity ( -- n ) 9 2^ ; inline
-: PAllHints ( -- n )
- { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
+CONSTANT: PAllHints
+ flags{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect }
STRUCT: XSizeHints
{ flags long }
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
:: (monitor-info>devmodes) ( monitor-info n -- )
DEVMODE <struct>
DEVMODE heap-size >>dmSize
- { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields
+ flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
:> devmode
monitor-info szDevice>>
: set-fullscreen-styles ( hwnd -- )
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
- [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+ [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } bitor ] change-style ] bi ;
: set-non-fullscreen-styles ( hwnd -- )
[ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
- [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ;
+ [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } unmask ] change-style ] bi ;
ERROR: unsupported-resolution triple ;
hwnd f
desktop-monitor-info rcMonitor>> slots{ left top } first2
triple first2
- {
+ flags{
SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
SWP_NOREPOSITION SWP_NOZORDER
- } flags
+ }
SetWindowPos win32-error=0/f ;
:: enable-fullscreen ( triple hwnd -- rect )
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitwise sequences system io.serial ;
+USING: alien.syntax kernel math.bitwise sequences system io.serial
+literals ;
IN: io.serial.unix
M: bsd lookup-baud ( m -- n )
CONSTANT: CLOCAL HEX: 00008000
CONSTANT: CCTS_OFLOW HEX: 00010000
CONSTANT: CRTS_IFLOW HEX: 00020000
-: CRTSCTS ( -- n ) { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+CONSTANT: CRTSCTS flags{ CCTS_OFLOW CRTS_IFLOW }
CONSTANT: CDTR_IFLOW HEX: 00040000
CONSTANT: CDSR_OFLOW HEX: 00080000
CONSTANT: CCAR_OFLOW HEX: 00100000
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.bitwise io.serial io.serial.unix ;
+USING: accessors kernel math.bitwise io.serial io.serial.unix
+literals ;
IN: io.serial.unix
: serial-obj ( -- obj )
! "/dev/ttyd0" >>path ! freebsd
! "/dev/ttyU0" >>path ! openbsd
19200 >>baud
- { IGNPAR ICRNL } flags >>iflag
- { } flags >>oflag
- { CS8 CLOCAL CREAD } flags >>cflag
- { ICANON } flags >>lflag ;
+ flags{ IGNPAR ICRNL } >>iflag
+ flags{ } >>oflag
+ flags{ CS8 CLOCAL CREAD } >>cflag
+ flags{ ICANON } >>lflag ;
: serial-test ( -- serial )
serial-obj
USING: accessors alien.c-types alien.syntax alien.data
classes.struct combinators io.ports io.streams.duplex
system kernel math math.bitwise vocabs.loader io.serial
-io.serial.unix.termios io.backend.unix unix unix.ffi ;
+io.serial.unix.termios io.backend.unix unix unix.ffi
+literals ;
IN: io.serial.unix
<< {
M: unix open-serial ( serial -- serial' )
dup
- path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+ path>> flags{ O_RDWR O_NOCTTY O_NDELAY } file-mode open-file
fd>duplex-stream >>stream ;
: serial-fd ( serial -- fd )
] 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 -- )
specialized-vectors literals fry
sequences.deep destructors math.bitwise opengl.gl
game.models game.models.obj game.models.loader game.models.collada
-prettyprint images.tga ;
+prettyprint images.tga literals ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
0 0 0 0 glClearColor
1 glClearDepth
HEX: ffffffff glClearStencil
- { GL_COLOR_BUFFER_BIT
+ flags{ GL_COLOR_BUFFER_BIT
GL_DEPTH_BUFFER_BIT
- GL_STENCIL_BUFFER_BIT } flags glClear ;
+ GL_STENCIL_BUFFER_BIT } glClear ;
: draw-model ( world -- )
clear-screen
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
-core-graphics.types kernel math.bitwise ;
+core-graphics.types kernel math.bitwise literals ;
IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ;
-: window-style ( -- n )
- {
+CONSTANT: window-style
+ flags{
NSClosableWindowMask
NSMiniaturizableWindowMask
NSResizableWindowMask
NSTitledWindowMask
- } flags ;
+ }
: <WebWindow> ( -- id )
<WebView> rect window-style <ViewWindow> ;
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 "libfactor.dylib"
void early_init();
void factor_vm::init_ffi()
{
- /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic Unix */
- 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)
+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);
+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
_(code_room) \
_(compact_gc) \
_(compute_identity_hashcode) \
- _(context) \
_(context_object) \
_(context_object_for) \
_(current_callback) \
// 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