Merge branch 'master' of git://github.com/slavapestov/factor into techniques
Erik Charlebois
commit
c011b7b10b
14
GNUmakefile
14
GNUmakefile
|
|
@ -169,22 +169,16 @@ macosx.app: factor
|
|||
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)
|
||||
|
|
|
|||
14
Nmakefile
14
Nmakefile
|
|
@ -2,11 +2,11 @@
|
|||
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 \
|
||||
|
|
@ -63,7 +63,7 @@ DLL_OBJS = vm\os-windows-nt.obj \
|
|||
.rs.res:
|
||||
rc $<
|
||||
|
||||
all: factor.com factor.exe libfactor-ffi-test.dll
|
||||
all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
|
||||
|
||||
libfactor-ffi-test.dll: vm/ffi_test.obj
|
||||
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
|
||||
|
|
@ -71,11 +71,11 @@ libfactor-ffi-test.dll: vm/ffi_test.obj
|
|||
factor.dll.lib: $(DLL_OBJS)
|
||||
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
|
||||
|
||||
factor.com: $(EXE_OBJS)
|
||||
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
|
||||
factor.com: $(EXE_OBJS) $(DLL_OBJS)
|
||||
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
|
||||
|
||||
factor.exe: $(EXE_OBJS)
|
||||
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
|
||||
factor.exe: $(EXE_OBJS) $(DLL_OBJS)
|
||||
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
|
||||
|
||||
clean:
|
||||
del vm\*.obj
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -76,27 +76,27 @@ HELP: day-abbreviation3
|
|||
} 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
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
|
|
|||
|
|
@ -432,14 +432,17 @@ STRUCT: double-rect
|
|||
void { void* void* double-rect } "cdecl"
|
||||
[ "example" set-global 2drop ] alien-callback ;
|
||||
|
||||
: double-rect-test ( arg -- arg' )
|
||||
f f rot
|
||||
double-rect-callback
|
||||
: double-rect-test ( arg callback -- arg' )
|
||||
[ f f ] 2dip
|
||||
void { void* void* double-rect } "cdecl" alien-indirect
|
||||
"example" get-global ;
|
||||
|
||||
[ 1.0 2.0 3.0 4.0 ]
|
||||
[ 1.0 2.0 3.0 4.0 <double-rect> 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 ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! 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
|
||||
|
|
@ -25,7 +26,7 @@ FUNCTION: void CFFileDescriptorEnableCallBacks (
|
|||
) ;
|
||||
|
||||
: enable-all-callbacks ( fd -- )
|
||||
{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
|
||||
flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack }
|
||||
CFFileDescriptorEnableCallBacks ;
|
||||
|
||||
: <CFFileDescriptor> ( fd callback -- handle )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
|
@ -16,15 +16,15 @@ kCGImageAlphaFirst
|
|||
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?
|
||||
|
|
@ -121,8 +121,8 @@ FUNCTION: uint GetCurrentButtonState ( ) ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: bitmap-flags ( -- flags )
|
||||
{ kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
|
||||
: bitmap-flags ( -- n )
|
||||
kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host bitor ;
|
||||
|
||||
: bitmap-color-space ( -- color-space )
|
||||
CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -98,7 +105,7 @@ CONSTANT: nv-reg 17
|
|||
2 vm-reg vm-context-offset STW
|
||||
|
||||
! Save C callstack pointer
|
||||
2 context-callstack-save-offset 1 STW
|
||||
1 2 context-callstack-save-offset STW
|
||||
|
||||
! Load Factor callstack pointer
|
||||
1 2 context-callstack-bottom-offset LWZ
|
||||
|
|
@ -108,6 +115,9 @@ CONSTANT: nv-reg 17
|
|||
2 MTLR
|
||||
BLRL
|
||||
|
||||
! Load VM again, pointlessly
|
||||
0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
|
||||
|
||||
! Load C callstack pointer
|
||||
2 vm-reg vm-context-offset LWZ
|
||||
1 2 context-callstack-save-offset LWZ
|
||||
|
|
@ -123,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
|
||||
|
|
@ -141,7 +151,6 @@ CONSTANT: nv-reg 17
|
|||
rs-reg ctx-reg context-retainstack-offset STW ;
|
||||
|
||||
: jit-restore-context ( -- )
|
||||
jit-load-context
|
||||
ds-reg ctx-reg context-datastack-offset LWZ
|
||||
rs-reg ctx-reg context-retainstack-offset LWZ ;
|
||||
|
||||
|
|
@ -317,6 +326,7 @@ CONSTANT: nv-reg 17
|
|||
3 6 MR
|
||||
4 vm-reg MR
|
||||
"inline_cache_miss" jit-call
|
||||
jit-load-context
|
||||
jit-restore-context ;
|
||||
|
||||
[ jit-load-return-address jit-inline-cache-miss ]
|
||||
|
|
@ -394,9 +404,11 @@ CONSTANT: nv-reg 17
|
|||
3 vm-reg MR
|
||||
"begin_callback" jit-call
|
||||
|
||||
jit-load-context
|
||||
jit-restore-context
|
||||
|
||||
! Call quotation
|
||||
3 nv-reg MR
|
||||
jit-call-quot
|
||||
|
||||
jit-save-context
|
||||
|
|
@ -414,6 +426,7 @@ CONSTANT: nv-reg 17
|
|||
0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm
|
||||
|
||||
! Load ds and rs registers
|
||||
jit-load-context
|
||||
jit-restore-context
|
||||
|
||||
! We have changed the stack; load return address again
|
||||
|
|
@ -755,33 +768,34 @@ CONSTANT: nv-reg 17
|
|||
: jit-pop-context-and-param ( -- )
|
||||
3 ds-reg 0 LWZ
|
||||
3 3 alien-offset LWZ
|
||||
4 ds-reg -8 LWZ
|
||||
ds-reg ds-reg 16 SUBI ;
|
||||
4 ds-reg -4 LWZ
|
||||
ds-reg ds-reg 8 SUBI ;
|
||||
|
||||
: jit-push-param ( -- )
|
||||
ds-reg ds-reg 8 ADDI
|
||||
ds-reg ds-reg 4 ADDI
|
||||
4 ds-reg 0 STW ;
|
||||
|
||||
: jit-set-context ( -- )
|
||||
jit-pop-context-and-param
|
||||
4 jit-switch-context
|
||||
3 jit-switch-context
|
||||
jit-push-param ;
|
||||
|
||||
[ jit-set-context ] \ (set-context) define-sub-primitive
|
||||
|
||||
: jit-pop-quot-and-param ( -- )
|
||||
3 ds-reg 0 LWZ
|
||||
4 ds-reg -8 LWZ
|
||||
ds-reg ds-reg 16 SUBI ;
|
||||
4 ds-reg -4 LWZ
|
||||
ds-reg ds-reg 8 SUBI ;
|
||||
|
||||
: jit-start-context ( -- )
|
||||
! Create the new context in return-reg
|
||||
3 vm-reg MR
|
||||
"new_context" jit-call
|
||||
6 3 MR
|
||||
|
||||
jit-pop-quot-and-param
|
||||
|
||||
3 jit-switch-context
|
||||
6 jit-switch-context
|
||||
|
||||
jit-push-param
|
||||
|
||||
|
|
|
|||
|
|
@ -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,14 +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
|
||||
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 ;
|
||||
|
|
@ -692,14 +687,6 @@ M:: ppc %save-context ( temp1 temp2 -- )
|
|||
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
|
||||
|
|
@ -710,18 +697,6 @@ M: ppc %prepare-alien-indirect ( -- )
|
|||
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? ;
|
||||
|
|
@ -757,13 +732,30 @@ M: ppc %box-small-struct ( c-type -- )
|
|||
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 %unnest-context ( -- )
|
||||
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 %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 {
|
||||
|
|
|
|||
|
|
@ -28,10 +28,13 @@ M: x86.32 %mov-vm-ptr ( reg -- )
|
|||
0 MOV 0 rc-absolute-cell rel-vm ;
|
||||
|
||||
M: x86.32 %vm-field ( dst field -- )
|
||||
[ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
|
||||
[ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
|
||||
|
||||
M: x86.32 %set-vm-field ( dst field -- )
|
||||
[ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
|
||||
|
||||
M: x86.32 %vm-field-ptr ( dst field -- )
|
||||
[ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
|
||||
[ 0 MOV ] dip rc-absolute-cell rel-vm ;
|
||||
|
||||
: local@ ( n -- op )
|
||||
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
|
||||
|
|
@ -166,7 +169,7 @@ M: x86.32 %pop-stack ( n -- )
|
|||
EAX swap ds-reg reg-stack MOV ;
|
||||
|
||||
M: x86.32 %pop-context-stack ( -- )
|
||||
temp-reg "ctx" %vm-field
|
||||
temp-reg %context
|
||||
EAX temp-reg "datastack" context-field-offset [+] MOV
|
||||
EAX EAX [] MOV
|
||||
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
|
||||
|
|
@ -241,6 +244,7 @@ M: x86.32 %alien-indirect ( -- )
|
|||
|
||||
M: x86.32 %begin-callback ( -- )
|
||||
0 save-vm-ptr
|
||||
ESP 4 [+] 0 MOV
|
||||
"begin_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
|
|
|
|||
|
|
@ -63,12 +63,13 @@ IN: bootstrap.x86
|
|||
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
|
||||
|
||||
|
|
@ -81,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
|
||||
|
|
@ -109,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
|
||||
|
|
@ -123,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
|
||||
|
||||
|
|
@ -254,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 ;
|
||||
|
||||
|
|
@ -267,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
|
||||
|
||||
|
|
@ -294,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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
|
||||
layouts parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
|
||||
: jit-update-seh ( ctx-reg -- ) drop ;
|
||||
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
|
|
@ -0,0 +1,54 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: bootstrap.image.private compiler.constants
|
||||
cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
|
||||
locals parser sequences ;
|
||||
IN: bootstrap.x86
|
||||
|
||||
: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
|
||||
: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
|
||||
: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
|
||||
|
||||
: jit-save-tib ( -- )
|
||||
tib-exception-list-offset [] FS PUSH
|
||||
tib-stack-base-offset [] FS PUSH
|
||||
tib-stack-limit-offset [] FS PUSH ;
|
||||
|
||||
: jit-restore-tib ( -- )
|
||||
tib-stack-limit-offset [] FS POP
|
||||
tib-stack-base-offset [] FS POP
|
||||
tib-exception-list-offset [] FS POP ;
|
||||
|
||||
:: jit-update-tib ( ctx-reg -- )
|
||||
! There's a redundant load here because we're not allowed
|
||||
! to clobber ctx-reg. Clobbers EAX.
|
||||
! Save callstack base in TIB
|
||||
EAX ctx-reg context-callstack-seg-offset [+] MOV
|
||||
EAX EAX segment-end-offset [+] MOV
|
||||
tib-stack-base-offset [] EAX FS MOV
|
||||
! Save callstack limit in TIB
|
||||
EAX ctx-reg context-callstack-seg-offset [+] MOV
|
||||
EAX EAX segment-start-offset [+] MOV
|
||||
tib-stack-limit-offset [] EAX FS MOV ;
|
||||
|
||||
: jit-install-seh ( -- )
|
||||
! Create a new exception record and store it in the TIB.
|
||||
! Align stack
|
||||
ESP 3 bootstrap-cells ADD
|
||||
! Exception handler address filled in by callback.cpp
|
||||
0 PUSH rc-absolute-cell rt-exception-handler jit-rel
|
||||
! No next handler
|
||||
0 PUSH
|
||||
! This is the new exception handler
|
||||
tib-exception-list-offset [] ESP FS MOV ;
|
||||
|
||||
:: jit-update-seh ( ctx-reg -- )
|
||||
! Load exception record structure that jit-install-seh
|
||||
! created from the bottom of the callstack. Clobbers EAX.
|
||||
EAX ctx-reg context-callstack-bottom-offset [+] MOV
|
||||
EAX bootstrap-cell ADD
|
||||
! Store exception record in TIB.
|
||||
tib-exception-list-offset [] EAX FS MOV ;
|
||||
|
||||
<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
|
||||
call
|
||||
|
|
@ -43,22 +43,25 @@ M: x86.64 machine-registers
|
|||
M: x86.64 %mov-vm-ptr ( reg -- )
|
||||
vm-reg MOV ;
|
||||
|
||||
M: x86.64 %vm-field ( dst field -- )
|
||||
[ vm-reg ] dip vm-field-offset [+] MOV ;
|
||||
M: x86.64 %vm-field ( dst offset -- )
|
||||
[ vm-reg ] dip [+] MOV ;
|
||||
|
||||
M: x86.64 %vm-field-ptr ( dst field -- )
|
||||
[ vm-reg ] dip vm-field-offset [+] LEA ;
|
||||
M: x86.64 %set-vm-field ( src offset -- )
|
||||
[ vm-reg ] dip [+] swap MOV ;
|
||||
|
||||
M: x86.64 %vm-field-ptr ( dst offset -- )
|
||||
[ vm-reg ] dip [+] LEA ;
|
||||
|
||||
: param@ ( n -- op ) reserved-stack-space + stack@ ;
|
||||
|
||||
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 ;
|
||||
|
|
@ -111,7 +114,7 @@ M: x86.64 %pop-stack ( n -- )
|
|||
param-reg-0 swap ds-reg reg-stack MOV ;
|
||||
|
||||
M: x86.64 %pop-context-stack ( -- )
|
||||
temp-reg "ctx" %vm-field
|
||||
temp-reg %context
|
||||
param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
|
||||
param-reg-0 param-reg-0 [] MOV
|
||||
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
|
||||
|
|
@ -228,6 +231,7 @@ M: x86.64 %alien-indirect ( -- )
|
|||
|
||||
M: x86.64 %begin-callback ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
param-reg-1 0 MOV
|
||||
"begin_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %alien-callback ( quot -- )
|
||||
|
|
|
|||
|
|
@ -26,6 +26,11 @@ IN: bootstrap.x86
|
|||
: fixnum>slot@ ( -- ) temp0 1 SAR ;
|
||||
: rex-length ( -- n ) 1 ;
|
||||
|
||||
: jit-save-tib ( -- ) ;
|
||||
: jit-restore-tib ( -- ) ;
|
||||
: jit-update-tib ( ctx-reg -- ) drop ;
|
||||
: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
|
||||
|
||||
: jit-call ( name -- )
|
||||
RAX 0 MOV rc-absolute-cell jit-dlsym
|
||||
RAX CALL ;
|
||||
|
|
@ -42,7 +47,7 @@ IN: bootstrap.x86
|
|||
] jit-prolog jit-define
|
||||
|
||||
[
|
||||
temp3 5 [] LEA
|
||||
temp3 5 [RIP+] LEA
|
||||
0 JMP rc-relative rt-entry-point-pic-tail jit-rel
|
||||
] jit-word-jump jit-define
|
||||
|
||||
|
|
@ -57,11 +62,12 @@ IN: bootstrap.x86
|
|||
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
|
||||
|
|
@ -75,15 +81,15 @@ 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
|
||||
|
||||
jit-load-context
|
||||
jit-restore-context
|
||||
|
||||
! call the quotation
|
||||
arg1 nv-reg MOV
|
||||
arg1 return-reg MOV
|
||||
jit-call-quot
|
||||
|
||||
jit-save-context
|
||||
|
|
@ -115,6 +121,7 @@ IN: bootstrap.x86
|
|||
vm-reg 0 MOV 0 rc-absolute-cell jit-vm
|
||||
|
||||
! Load ds and rs registers
|
||||
jit-load-context
|
||||
jit-restore-context
|
||||
|
||||
! Call quotation
|
||||
|
|
@ -168,6 +175,7 @@ IN: bootstrap.x86
|
|||
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 ]
|
||||
|
|
|
|||
|
|
@ -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,3 +164,11 @@ IN: cpu.x86.assembler.tests
|
|||
|
||||
[ { 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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
@ -188,6 +192,13 @@ M: register displacement, drop ;
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -423,8 +423,13 @@ M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
|
|||
|
||||
HOOK: %mov-vm-ptr cpu ( reg -- )
|
||||
|
||||
HOOK: %vm-field-ptr cpu ( reg offset -- )
|
||||
|
||||
: load-zone-offset ( nursery-ptr -- )
|
||||
"nursery" vm-field-offset %vm-field-ptr ;
|
||||
|
||||
: load-allot-ptr ( nursery-ptr allot-ptr -- )
|
||||
[ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
|
||||
[ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
|
||||
|
||||
: inc-allot-ptr ( nursery-ptr n -- )
|
||||
[ [] ] dip data-alignment get align ADD ;
|
||||
|
|
@ -456,7 +461,7 @@ M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
|
|||
M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
|
||||
|
||||
M:: x86 %check-nursery ( label size temp1 temp2 -- )
|
||||
temp1 "nursery" %vm-field-ptr
|
||||
temp1 load-zone-offset
|
||||
! Load 'here' into temp2
|
||||
temp2 temp1 [] MOV
|
||||
temp2 size ADD
|
||||
|
|
@ -477,7 +482,7 @@ M: x86 %push-stack ( -- )
|
|||
ds-reg [] int-regs return-reg MOV ;
|
||||
|
||||
M: x86 %push-context-stack ( -- )
|
||||
temp-reg "ctx" %vm-field
|
||||
temp-reg %context
|
||||
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
|
||||
temp-reg temp-reg "datastack" context-field-offset [+] MOV
|
||||
temp-reg [] int-regs return-reg MOV ;
|
||||
|
|
@ -1403,7 +1408,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
|
|||
|
||||
M:: x86 %restore-context ( temp1 temp2 -- )
|
||||
#! Load Factor stack pointers on entry from C to Factor.
|
||||
temp1 "ctx" %vm-field
|
||||
temp1 %context
|
||||
ds-reg temp1 "datastack" context-field-offset [+] MOV
|
||||
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
|
||||
|
||||
|
|
@ -1411,7 +1416,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
|
|||
#! Save Factor stack pointers in case the C code calls a
|
||||
#! callback which does a GC, which must reliably trace
|
||||
#! all roots.
|
||||
temp1 "ctx" %vm-field
|
||||
temp1 %context
|
||||
temp2 stack-reg cell neg [+] LEA
|
||||
temp1 "callstack-top" context-field-offset [+] temp2 MOV
|
||||
temp1 "datastack" context-field-offset [+] ds-reg MOV
|
||||
|
|
|
|||
|
|
@ -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: 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
|
||||
|
||||
|
|
@ -31,13 +31,13 @@ M: kqueue-mx dispose* fd>> close-file ;
|
|||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: alien alien.c-types alien.data alien.syntax arrays continuations
|
|||
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
|
||||
|
|
@ -11,7 +11,7 @@ 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 )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.buffers io.files io.ports io.binary io.timeouts system
|
|||
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 ;
|
||||
|
|
@ -43,12 +43,12 @@ HOOK: add-completion io-backend ( port -- )
|
|||
<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>
|
||||
|
|
|
|||
|
|
@ -4,11 +4,10 @@ USING: accessors alien.c-types alien.strings combinators
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
! 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 ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: tools.test io.files io.files.temp io.pathnames
|
|||
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
|
||||
|
|
@ -45,7 +45,7 @@ IN: io.files.unix.tests
|
|||
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
|
||||
|
|
@ -85,7 +85,7 @@ prepare-test-file
|
|||
[ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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 )
|
||||
|
|
@ -12,15 +12,14 @@ 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 ;
|
||||
|
|
@ -28,8 +27,7 @@ M: unix (file-reader) ( path -- stream )
|
|||
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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@ io.backend.windows kernel math splitting fry alien.strings
|
|||
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 )
|
||||
|
|
@ -16,7 +17,7 @@ IN: io.files.windows
|
|||
] 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 )
|
||||
|
|
@ -29,7 +30,7 @@ IN: io.files.windows
|
|||
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
|
||||
|
|
@ -38,7 +39,7 @@ IN: io.files.windows
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -12,13 +12,13 @@ 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 -- )
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.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 )
|
||||
|
|
@ -29,9 +29,9 @@ C: <win32-mapped-file> win32-mapped-file
|
|||
|
||||
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 ;
|
||||
|
|
@ -40,7 +40,7 @@ M: windows (mapped-file-reader)
|
|||
[
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.files io.pathnames io.buffers io.ports io.timeouts
|
|||
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
|
||||
|
||||
|
|
@ -65,13 +65,13 @@ M: linux-monitor dispose* ( monitor -- )
|
|||
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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ locals kernel math assocs namespaces make continuations sequences
|
|||
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
|
||||
|
|
@ -16,7 +16,7 @@ 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,14 +3,14 @@
|
|||
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
|
||||
|
|
@ -21,7 +21,7 @@ IN: io.pipes.windows.nt
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! 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: $
|
||||
|
|
@ -62,6 +62,19 @@ ${ five six 7 } .
|
|||
|
||||
{ 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 """
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel literals math tools.test ;
|
||||
USING: accessors kernel literals math tools.test ;
|
||||
IN: literals.tests
|
||||
|
||||
<<
|
||||
|
|
@ -27,3 +27,16 @@ CONSTANT: constant-a 3
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ SYNTAX: $ scan-word expand-literal >vector ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -135,18 +135,6 @@ HELP: clear-bit
|
|||
}
|
||||
} ;
|
||||
|
||||
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." }
|
||||
|
|
@ -408,7 +396,6 @@ $nl
|
|||
}
|
||||
"Bitfields:"
|
||||
{ $subsections
|
||||
flags
|
||||
"math-bitfields"
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
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
|
||||
|
||||
|
|
@ -23,17 +23,6 @@ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -44,10 +44,6 @@ IN: math.bitwise
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -258,15 +258,14 @@ CONSTANT: SSL_SESS_CACHE_OFF HEX: 0000
|
|||
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
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
|
|||
] 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ $nl
|
|||
|
||||
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
|
||||
|
|
@ -61,4 +61,10 @@ ABOUT: "tools.deploy"
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,13 +1,16 @@
|
|||
! 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
|
||||
} cond require
|
||||
|
|
|
|||
|
|
@ -34,9 +34,6 @@ IN: tools.deploy.macosx
|
|||
"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
|
||||
|
|
@ -50,11 +47,10 @@ IN: tools.deploy.macosx
|
|||
: 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 ]
|
||||
|
|
|
|||
|
|
@ -11,16 +11,12 @@ IN: tools.deploy.windows
|
|||
|
||||
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 -- )
|
||||
|
|
|
|||
|
|
@ -628,7 +628,7 @@ M: windows-ui-backend do-events
|
|||
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
|
||||
|
|
@ -811,8 +811,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
|
|||
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>>
|
||||
|
|
@ -838,7 +837,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
|
|||
[
|
||||
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 ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax math math.bitwise classes.struct ;
|
||||
USING: alien.c-types alien.syntax math math.bitwise classes.struct
|
||||
literals ;
|
||||
IN: unix.linux.inotify
|
||||
|
||||
STRUCT: inotify-event
|
||||
|
|
@ -27,8 +28,8 @@ CONSTANT: IN_UNMOUNT HEX: 2000 ! Backing fs was unmounted
|
|||
CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed
|
||||
CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored
|
||||
|
||||
: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close
|
||||
: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves
|
||||
CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }
|
||||
CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }
|
||||
|
||||
CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory
|
||||
CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link
|
||||
|
|
@ -36,20 +37,20 @@ CONSTANT: IN_MASK_ADD HEX: 20000000 ! add to the mask of an already existing w
|
|||
CONSTANT: IN_ISDIR HEX: 40000000 ! event occurred against dir
|
||||
CONSTANT: IN_ONESHOT HEX: 80000000 ! only send event once
|
||||
|
||||
: IN_CHANGE_EVENTS ( -- n )
|
||||
{
|
||||
CONSTANT: IN_CHANGE_EVENTS
|
||||
flags{
|
||||
IN_MODIFY IN_ATTRIB IN_MOVED_FROM
|
||||
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
|
||||
IN_MOVE_SELF
|
||||
} flags ; foldable
|
||||
}
|
||||
|
||||
: IN_ALL_EVENTS ( -- n )
|
||||
{
|
||||
CONSTANT: IN_ALL_EVENTS
|
||||
flags{
|
||||
IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE
|
||||
IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM
|
||||
IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
|
||||
IN_MOVE_SELF
|
||||
} flags ; foldable
|
||||
}
|
||||
|
||||
FUNCTION: int inotify_init ( ) ;
|
||||
FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask ) ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
|
@ -29,8 +29,8 @@ CONSTANT: MNT_MULTILABEL HEX: 04000000
|
|||
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
|
||||
|
|
@ -38,14 +38,13 @@ ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
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
|
||||
|
|
@ -54,19 +54,21 @@ CONSTANT: D3DCS_PLANE3 HEX: 00000200
|
|||
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 }
|
||||
|
|
@ -777,8 +779,7 @@ CONSTANT: D3DVS_SWIZZLE_MASK HEX: 00FF0000
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -705,10 +705,10 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
|
@ -818,7 +818,7 @@ CONSTANT: TA_RIGHT 2
|
|||
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
|
||||
|
|
|
|||
|
|
@ -33,18 +33,17 @@ CONSTANT: WS_MINIMIZEBOX HEX: 00020000
|
|||
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
|
||||
|
||||
|
|
@ -76,11 +75,11 @@ CONSTANT: WS_EX_CONTROLPARENT HEX: 00010000
|
|||
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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
classes.struct windows.com.syntax init literals ;
|
||||
FROM: alien.c-types => short ;
|
||||
IN: windows.winsock
|
||||
|
||||
|
|
@ -73,8 +73,7 @@ CONSTANT: AI_PASSIVE 1
|
|||
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
|
||||
|
|
|
|||
|
|
@ -2,18 +2,18 @@
|
|||
! 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
|
||||
|
|
@ -25,7 +25,7 @@ IN: x11.windows
|
|||
EnterWindowMask
|
||||
LeaveWindowMask
|
||||
PropertyChangeMask
|
||||
} flags ;
|
||||
}
|
||||
|
||||
: window-attributes ( visinfo -- attributes )
|
||||
XSetWindowAttributes <struct>
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -1134,8 +1135,8 @@ X-FUNCTION: Status XWithdrawWindow (
|
|||
: 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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ IN: fullscreen
|
|||
:: (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>>
|
||||
|
|
@ -73,11 +73,11 @@ ERROR: display-change-error n ;
|
|||
|
||||
: 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 ;
|
||||
|
||||
|
|
@ -92,10 +92,10 @@ 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 )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! 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 )
|
||||
|
|
@ -60,7 +61,7 @@ CONSTANT: HUPCL HEX: 00004000
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! 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 )
|
||||
|
|
@ -10,10 +11,10 @@ IN: io.serial.unix
|
|||
! "/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
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
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
|
||||
|
||||
<< {
|
||||
|
|
@ -33,7 +34,7 @@ FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
|
|||
|
||||
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 )
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ ui.gadgets.worlds ui.pixel-formats specialized-arrays
|
|||
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
|
||||
|
|
@ -164,9 +164,9 @@ TUPLE: vbo
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
|
@ -13,13 +13,13 @@ IMPORT: WebView
|
|||
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> ;
|
||||
|
|
|
|||
|
|
@ -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 "libfactor.dylib"
|
||||
|
||||
void early_init();
|
||||
|
||||
|
|
|
|||
|
|
@ -46,8 +46,7 @@ void sleep_nanos(u64 nsec)
|
|||
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -48,11 +48,8 @@ void sleep_nanos(u64 nsec)
|
|||
Sleep((DWORD)(nsec/1000000));
|
||||
}
|
||||
|
||||
LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
|
||||
LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
|
||||
{
|
||||
PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
|
||||
CONTEXT *c = (CONTEXT*)pe->ContextRecord;
|
||||
|
||||
c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP);
|
||||
signal_callstack_top = (stack_frame *)c->ESP;
|
||||
|
||||
|
|
@ -81,35 +78,23 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
|
|||
MXCSR(c) &= 0xffffffc0;
|
||||
c->EIP = (cell)factor::fp_signal_handler_impl;
|
||||
break;
|
||||
case 0x40010006:
|
||||
/* If the Widcomm bluetooth stack is installed, the BTTray.exe
|
||||
process injects code into running programs. For some reason this
|
||||
results in random SEH exceptions with this (undocumented)
|
||||
exception code being raised. The workaround seems to be ignoring
|
||||
this altogether, since that is what happens if SEH is not
|
||||
enabled. Don't really have any idea what this exception means. */
|
||||
break;
|
||||
default:
|
||||
signal_number = e->ExceptionCode;
|
||||
c->EIP = (cell)factor::misc_signal_handler_impl;
|
||||
break;
|
||||
}
|
||||
return EXCEPTION_CONTINUE_EXECUTION;
|
||||
|
||||
return ExceptionContinueExecution;
|
||||
}
|
||||
|
||||
FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe)
|
||||
LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
|
||||
{
|
||||
return current_vm()->exception_handler(pe);
|
||||
return current_vm()->exception_handler(e,frame,c,dispatch);
|
||||
}
|
||||
|
||||
void factor_vm::c_to_factor_toplevel(cell quot)
|
||||
{
|
||||
if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
|
||||
fatal_error("AddVectoredExceptionHandler failed", 0);
|
||||
|
||||
c_to_factor(quot);
|
||||
|
||||
RemoveVectoredExceptionHandler((void *)factor::exception_handler);
|
||||
}
|
||||
|
||||
void factor_vm::open_console()
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue