diff --git a/GNUmakefile b/GNUmakefile index 12ca388f87..9f93deedf2 100755 --- a/GNUmakefile +++ b/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) diff --git a/Nmakefile b/Nmakefile index a73a59d0f5..9df7a6a1ee 100755 --- a/Nmakefile +++ b/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 diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 141a77d2b2..62240f73ce 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -15,10 +15,11 @@ generalizations ; IN: bootstrap.image : arch ( os cpu -- arch ) + [ dup "winnt" = "winnt" "unix" ? ] dip { - { "ppc" [ "-ppc" append ] } - { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] } - [ nip ] + { "ppc" [ drop "-ppc" append ] } + { "x86.32" [ nip "-x86.32" append ] } + { "x86.64" [ nip "-x86.64" append ] } } case ; : my-arch ( -- arch ) @@ -32,7 +33,7 @@ IN: bootstrap.image : images ( -- seq ) { - "x86.32" + "winnt-x86.32" "unix-x86.32" "winnt-x86.64" "unix-x86.64" "linux-ppc" "macosx-ppc" } ; diff --git a/basis/boxes/boxes.factor b/basis/boxes/boxes.factor index 811c5addb0..a159e1402b 100644 --- a/basis/boxes/boxes.factor +++ b/basis/boxes/boxes.factor @@ -11,7 +11,7 @@ ERROR: box-full box ; : >box ( value box -- ) dup occupied>> - [ box-full ] [ t >>occupied (>>value) ] if ; + [ box-full ] [ t >>occupied (>>value) ] if ; inline ERROR: box-empty box ; @@ -19,10 +19,10 @@ ERROR: box-empty box ; dup occupied>> [ box-empty ] unless ; inline : box> ( box -- value ) - check-box [ f ] change-value f >>occupied drop ; + check-box [ f ] change-value f >>occupied drop ; inline : ?box ( box -- value/f ? ) - dup occupied>> [ box> t ] [ drop f f ] if ; + dup occupied>> [ box> t ] [ drop f f ] if ; inline : if-box? ( box quot -- ) [ ?box ] dip [ drop ] if ; inline diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 6ce8b1d5fd..a5a31ebd65 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -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 diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 24433ad594..44326c179f 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -202,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ; M: ##set-slot insn-slot# slot>> constant ; M: ##set-slot-imm insn-slot# slot>> ; M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ; -M: ##vm-field-ptr insn-slot# field-name>> ; +M: ##vm-field insn-slot# offset>> ; +M: ##set-vm-field insn-slot# offset>> ; M: ##slot insn-object obj>> resolve ; M: ##slot-imm insn-object obj>> resolve ; M: ##set-slot insn-object obj>> resolve ; M: ##set-slot-imm insn-object obj>> resolve ; M: ##alien-global insn-object drop \ ##alien-global ; -M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ; +M: ##vm-field insn-object drop \ ##vm-field ; +M: ##set-vm-field insn-object drop \ ##vm-field ; : init-alias-analysis ( insns -- insns' ) H{ } clone histories set @@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ; 0 ac-counter set next-ac heap-ac set - \ ##vm-field-ptr set-new-ac + \ ##vm-field set-new-ac \ ##alien-global set-new-ac dup local-live-in [ set-heap-ac ] each ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 678ce76860..c015cb640b 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -660,13 +660,13 @@ INSN: ##alien-global def: dst/int-rep literal: symbol library ; -INSN: ##vm-field-ptr -def: dst/int-rep -literal: field-name ; - INSN: ##vm-field def: dst/int-rep -literal: field-name ; +literal: offset ; + +INSN: ##set-vm-field +use: src/int-rep +literal: offset ; ! FFI INSN: ##alien-invoke @@ -835,8 +835,8 @@ UNION: ##allocation ##box-displaced-alien ; ! For alias analysis -UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ; -UNION: ##write ##set-slot ##set-slot-imm ; +UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ; +UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; ! Instructions that kill all live vregs but cannot trigger GC UNION: partial-sync-insn diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 4ebc818b83..2b2ae7d160 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -32,6 +32,7 @@ IN: compiler.cfg.intrinsics { kernel.private:tag [ drop emit-tag ] } { kernel.private:context-object [ emit-context-object ] } { kernel.private:special-object [ emit-special-object ] } + { kernel.private:set-special-object [ emit-set-special-object ] } { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] } { math.private:both-fixnums? [ drop emit-both-fixnums? ] } { math.private:fixnum+ [ drop emit-fixnum+ ] } diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor index 9731d2f6f5..da77bcaa09 100644 --- a/basis/compiler/cfg/intrinsics/misc/misc.factor +++ b/basis/compiler/cfg/intrinsics/misc/misc.factor @@ -1,30 +1,39 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces layouts sequences kernel math accessors compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions compiler.cfg.builder.blocks compiler.cfg.utilities ; -FROM: vm => context-field-offset ; +FROM: vm => context-field-offset vm-field-offset ; IN: compiler.cfg.intrinsics.misc : emit-tag ( -- ) ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ; +: special-object-offset ( n -- offset ) + cells "special-objects" vm-field-offset + ; + : emit-special-object ( node -- ) dup node-input-infos first literal>> [ - "special-objects" ^^vm-field-ptr - ds-drop swap 0 ^^slot-imm + ds-drop + special-object-offset ^^vm-field ds-push ] [ emit-primitive ] ?if ; -: context-object-offset ( -- n ) - "context-objects" context-field-offset cell /i ; +: emit-set-special-object ( node -- ) + dup node-input-infos second literal>> [ + ds-drop + [ ds-pop ] dip special-object-offset ##set-vm-field + ] [ emit-primitive ] ?if ; + +: context-object-offset ( n -- n ) + cells "context-objects" context-field-offset + ; : emit-context-object ( node -- ) dup node-input-infos first literal>> [ - "ctx" ^^vm-field - ds-drop swap context-object-offset + 0 ^^slot-imm ds-push + "ctx" vm-field-offset ^^vm-field + ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push ] [ emit-primitive ] ?if ; : emit-identity-hashcode ( -- ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d82ced8a1d..4208fec0a7 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -210,8 +210,8 @@ CODEGEN: ##compare-imm %compare-imm CODEGEN: ##compare-float-ordered %compare-float-ordered CODEGEN: ##compare-float-unordered %compare-float-unordered CODEGEN: ##save-context %save-context -CODEGEN: ##vm-field-ptr %vm-field-ptr CODEGEN: ##vm-field %vm-field +CODEGEN: ##set-vm-field %set-vm-field CODEGEN: _fixnum-add %fixnum-add CODEGEN: _fixnum-sub %fixnum-sub diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 9769b72801..ac0fcff0ff 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -34,6 +34,10 @@ CONSTANT: deck-bits 18 : context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline : context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline : context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline +: context-callstack-seg-offset ( -- n ) 7 bootstrap-cells ; inline +: segment-start-offset ( -- n ) 0 bootstrap-cells ; inline +: segment-size-offset ( -- n ) 1 bootstrap-cells ; inline +: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline ! Relocation classes CONSTANT: rc-absolute-cell 0 @@ -61,6 +65,7 @@ CONSTANT: rt-megamorphic-cache-hits 8 CONSTANT: rt-vm 9 CONSTANT: rt-cards-offset 10 CONSTANT: rt-decks-offset 11 +CONSTANT: rt-exception-handler 12 : rc-absolute? ( n -- ? ) ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 692dbee4c5..ceac1b094c 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -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-test >double-rect< ] unit-test +[ + 1.0 2.0 3.0 4.0 + double-rect-callback double-rect-test + >double-rect< +] unit-test STRUCT: test_struct_14 { x1 double } diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor index 4a1c7d3370..2fb75226eb 100644 --- a/basis/concurrency/conditions/conditions.factor +++ b/basis/concurrency/conditions/conditions.factor @@ -4,10 +4,10 @@ USING: deques threads kernel arrays sequences alarms fry ; IN: concurrency.conditions : notify-1 ( deque -- ) - dup deque-empty? [ drop ] [ pop-back resume-now ] if ; + dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline : notify-all ( deque -- ) - [ resume-now ] slurp-deque ; + [ resume-now ] slurp-deque ; inline : queue-timeout ( queue timeout -- alarm ) #! Add an alarm which removes the current thread from the @@ -23,7 +23,7 @@ IN: concurrency.conditions ERROR: wait-timeout ; : queue ( queue -- ) - [ self ] dip push-front ; + [ self ] dip push-front ; inline : wait ( queue timeout status -- ) over [ @@ -31,4 +31,4 @@ ERROR: wait-timeout ; [ wait-timeout ] [ cancel-alarm ] if ] [ [ drop queue ] dip suspend drop - ] if ; + ] if ; inline diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index e245f93bd5..163873575c 100644 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -6,22 +6,24 @@ concurrency.conditions accessors debugger debugger.threads locals fry ; IN: concurrency.mailboxes -TUPLE: mailbox threads data ; +TUPLE: mailbox { threads dlist } { data dlist } ; : ( -- mailbox ) mailbox new >>threads - >>data ; + >>data ; inline : mailbox-empty? ( mailbox -- bool ) - data>> deque-empty? ; + data>> deque-empty? ; inline -: mailbox-put ( obj mailbox -- ) +GENERIC: mailbox-put ( obj mailbox -- ) + +M: mailbox mailbox-put [ data>> push-front ] [ threads>> notify-all ] bi yield ; : wait-for-mailbox ( mailbox timeout -- ) - [ threads>> ] dip "mailbox" wait ; + [ threads>> ] dip "mailbox" wait ; inline :: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... ) mailbox data>> pred dlist-any? [ @@ -34,16 +36,17 @@ TUPLE: mailbox threads data ; 2dup wait-for-mailbox block-if-empty ] [ drop - ] if ; + ] if ; inline recursive : mailbox-peek ( mailbox -- obj ) data>> peek-back ; -: mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty data>> pop-back ; +GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj ) + +M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ; : mailbox-get ( mailbox -- obj ) - f mailbox-get-timeout ; + f mailbox-get-timeout ; inline : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 37965309e8..3f55b0969b 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -1,20 +1,22 @@ -! Copyright (C) 2005, 2008 Chris Double, Slava Pestov. +! Copyright (C) 2005, 2010 Chris Double, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel threads concurrency.mailboxes continuations -namespaces assocs accessors summary fry ; +USING: kernel kernel.private threads concurrency.mailboxes +continuations namespaces assocs accessors summary fry ; IN: concurrency.messaging GENERIC: send ( message thread -- ) -: mailbox-of ( thread -- mailbox ) - dup mailbox>> [ ] [ - [ >>mailbox drop ] keep - ] ?if ; +GENERIC: mailbox-of ( thread -- mailbox ) + +M: thread mailbox-of + dup mailbox>> + [ { mailbox } declare ] + [ [ >>mailbox drop ] keep ] ?if ; inline M: thread send ( message thread -- ) - check-registered mailbox-of mailbox-put ; + mailbox-of mailbox-put ; -: my-mailbox ( -- mailbox ) self mailbox-of ; +: my-mailbox ( -- mailbox ) self mailbox-of ; inline : receive ( -- message ) my-mailbox mailbox-get ?linked ; diff --git a/basis/core-foundation/file-descriptors/file-descriptors.factor b/basis/core-foundation/file-descriptors/file-descriptors.factor index ec5581d463..4ec362f0fc 100644 --- a/basis/core-foundation/file-descriptors/file-descriptors.factor +++ b/basis/core-foundation/file-descriptors/file-descriptors.factor @@ -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 ; : ( fd callback -- handle ) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index f3f759115c..1b7693da14 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -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 ( ) ; > 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 { diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 09f1ecb32b..97f0cfb668 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -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 -- ) diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 15a7dc1c29..9b1a1de23d 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -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 ; diff --git a/basis/cpu/x86/32/unix/bootstrap.factor b/basis/cpu/x86/32/unix/bootstrap.factor new file mode 100644 index 0000000000..1e3bee4961 --- /dev/null +++ b/basis/cpu/x86/32/unix/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/32/winnt/bootstrap.factor b/basis/cpu/x86/32/winnt/bootstrap.factor new file mode 100644 index 0000000000..b8ee1dacaf --- /dev/null +++ b/basis/cpu/x86/32/winnt/bootstrap.factor @@ -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 diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 04f64f96b6..4dfb250348 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -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 -- ) diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 2f03823d45..69734df225 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -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 ] diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index 531110da7b..8ed789f392 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -1,5 +1,5 @@ USING: cpu.x86.assembler cpu.x86.assembler.operands -kernel tools.test namespaces make ; +kernel tools.test namespaces make layouts ; IN: cpu.x86.assembler.tests [ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test @@ -164,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 diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index b075b121a5..b91083dad1 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff. +! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io.binary kernel combinators kernel.private math -math.bitwise locals namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.operands -cpu.x86.assembler.operands.private ; +USING: arrays io.binary kernel combinators +combinators.short-circuit math math.bitwise locals namespaces +make sequences words system layouts math.order accessors +cpu.x86.assembler.operands cpu.x86.assembler.operands.private ; QUALIFIED: sequences IN: cpu.x86.assembler @@ -22,7 +22,11 @@ IN: cpu.x86.assembler GENERIC: sib-present? ( op -- ? ) M: indirect sib-present? - [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ; + { + [ base>> { ESP RSP R12 } member? ] + [ index>> ] + [ scale>> ] + } 1|| ; M: register sib-present? drop f ; @@ -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 ; diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor index bd9a3f6cdd..e8d98cde17 100644 --- a/basis/cpu/x86/assembler/operands/operands.factor +++ b/basis/cpu/x86/assembler/operands/operands.factor @@ -1,13 +1,9 @@ -! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff. +! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel words math accessors sequences namespaces assocs layouts cpu.x86.assembler.syntax ; IN: cpu.x86.assembler.operands -! In 32-bit mode, { 1234 } is absolute indirect addressing. -! In 64-bit mode, { 1234 } is RIP-relative. -! Beware! - REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ; ALIAS: AH SPL @@ -90,7 +86,13 @@ M: object operand-64? drop f ; PRIVATE> : [] ( reg/displacement -- indirect ) - dup integer? [ [ f f f ] dip ] [ f f f ] if ; + dup integer? + [ [ f f bootstrap-cell 8 = 0 f ? ] dip ] + [ f f f ] + if ; + +: [RIP+] ( displacement -- indirect ) + [ f f f ] dip ; : [+] ( reg displacement -- indirect ) dup integer? diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 961f0c9977..80b56f9f91 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -20,6 +20,8 @@ big-endian off ! Save all non-volatile registers nv-regs [ PUSH ] each + jit-save-tib + ! Load VM into vm-reg vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel @@ -36,7 +38,9 @@ big-endian off ! Load Factor callstack pointer stack-reg nv-reg context-callstack-bottom-offset [+] MOV - stack-reg bootstrap-cell ADD + + nv-reg jit-update-tib + jit-install-seh ! Call into Factor code nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel @@ -55,6 +59,8 @@ big-endian off vm-reg vm-context-offset [+] nv-reg MOV ! Restore non-volatile registers + jit-restore-tib + nv-regs [ POP ] each frame-reg POP diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index dbb112bf4b..acd2e1358d 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -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 diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 44140d3109..53e134fad9 100644 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -29,7 +29,7 @@ TUPLE: dlist : ( -- search-deque ) 20 ; -M: dlist deque-empty? front>> not ; +M: dlist deque-empty? front>> not ; inline M: dlist-node node-value obj>> ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index 677daca69d..28d18cb53a 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -35,7 +35,7 @@ TUPLE: max-heap < heap ; : ( -- max-heap ) max-heap ; M: heap heap-empty? ( heap -- ? ) - data>> empty? ; + data>> empty? ; inline M: heap heap-size ( heap -- n ) data>> length ; diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 16d0338da5..41fc7a65bc 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -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 ; diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor index 6022e91efd..53a67bbeab 100644 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ b/basis/io/backend/windows/nt/privileges/privileges.factor @@ -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 + flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE [ OpenProcessToken win32-error=0/f ] keep *void* ; : open-process-token ( -- handle ) diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 6ec2ec4dc5..0e0a803679 100644 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -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 -- ) |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 diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 77d7f2d1b2..0cc8aaa0e4 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -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 diff --git a/basis/io/files/unique/unix/unix.factor b/basis/io/files/unique/unix/unix.factor index ec72d9128b..cd60e3d4b8 100644 --- a/basis/io/files/unique/unix/unix.factor +++ b/basis/io/files/unique/unix/unix.factor @@ -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 ; diff --git a/basis/io/files/unix/unix-tests.factor b/basis/io/files/unix/unix-tests.factor index 93e499a576..06f7473aed 100644 --- a/basis/io/files/unix/unix-tests.factor +++ b/basis/io/files/unix/unix-tests.factor @@ -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 diff --git a/basis/io/files/unix/unix.factor b/basis/io/files/unix/unix.factor index bf0a21f997..e695345125 100644 --- a/basis/io/files/unix/unix.factor +++ b/basis/io/files/unix/unix.factor @@ -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 init-fd ; -: 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 init-fd ; -: 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 ) [ diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index c4c848cb64..4fc2057a74 100644 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -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 diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index f426201b06..84378efeb8 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -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 -- ) diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index e3e3116b59..b1191082b3 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -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 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 ] 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 ] with-destructors ; diff --git a/basis/io/monitors/linux/linux.factor b/basis/io/monitors/linux/linux.factor index 31442b7f0b..9b2440aec8 100644 --- a/basis/io/monitors/linux/linux.factor +++ b/basis/io/monitors/linux/linux.factor @@ -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 ) [ diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor index 4d061cbb1a..e6a055a9d6 100644 --- a/basis/io/monitors/windows/nt/nt.factor +++ b/basis/io/monitors/windows/nt/nt.factor @@ -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 ; diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/nt/nt.factor index 7fce8b4de2..d58e5e3d5f 100644 --- a/basis/io/pipes/windows/nt/nt.factor +++ b/basis/io/pipes/windows/nt/nt.factor @@ -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 diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index a464d75b22..6fcf8a5e07 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -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 """ diff --git a/basis/literals/literals-tests.factor b/basis/literals/literals-tests.factor index d7256a64b1..4357198db6 100644 --- a/basis/literals/literals-tests.factor +++ b/basis/literals/literals-tests.factor @@ -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 diff --git a/basis/literals/literals.factor b/basis/literals/literals.factor index 3e541a80ce..42a7ab9668 100644 --- a/basis/literals/literals.factor +++ b/basis/literals/literals.factor @@ -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 ; diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor index ee94479b46..4024953070 100644 --- a/basis/math/bitwise/bitwise-docs.factor +++ b/basis/math/bitwise/bitwise-docs.factor @@ -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" } ; diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index a5919d3ec3..93d2d9e882 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -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 diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 15db425137..cd38c8513c 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -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 ; diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index bfd59cde25..96d235d271 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -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 diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor index 30b169bfed..72b908a32f 100644 --- a/basis/random/windows/windows.factor +++ b/basis/random/windows/windows.factor @@ -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 ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 01f3ff77c0..15895184df 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -355,7 +355,6 @@ M: bad-executable summary \ code-room { } { byte-array } define-primitive \ code-room make-flushable \ compact-gc { } { } define-primitive \ compute-identity-hashcode { object } { } define-primitive -\ context { } { c-ptr } define-primitive \ context make-flushable \ context-object { fixnum } { object } define-primitive \ context-object make-flushable \ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index 742ecaa1f7..01578d4e64 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -56,3 +56,6 @@ yield [ "x" tget "p" get fulfill ] in-thread [ f ] [ "p" get ?promise ] unit-test + +! Test system traps inside threads +[ ] [ [ dup ] in-thread yield ] unit-test diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 117e941aa7..330b4abd6c 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -11,17 +11,20 @@ IN: threads ! Wrap sub-primitives; we don't want them inlined into callers ! since their behavior depends on what frames are on the callstack +: context ( -- context ) + 2 context-object ; inline + : set-context ( obj context -- obj' ) - (set-context) ; + (set-context) ; inline : start-context ( obj quot: ( obj -- * ) -- obj' ) - (start-context) ; + (start-context) ; inline : set-context-and-delete ( obj context -- * ) - (set-context-and-delete) ; + (set-context-and-delete) ; inline : start-context-and-delete ( obj quot: ( obj -- * ) -- * ) - (start-context-and-delete) ; + (start-context-and-delete) ; inline ! Context introspection : namestack-for ( context -- namestack ) @@ -80,23 +83,13 @@ sleep-entry ; : thread-registered? ( thread -- ? ) id>> threads key? ; -ERROR: already-stopped thread ; - -: check-unregistered ( thread -- thread ) - dup thread-registered? [ already-stopped ] when ; - -ERROR: not-running thread ; - -: check-registered ( thread -- thread ) - dup thread-registered? [ not-running ] unless ; - > threads set-at ; + dup id>> threads set-at ; : unregister-thread ( thread -- ) - check-registered id>> threads delete-at ; + id>> threads delete-at ; : set-self ( thread -- ) 63 set-special-object ; inline @@ -106,7 +99,7 @@ PRIVATE> 65 special-object { dlist } declare ; inline : sleep-queue ( -- heap ) - 66 special-object { dlist } declare ; inline + 66 special-object { min-heap } declare ; inline : new-thread ( quot name class -- thread ) new @@ -120,16 +113,13 @@ PRIVATE> \ thread new-thread ; : resume ( thread -- ) - f >>state - check-registered run-queue push-front ; + f >>state run-queue push-front ; : resume-now ( thread -- ) - f >>state - check-registered run-queue push-back ; + f >>state run-queue push-back ; : resume-with ( obj thread -- ) - f >>state - check-registered 2array run-queue push-front ; + f >>state 2array run-queue push-front ; : sleep-time ( -- nanos/f ) { @@ -150,22 +140,19 @@ DEFER: stop >sleep-entry drop ; + dupd sleep-queue heap-push* >>sleep-entry drop ; -: expire-sleep? ( heap -- ? ) - dup heap-empty? +: expire-sleep? ( -- ? ) + sleep-queue dup heap-empty? [ drop f ] [ heap-peek nip nano-count <= ] if ; : expire-sleep ( thread -- ) f >>sleep-entry resume ; : expire-sleep-loop ( -- ) - sleep-queue - [ dup expire-sleep? ] - [ dup heap-pop drop expire-sleep ] - while - drop ; + [ expire-sleep? ] + [ sleep-queue heap-pop drop expire-sleep ] + while ; CONSTANT: [start] [ @@ -177,7 +164,9 @@ CONSTANT: [start] : no-runnable-threads ( -- ) die ; -: (next) ( obj thread -- obj' ) +GENERIC: (next) ( obj thread -- obj' ) + +M: thread (next) dup runnable>> [ context>> box> set-context ] [ t >>runnable drop [start] start-context ] if ; diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 976fc25357..27c5bbccf1 100755 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -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 diff --git a/basis/tools/deploy/deploy.factor b/basis/tools/deploy/deploy.factor index e57cc1f04b..9430802803 100644 --- a/basis/tools/deploy/deploy.factor +++ b/basis/tools/deploy/deploy.factor @@ -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 \ No newline at end of file +} cond require diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index c02642ba1d..446f453709 100644 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -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 ] diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index f592ff2d69..7981859573 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -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 -- ) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 8a4ae9853f..c0829e5c8d 100644 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -628,7 +628,7 @@ M: windows-ui-backend do-events WNDCLASSEX 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 ] diff --git a/basis/unix/linux/inotify/inotify.factor b/basis/unix/linux/inotify/inotify.factor index c296cc8166..947191e7dd 100644 --- a/basis/unix/linux/inotify/inotify.factor +++ b/basis/unix/linux/inotify/inotify.factor @@ -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 ) ; diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index 75b231da96..b5ae2c2223 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -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 diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index b0f2c945f7..b4c5734810 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -11,10 +11,10 @@ STRUCT: context { datastack cell } { retainstack cell } { callstack-save cell } -{ context-objects cell[10] } { datastack-region void* } { retainstack-region void* } -{ callstack-region void* } ; +{ callstack-region void* } +{ context-objects cell[10] } ; : context-field-offset ( field -- offset ) context offset-of ; inline diff --git a/basis/windows/directx/d3d9types/d3d9types.factor b/basis/windows/directx/d3d9types/d3d9types.factor index dc02849553..618d3c79e5 100644 --- a/basis/windows/directx/d3d9types/d3d9types.factor +++ b/basis/windows/directx/d3d9types/d3d9types.factor @@ -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 diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor index 67757d05d2..a3dbaf40ff 100755 --- a/basis/windows/errors/errors.factor +++ b/basis/windows/errors/errors.factor @@ -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 diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 43307cb6ba..93784ea370 100644 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -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 diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 1c23c36071..54d31bb12b 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -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 diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index b58cbcacbd..49a3d6e9fa 100644 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.strings alien.syntax arrays byte-arrays kernel literals math sequences windows.types windows.kernel32 windows.errors math.bitwise io.encodings.utf16n -classes.struct windows.com.syntax init ; +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 diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor index ad0a8b11a6..fb267ef4bb 100644 --- a/basis/x11/windows/windows.factor +++ b/basis/x11/windows/windows.factor @@ -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 diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 1c5ff2e3ef..ac9e5591dc 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -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 } diff --git a/build-support/factor.sh b/build-support/factor.sh index 3a5fb4e253..68d138c3ef 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -68,7 +68,7 @@ set_downloader() { if [[ $? -ne 0 ]] ; then DOWNLOADER=wget else - DOWNLOADER="curl -O" + DOWNLOADER="curl -f -O" fi } @@ -291,9 +291,15 @@ set_build_info() { elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=winnt-x86.64 MAKE_TARGET=winnt-x86-64 + elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then + MAKE_IMAGE_TARGET=winnt-x86.32 + MAKE_TARGET=winnt-x86-32 elif [[ $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=unix-x86.64 MAKE_TARGET=$OS-x86-64 + elif [[ $ARCH == x86 && $WORD == 32 ]] ; then + MAKE_IMAGE_TARGET=unix-x86.32 + MAKE_TARGET=$OS-x86-32 else MAKE_IMAGE_TARGET=$ARCH.$WORD MAKE_TARGET=$OS-$ARCH-$WORD diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 52ee1e14b4..87963848bf 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -18,7 +18,8 @@ H{ } clone sub-primitives set "vocab:bootstrap/syntax.factor" parse-file architecture get { - { "x86.32" "x86/32" } + { "winnt-x86.32" "x86/32/winnt" } + { "unix-x86.32" "x86/32/unix" } { "winnt-x86.64" "x86/64/winnt" } { "unix-x86.64" "x86/64/unix" } { "linux-ppc" "ppc/linux" } @@ -538,7 +539,6 @@ tuple { "system-micros" "system" "primitive_system_micros" (( -- us )) } { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) } { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) } - { "context" "threads.private" "primitive_context" (( -- context )) } { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) } { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) } { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) } diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 3710680269..8775e599a6 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -235,7 +235,7 @@ HELP: save-error $low-level-note ; HELP: with-datastack -{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } +{ $values { "stack" sequence } { "quot" quotation } { "new-stack" sequence } } { $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index cfceb1f715..196a12d0d2 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,10 +1,17 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces make math splitting sorting quotations assocs combinators combinators.private accessors words ; IN: continuations +: with-datastack ( stack quot -- new-stack ) + [ + [ [ datastack ] dip swap [ { } like set-datastack ] dip ] dip + swap [ call datastack ] dip + swap [ set-datastack ] dip + ] (( stack quot -- new-stack )) call-effect-unsafe ; + SYMBOL: error SYMBOL: error-continuation SYMBOL: error-thread @@ -90,14 +97,6 @@ SYMBOL: return-continuation : return ( -- * ) return-continuation get continue ; -: with-datastack ( stack quot -- newstack ) - [ - [ - [ [ { } like set-datastack ] dip call datastack ] dip - continue-with - ] (( stack quot continuation -- * )) call-effect-unsafe - ] callcc1 2nip ; - GENERIC: compute-restarts ( error -- seq ) devmodes) ( monitor-info n -- ) DEVMODE 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 ) diff --git a/extra/io/serial/unix/bsd/bsd.factor b/extra/io/serial/unix/bsd/bsd.factor index dbb013aca0..14d4f515ae 100644 --- a/extra/io/serial/unix/bsd/bsd.factor +++ b/extra/io/serial/unix/bsd/bsd.factor @@ -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 diff --git a/extra/io/serial/unix/unix-tests.factor b/extra/io/serial/unix/unix-tests.factor index f4c0c6b45a..422844ab82 100644 --- a/extra/io/serial/unix/unix-tests.factor +++ b/extra/io/serial/unix/unix-tests.factor @@ -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 diff --git a/extra/io/serial/unix/unix.factor b/extra/io/serial/unix/unix.factor index 6c0de55ec8..fc613da423 100644 --- a/extra/io/serial/unix/unix.factor +++ b/extra/io/serial/unix/unix.factor @@ -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 ) diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 6fedac87bd..f8046ac8e5 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -33,7 +33,7 @@ USING: mason.child mason.config tools.test namespaces io kernel sequences ; ] with-scope ] unit-test -[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [ +[ { "./factor.com" "-i=boot.winnt-x86.32.image" "-no-user-init" } ] [ [ "winnt" target-os set "x86.32" target-cpu set diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 912cd48c79..db68a558e0 100644 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -17,8 +17,8 @@ SYMBOL: current-git-id : short-running-process ( command -- ) #! Give network operations and shell commands at most - #! 15 minutes to complete, to catch hangs. - >process 15 minutes >>timeout try-output-process ; + #! 30 minutes to complete, to catch hangs. + >process 30 minutes >>timeout try-output-process ; HOOK: really-delete-tree os ( path -- ) diff --git a/extra/model-viewer/model-viewer.factor b/extra/model-viewer/model-viewer.factor index 061ce07d1e..f1b184f220 100644 --- a/extra/model-viewer/model-viewer.factor +++ b/extra/model-viewer/model-viewer.factor @@ -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 diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor index e6178a55c3..8f89b1b4ae 100644 --- a/extra/webkit-demo/webkit-demo.factor +++ b/extra/webkit-demo/webkit-demo.factor @@ -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 ; + } : ( -- id ) rect window-style ; diff --git a/vm/callbacks.cpp b/vm/callbacks.cpp old mode 100644 new mode 100755 index 6c8165f5c4..38479a3cb4 --- a/vm/callbacks.cpp +++ b/vm/callbacks.cpp @@ -19,7 +19,25 @@ void factor_vm::init_callbacks(cell size) callbacks = new callback_heap(size,this); } -void callback_heap::store_callback_operand(code_block *stub, cell index, cell value) +bool callback_heap::setup_seh_p() +{ +#if defined(WINDOWS) && defined(FACTOR_X86) + return true; +#else + return false; +#endif +} + +bool callback_heap::return_takes_param_p() +{ +#if defined(FACTOR_X86) || defined(FACTOR_AMD64) + return true; +#else + return false; +#endif +} + +instruction_operand callback_heap::callback_operand(code_block *stub, cell index) { tagged code_template(parent->special_objects[CALLBACK_STUB]); @@ -33,12 +51,23 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va offset); instruction_operand op(rel,stub,0); - op.store_value(value); + + return op; +} + +void callback_heap::store_callback_operand(code_block *stub, cell index) +{ + parent->store_external_address(callback_operand(stub,index)); +} + +void callback_heap::store_callback_operand(code_block *stub, cell index, cell value) +{ + callback_operand(stub,index).store_value(value); } void callback_heap::update(code_block *stub) { - store_callback_operand(stub,1,(cell)callback_entry_point(stub)); + store_callback_operand(stub,setup_seh_p() ? 2 : 1,(cell)callback_entry_point(stub)); stub->flush_icache(); } @@ -64,13 +93,24 @@ code_block *callback_heap::add(cell owner, cell return_rewind) /* Store VM pointer */ store_callback_operand(stub,0,(cell)parent); - store_callback_operand(stub,2,(cell)parent); + + cell index; + + if(setup_seh_p()) + { + store_callback_operand(stub,1); + index = 1; + } + else + index = 0; + + /* Store VM pointer */ + store_callback_operand(stub,index + 2,(cell)parent); /* On x86, the RET instruction takes an argument which depends on the callback's calling convention */ -#if defined(FACTOR_X86) || defined(FACTOR_AMD64) - store_callback_operand(stub,3,return_rewind); -#endif + if(return_takes_param_p()) + store_callback_operand(stub,index + 3,return_rewind); update(stub); diff --git a/vm/callbacks.hpp b/vm/callbacks.hpp index 607984ad23..a0ab3d6bf9 100644 --- a/vm/callbacks.hpp +++ b/vm/callbacks.hpp @@ -38,6 +38,10 @@ struct callback_heap { return w->entry_point; } + bool setup_seh_p(); + bool return_takes_param_p(); + instruction_operand callback_operand(code_block *stub, cell index); + void store_callback_operand(code_block *stub, cell index); void store_callback_operand(code_block *stub, cell index, cell value); void update(code_block *stub); diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp index 894e49846d..de103cda12 100755 --- a/vm/code_blocks.cpp +++ b/vm/code_blocks.cpp @@ -225,6 +225,11 @@ void factor_vm::store_external_address(instruction_operand op) case RT_DECKS_OFFSET: op.store_value(decks_offset); break; +#ifdef WINDOWS + case RT_EXCEPTION_HANDLER: + op.store_value((cell)&factor::exception_handler); + break; +#endif default: critical_error("Bad rel type",op.rel_type()); break; diff --git a/vm/collector.hpp b/vm/collector.hpp index ece4926c28..0b8b473e8b 100644 --- a/vm/collector.hpp +++ b/vm/collector.hpp @@ -1,6 +1,8 @@ namespace factor { +struct must_start_gc_again {}; + template struct data_workhorse { factor_vm *parent; TargetGeneration *target; @@ -27,8 +29,7 @@ template struct data_workhorse { { cell size = untagged->size(); object *newpointer = target->allot(size); - /* XXX not exception-safe */ - if(!newpointer) longjmp(parent->current_gc->gc_unwind,1); + if(!newpointer) throw must_start_gc_again(); memcpy(newpointer,untagged,size); untagged->forward_to(newpointer); diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 9364f2e362..25fe0e5280 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -108,9 +108,16 @@ context *factor_vm::new_context() return new_context; } +void factor_vm::init_context(context *ctx) +{ + ctx->context_objects[OBJ_CONTEXT] = allot_alien(ctx); +} + context *new_context(factor_vm *parent) { - return parent->new_context(); + context *new_context = parent->new_context(); + parent->init_context(new_context); + return new_context; } void factor_vm::delete_context(context *old_context) @@ -124,16 +131,22 @@ VM_C_API void delete_context(factor_vm *parent, context *old_context) parent->delete_context(old_context); } -void factor_vm::begin_callback() +cell factor_vm::begin_callback(cell quot_) { + data_root quot(quot_,this); + ctx->reset(); spare_ctx = new_context(); callback_ids.push_back(callback_id++); + + init_context(ctx); + + return quot.value(); } -void begin_callback(factor_vm *parent) +cell begin_callback(factor_vm *parent, cell quot) { - parent->begin_callback(); + return parent->begin_callback(quot); } void factor_vm::end_callback() @@ -296,9 +309,4 @@ void factor_vm::primitive_load_locals() ctx->retainstack += sizeof(cell) * count; } -void factor_vm::primitive_context() -{ - ctx->push(allot_alien(ctx)); -} - } diff --git a/vm/contexts.hpp b/vm/contexts.hpp index f3aba0e5a6..582fab173f 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -6,6 +6,7 @@ static const cell context_object_count = 10; enum context_object { OBJ_NAMESTACK, OBJ_CATCHSTACK, + OBJ_CONTEXT, }; static const cell stack_reserved = 1024; @@ -27,14 +28,14 @@ struct context { /* C callstack pointer */ cell callstack_save; - /* context-specific special objects, accessed by context-object and - set-context-object primitives */ - cell context_objects[context_object_count]; - segment *datastack_seg; segment *retainstack_seg; segment *callstack_seg; + /* context-specific special objects, accessed by context-object and + set-context-object primitives */ + cell context_objects[context_object_count]; + context(cell datastack_size, cell retainstack_size, cell callstack_size); ~context(); @@ -71,7 +72,7 @@ struct context { VM_C_API context *new_context(factor_vm *parent); VM_C_API void delete_context(factor_vm *parent, context *old_context); -VM_C_API void begin_callback(factor_vm *parent); +VM_C_API cell begin_callback(factor_vm *parent, cell quot); VM_C_API void end_callback(factor_vm *parent); } diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp old mode 100644 new mode 100755 index bfdcd8afb2..89d7fb792a --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -5,7 +5,7 @@ namespace factor #define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1) -#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell)) +#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell) * 5) inline static void flush_icache(cell start, cell len) {} diff --git a/vm/factor.cpp b/vm/factor.cpp index e726ebf6da..89da7a2db7 100755 --- a/vm/factor.cpp +++ b/vm/factor.cpp @@ -14,7 +14,12 @@ void factor_vm::default_parameters(vm_parameters *p) p->datastack_size = 32 * sizeof(cell); p->retainstack_size = 32 * sizeof(cell); + +#ifdef FACTOR_PPC + p->callstack_size = 256 * sizeof(cell); +#else p->callstack_size = 128 * sizeof(cell); +#endif p->code_size = 8 * sizeof(cell); p->young_size = sizeof(cell) / 4; diff --git a/vm/gc.cpp b/vm/gc.cpp index a57f338c44..e01a05aa5b 100755 --- a/vm/gc.cpp +++ b/vm/gc.cpp @@ -135,49 +135,57 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p) /* Keep trying to GC higher and higher generations until we don't run out of space */ - if(setjmp(current_gc->gc_unwind)) + for(;;) { - /* We come back here if a generation is full */ - start_gc_again(); - } - - current_gc->event->op = current_gc->op; - - switch(current_gc->op) - { - case collect_nursery_op: - collect_nursery(); - break; - case collect_aging_op: - collect_aging(); - if(data->high_fragmentation_p()) + try { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; - collect_full(trace_contexts_p); + current_gc->event->op = current_gc->op; + + switch(current_gc->op) + { + case collect_nursery_op: + collect_nursery(); + break; + case collect_aging_op: + collect_aging(); + if(data->high_fragmentation_p()) + { + current_gc->op = collect_full_op; + current_gc->event->op = collect_full_op; + collect_full(trace_contexts_p); + } + break; + case collect_to_tenured_op: + collect_to_tenured(); + if(data->high_fragmentation_p()) + { + current_gc->op = collect_full_op; + current_gc->event->op = collect_full_op; + collect_full(trace_contexts_p); + } + break; + case collect_full_op: + collect_full(trace_contexts_p); + break; + case collect_compact_op: + collect_compact(trace_contexts_p); + break; + case collect_growing_heap_op: + collect_growing_heap(requested_bytes,trace_contexts_p); + break; + default: + critical_error("Bad GC op",current_gc->op); + break; + } + + break; } - break; - case collect_to_tenured_op: - collect_to_tenured(); - if(data->high_fragmentation_p()) + catch(const must_start_gc_again e) { - current_gc->op = collect_full_op; - current_gc->event->op = collect_full_op; - collect_full(trace_contexts_p); + /* We come back here if a generation is full */ + start_gc_again(); + continue; } - break; - case collect_full_op: - collect_full(trace_contexts_p); - break; - case collect_compact_op: - collect_compact(trace_contexts_p); - break; - case collect_growing_heap_op: - collect_growing_heap(requested_bytes,trace_contexts_p); - break; - default: - critical_error("Bad GC op",current_gc->op); - break; } end_gc(); diff --git a/vm/gc.hpp b/vm/gc.hpp index 5224dec3e2..5129ced909 100755 --- a/vm/gc.hpp +++ b/vm/gc.hpp @@ -45,7 +45,6 @@ struct gc_event { struct gc_state { gc_op op; u64 start_time; - jmp_buf gc_unwind; gc_event *event; explicit gc_state(gc_op op_, factor_vm *parent); diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp index dc8aa9d841..66ffddc24e 100644 --- a/vm/instruction_operands.hpp +++ b/vm/instruction_operands.hpp @@ -26,6 +26,10 @@ enum relocation_type { RT_CARDS_OFFSET, /* value of vm->decks_offset */ RT_DECKS_OFFSET, + /* address of exception_handler -- this exists as a separate relocation + type since its used in a situation where relocation arguments cannot + be passed in, and so RT_DLSYM is inappropriate (Windows only) */ + RT_EXCEPTION_HANDLER, }; enum relocation_class { @@ -105,6 +109,7 @@ struct relocation_entry { case RT_MEGAMORPHIC_CACHE_HITS: case RT_CARDS_OFFSET: case RT_DECKS_OFFSET: + case RT_EXCEPTION_HANDLER: return 0; default: critical_error("Bad rel type",rel_type()); diff --git a/vm/master.hpp b/vm/master.hpp index 9879fa607a..a111a86b69 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -16,7 +16,6 @@ #include #include #include -#include #include #include #include diff --git a/vm/os-genunix.hpp b/vm/os-genunix.hpp index c6123eca56..a40e891a6e 100644 --- a/vm/os-genunix.hpp +++ b/vm/os-genunix.hpp @@ -2,7 +2,6 @@ namespace factor { #define VM_C_API extern "C" -#define NULL_DLL NULL void early_init(); const char *vm_executable_path(); diff --git a/vm/os-macosx.hpp b/vm/os-macosx.hpp index 8428f56998..27eba77215 100644 --- a/vm/os-macosx.hpp +++ b/vm/os-macosx.hpp @@ -3,7 +3,6 @@ namespace factor #define VM_C_API extern "C" __attribute__((visibility("default"))) #define FACTOR_OS_STRING "macosx" -#define NULL_DLL "libfactor.dylib" void early_init(); diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index a8898eccab..034dfcbf5f 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -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) diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index 2d5881252a..4f90d7f641 100755 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -48,11 +48,8 @@ void sleep_nanos(u64 nsec) Sleep((DWORD)(nsec/1000000)); } -LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) +LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { - PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; - CONTEXT *c = (CONTEXT*)pe->ContextRecord; - c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP); signal_callstack_top = (stack_frame *)c->ESP; @@ -81,35 +78,23 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe) MXCSR(c) &= 0xffffffc0; c->EIP = (cell)factor::fp_signal_handler_impl; break; - case 0x40010006: - /* If the Widcomm bluetooth stack is installed, the BTTray.exe - process injects code into running programs. For some reason this - results in random SEH exceptions with this (undocumented) - exception code being raised. The workaround seems to be ignoring - this altogether, since that is what happens if SEH is not - enabled. Don't really have any idea what this exception means. */ - break; default: signal_number = e->ExceptionCode; c->EIP = (cell)factor::misc_signal_handler_impl; break; } - return EXCEPTION_CONTINUE_EXECUTION; + + return ExceptionContinueExecution; } -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe) +LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch) { - return current_vm()->exception_handler(pe); + return current_vm()->exception_handler(e,frame,c,dispatch); } void factor_vm::c_to_factor_toplevel(cell quot) { - if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler)) - fatal_error("AddVectoredExceptionHandler failed", 0); - c_to_factor(quot); - - RemoveVectoredExceptionHandler((void *)factor::exception_handler); } void factor_vm::open_console() diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp index c5e721c56d..d84ac97298 100755 --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -20,15 +20,9 @@ typedef char symbol_char; #define FACTOR_OS_STRING "winnt" -#define FACTOR_DLL L"factor.dll" +#define FACTOR_DLL NULL -#ifdef _MSC_VER - #define FACTOR_STDCALL(return_type) return_type __stdcall -#else - #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type -#endif - -FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe); +LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); // SSE traps raise these exception codes, which are defined in internal NT headers // but not winbase.h diff --git a/vm/primitives.hpp b/vm/primitives.hpp index 7e95a3bad5..ff0947912c 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -43,7 +43,6 @@ namespace factor _(code_room) \ _(compact_gc) \ _(compute_identity_hashcode) \ - _(context) \ _(context_object) \ _(context_object_for) \ _(current_callback) \ diff --git a/vm/vm.hpp b/vm/vm.hpp index ad74a8e090..36ec3260d6 100755 --- a/vm/vm.hpp +++ b/vm/vm.hpp @@ -112,10 +112,11 @@ struct factor_vm // contexts context *new_context(); + void init_context(context *ctx); void delete_context(context *old_context); void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_); void delete_contexts(); - void begin_callback(); + cell begin_callback(cell quot); void end_callback(); void primitive_current_callback(); void primitive_context_object(); @@ -135,7 +136,6 @@ struct factor_vm void primitive_set_retainstack(); void primitive_check_datastack(); void primitive_load_locals(); - void primitive_context(); template void iterate_active_callstacks(Iterator &iter) { @@ -706,7 +706,7 @@ struct factor_vm #if defined(WINNT) void open_console(); - LONG exception_handler(PEXCEPTION_POINTERS pe); + LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch); #endif #else // UNIX