diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor index 2bc8d612b6..571f5bac5e 100644 --- a/basis/bootstrap/threads/threads.factor +++ b/basis/bootstrap/threads/threads.factor @@ -1,9 +1,6 @@ -! Copyright (C) 2008, 2009 Slava Pestov. +! Copyright (C) 2008, 2011 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: vocabs.loader kernel io.thread threads -compiler.utilities namespaces ; -IN: bootstrap.threads +USE: vocabs.loader -{ "bootstrap.threads" "debugger" } "debugger.threads" require-when - -[ yield ] yield-hook set-global +"threads" require +"io.thread" require diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index e4fd64505e..0aae136cae 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -4,6 +4,7 @@ USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs definitions math graphs generic generic.single combinators combinators.smart macros source-files.errors combinators.short-circuit classes.algebra +vocabs.loader stack-checker stack-checker.dependencies stack-checker.inlining stack-checker.errors @@ -181,3 +182,5 @@ M: optimizing-compiler process-forgotten-words : disable-optimizer ( -- ) f compiler-impl set-global ; + +{ "threads" "compiler" } "compiler.threads" require-when diff --git a/basis/compiler/threads/authors.txt b/basis/compiler/threads/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/threads/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/threads/threads.factor b/basis/compiler/threads/threads.factor new file mode 100644 index 0000000000..ed79653e54 --- /dev/null +++ b/basis/compiler/threads/threads.factor @@ -0,0 +1,12 @@ +! Copyright (C) 2011 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.private compiler.utilities kernel namespaces +stack-checker.alien threads threads.private ; +IN: compiler.threads + +[ yield ] yield-hook set-global + +[ + dup current-callback eq? + [ drop ] [ wait-for-callback ] if +] wait-for-callback-hook set-global diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 5396b83dca..b4465c2975 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -104,15 +104,10 @@ TUPLE: run-loop fds sources timers ; : (reset-timer) ( timer timestamp -- ) >CFAbsoluteTime CFRunLoopTimerSetNextFireDate ; -: nano-count>micros ( x -- n ) - nano-count - 1,000 /f system-micros + ; - : reset-timer ( timer -- ) - { - { [ run-queue deque-empty? not ] [ system-micros ] } - { [ sleep-queue heap-empty? not ] [ sleep-queue heap-peek nip nano-count>micros ] } - [ system-micros 1,000,000 + ] - } cond (reset-timer) ; + sleep-time + [ 1000 /f ] [ 1,000,000 ] if* system-micros + + (reset-timer) ; PRIVATE> diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 9159b7f46c..b3eb1d4ad0 100755 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -355,3 +355,5 @@ M: not-found-in-roots summary drop "Cannot resolve vocab: path" ; M: wrong-values summary drop "Quotation's stack effect does not match call site" ; M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ; + +{ "threads" "debugger" } "debugger.threads" require-when diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 149168532f..d393aa9332 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -122,9 +122,13 @@ TUPLE: alien-callback-params < alien-node-params xt ; GENERIC: wrap-callback-quot ( params quot -- quot' ) +SYMBOL: wait-for-callback-hook + +wait-for-callback-hook [ [ drop ] ] initialize + M: callable wrap-callback-quot swap [ callback-parameter-quot ] [ callback-return-quot ] bi surround - yield-hook get + wait-for-callback-hook get '[ _ _ do-callback ] >quotation ; diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 330b4abd6c..fe4f2a0f24 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2004, 2010 Slava Pestov. +! Copyright (C) 2004, 2011 Slava Pestov. ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables heaps kernel kernel.private math -namespaces sequences vectors continuations continuations.private +USING: alien.private arrays hashtables heaps kernel kernel.private +math namespaces sequences vectors continuations continuations.private dlists assocs system combinators init boxes accessors math.order deques strings quotations fry ; IN: threads @@ -101,6 +101,9 @@ PRIVATE> : sleep-queue ( -- heap ) 66 special-object { min-heap } declare ; inline +: waiting-callbacks ( -- assoc ) + 68 special-object { hashtable } declare ; inline + : new-thread ( quot name class -- thread ) new swap >>name @@ -123,6 +126,7 @@ PRIVATE> : sleep-time ( -- nanos/f ) { + { [ current-callback waiting-callbacks key? ] [ 0 ] } { [ run-queue deque-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } [ sleep-queue heap-peek nip nano-count [-] ] @@ -176,8 +180,13 @@ M: thread (next) [ context>> box> set-context-and-delete ] [ t >>runnable drop [start] start-context-and-delete ] if ; +: wake-up-callbacks ( -- ) + current-callback waiting-callbacks delete-at* + [ resume-now ] [ drop ] if ; + : next ( -- obj thread ) expire-sleep-loop + wake-up-callbacks run-queue pop-back dup array? [ first2 ] [ [ f ] dip ] if f >>state @@ -230,7 +239,8 @@ GENERIC: error-in-thread ( error thread -- ) : init-thread-state ( -- ) H{ } clone 64 set-special-object 65 set-special-object - 66 set-special-object ; + 66 set-special-object + H{ } clone 68 set-special-object ; : init-initial-thread ( -- ) [ ] "Initial" @@ -244,6 +254,10 @@ GENERIC: error-in-thread ( error thread -- ) init-thread-state init-initial-thread ; +: wait-for-callback ( callback -- ) + self swap waiting-callbacks set-at + "Callback return" suspend drop ; + PRIVATE> [ init-threads ] "threads" add-startup-hook diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 1e7777d9d7..e211e31374 100644 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -217,7 +217,6 @@ M: cocoa-ui-backend beep ( -- ) NSBeep ; M: cocoa-ui-backend system-alert - invalidate-run-loop-timers NSAlert -> alloc -> init -> autorelease [ { [ swap -> setInformativeText: ] @@ -225,8 +224,7 @@ M: cocoa-ui-backend system-alert [ "OK" -> addButtonWithTitle: drop ] [ -> runModal drop ] } cleave - ] [ 2drop ] if* - init-thread-timer ; + ] [ 2drop ] if* ; CLASS: FactorApplicationDelegate < NSObject [ diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 98b1d6428c..cb61f70c2c 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -101,21 +101,12 @@ SYMBOL: callbacks [ H{ } clone callbacks set-global ] "alien" add-startup-hook -! Every callback invocation has a unique identifier in the VM. -! We make sure that the current callback is the right one before -! returning from it, to avoid a bad interaction between threads -! and callbacks. See basis/compiler/tests/alien.factor for a -! test case. -: wait-to-return ( yield-quot: ( -- ) callback-id -- ) - dup current-callback eq? - [ 2drop ] [ over call wait-to-return ] if ; inline recursive - ! Used by compiler.codegen to wrap callback bodies -: do-callback ( callback-quot yield-quot: ( -- ) -- ) +: do-callback ( callback-quot wait-quot: ( callback -- ) -- ) init-namespaces init-catchstack current-callback - [ 2drop call ] [ wait-to-return drop ] 3bi ; inline + [ 2drop call ] [ swap call( callback -- ) drop ] 3bi ; inline ! A utility for defining global variables that are recompiled in ! every session diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor index 57795f49c2..4e2aa75d93 100644 --- a/extra/dns/dns.factor +++ b/extra/dns/dns.factor @@ -6,7 +6,8 @@ io io.binary io.encodings.binary io.encodings.string io.encodings.utf8 io.sockets io.sockets.private io.streams.byte-array io.timeouts kernel make math math.bitwise math.parser namespaces nested-comments random sequences -slots.syntax splitting system vectors vocabs.loader strings ; +slots.syntax splitting system vectors vocabs.loader strings +ascii ; IN: dns : with-input-seek ( n seek-type quot -- ) @@ -238,10 +239,15 @@ M: SOA parse-rdata 2drop parse-soa ; [ [ parse-rr ] replicate ] change-additional-section ] with-byte-reader ; -: >n/label ( string -- byte-array ) - [ length 1array ] [ utf8 encode ] bi B{ } append-as ; +ERROR: unsupported-domain-name string ; -: >name ( domain -- byte-array ) "." split [ >n/label ] map concat ; +: >n/label ( string -- byte-array ) + dup [ ascii? ] all? + [ unsupported-domain-name ] unless + [ length 1array ] [ ] bi B{ } append-as ; + +: >name ( domain -- byte-array ) + "." split [ >n/label ] map concat ; : query>byte-array ( query -- byte-array ) [ @@ -321,40 +327,41 @@ M: TXT rdata>byte-array : udp-query ( bytes server -- bytes' ) f 0 - 30 seconds over set-timeout [ + 10 seconds over set-timeout [ [ send ] [ receive drop ] bi ] with-disposal ; : ( -- inet4 ) dns-servers get random 53 ; -: dns-query ( query -- message ) - message>byte-array +: dns-query ( name type class -- message ) + message>byte-array udp-query parse-message ; -: dns-A-query ( domain -- message ) A IN dns-query ; -: dns-AAAA-query ( domain -- message ) AAAA IN dns-query ; -: dns-MX-query ( domain -- message ) MX IN dns-query ; -: dns-NS-query ( domain -- message ) NS IN dns-query ; -: dns-TXT-query ( domain -- message ) TXT IN dns-query ; +: dns-A-query ( name -- message ) A IN dns-query ; +: dns-AAAA-query ( name -- message ) AAAA IN dns-query ; +: dns-MX-query ( name -- message ) MX IN dns-query ; +: dns-NS-query ( name -- message ) NS IN dns-query ; +: dns-TXT-query ( name -- message ) TXT IN dns-query ; + +: read-TXT-strings ( byte-array -- strings ) + [ + binary [ + [ read1 [ read , t ] [ f ] if* ] loop + ] with-input-stream + ] { } make ; : TXT-message>strings ( message -- strings ) answer-section>> [ rdata>> - [ - binary [ - [ - read1 [ read , t ] [ f ] if* - ] loop - ] with-input-stream - ] { } make [ utf8 decode ] map + read-TXT-strings [ utf8 decode ] map ] map ; -: TXT. ( domain -- ) +: TXT. ( name -- ) dns-TXT-query TXT-message>strings [ [ write ] each nl ] each ; : reverse-lookup ( reversed-ip -- message ) - PTR IN dns-query ; + PTR IN dns-query ; : reverse-ipv4-lookup ( ip -- message ) ipv4>arpa reverse-lookup ; diff --git a/extra/game/debug/tests/tests.factor b/extra/game/debug/tests/tests.factor index 2a70f55d8a..b6bcacc780 100644 --- a/extra/game/debug/tests/tests.factor +++ b/extra/game/debug/tests/tests.factor @@ -41,14 +41,14 @@ IN: game.debug.tests COLOR: purple { 5 5 } world dim>> draw-text world [ 1 + ] change-frame# drop ; -TUPLE: tests-world < wasd-world frame-number ; +TUPLE: tests-world < wasd-world frame# ; M: tests-world draw-world* draw-debug-tests ; M: tests-world wasd-movement-speed drop 1/16. ; M: tests-world wasd-near-plane drop 1/32. ; M: tests-world wasd-far-plane drop 1024.0 ; M: tests-world begin-game-world init-gpu - 0 >>frame-number + 0 >>frame# { 0.0 0.0 2.0 } 0 0 set-wasd-view drop ; GAME: run-tests { diff --git a/vm/objects.hpp b/vm/objects.hpp index 41265cd241..0b17c921bf 100755 --- a/vm/objects.hpp +++ b/vm/objects.hpp @@ -93,6 +93,8 @@ enum special_object { OBJ_SLEEP_QUEUE = 66, OBJ_VM_COMPILER = 67, /* version string of the compiler we were built with */ + + OBJ_WAITING_CALLBACKS = 68, }; /* save-image-and-exit discards special objects that are filled in on startup