Merge branch 'master' into sorting

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
+USE: vocabs.loader
-compiler.utilities namespaces ;
-IN: bootstrap.threads
 
-{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
+"threads" require
-
+"io.thread" require
-[ yield ] yield-hook set-global

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

basis/compiler/threads/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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

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 -- )
-    {
+    sleep-time
-        { [ run-queue deque-empty? not ] [ system-micros ] }
+    [ 1000 /f ] [ 1,000,000 ] if* system-micros +
-        { [ sleep-queue heap-empty? not ] [ sleep-queue heap-peek nip nano-count>micros ] }
+    (reset-timer) ;
-        [ system-micros 1,000,000 + ]
-    } cond (reset-timer) ;
 
 PRIVATE>
 

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

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 ;
 

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
+USING: alien.private arrays hashtables heaps kernel kernel.private
-namespaces sequences vectors continuations continuations.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
     <dlist> 65 set-special-object
-    <min-heap> 66 set-special-object ;
+    <min-heap> 66 set-special-object
+    H{ } clone 68 set-special-object ;
 
 : init-initial-thread ( -- )
     [ ] "Initial" <thread>
@@ -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

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 <NSString> -> setInformativeText: ]
@@ -225,8 +224,7 @@ M: cocoa-ui-backend system-alert
             [ "OK" <NSString> -> addButtonWithTitle: drop ]
             [ -> runModal drop ]
         } cleave
-    ] [ 2drop ] if*
+    ] [ 2drop ] if* ;
-    init-thread-timer ;
 
 CLASS: FactorApplicationDelegate < NSObject
 [

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

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 )
+ERROR: unsupported-domain-name string ;
-    [ length 1array ] [ utf8 encode ] bi B{ } append-as ;
 
-: >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 <inet4> <datagram>
-    30 seconds over set-timeout [
+    10 seconds over set-timeout [
         [ send ] [ receive drop ] bi
     ] with-disposal ;
 
 : <dns-inet4> ( -- inet4 )
     dns-servers get random 53 <inet4> ;
 
-: dns-query ( query -- message )
+: dns-query ( name type class -- message )
-    <message> message>byte-array
+    <query> <message> message>byte-array
     <dns-inet4> udp-query parse-message ;
 
-: dns-A-query ( domain -- message ) A IN <query> dns-query ;
+: dns-A-query ( name -- message ) A IN dns-query ;
-: dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ;
+: dns-AAAA-query ( name -- message ) AAAA IN dns-query ;
-: dns-MX-query ( domain -- message ) MX IN <query> dns-query ;
+: dns-MX-query ( name -- message ) MX IN dns-query ;
-: dns-NS-query ( domain -- message ) NS IN <query> dns-query ;
+: dns-NS-query ( name -- message ) NS IN dns-query ;
-: dns-TXT-query ( domain -- message ) TXT IN <query> dns-query ;
+: dns-TXT-query ( name -- message ) TXT IN dns-query ;
+
+: read-TXT-strings ( byte-array -- strings )
+    [
+        binary <byte-reader> [
+            [ read1 [ read , t ] [ f ] if* ] loop
+        ] with-input-stream
+    ] { } make ;
 
 : TXT-message>strings ( message -- strings )
     answer-section>>
     [ rdata>>
-        [
+        read-TXT-strings [ utf8 decode ] map
-            binary <byte-reader> [
-                [
-                    read1 [ read , t ] [ f ] if*
-                ] loop
-            ] with-input-stream
-        ] { } make [ 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 <query> dns-query ;
+    PTR IN dns-query ;
 
 : reverse-ipv4-lookup ( ip -- message )
     ipv4>arpa reverse-lookup ;

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 {

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