Merge branch 'master' into sorting

db4
John Benediktsson 2011-05-03 20:51:53 -07:00
commit ef98730827
13 changed files with 83 additions and 57 deletions

View File

@ -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

View File

@ -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

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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

View File

@ -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>

View File

@ -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

View File

@ -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 ;

View File

@ -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
<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

View File

@ -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*
init-thread-timer ;
] [ 2drop ] if* ;
CLASS: FactorApplicationDelegate < NSObject
[

View File

@ -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

View File

@ -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 <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 )
<message> message>byte-array
: dns-query ( name type class -- message )
<query> <message> message>byte-array
<dns-inet4> udp-query parse-message ;
: dns-A-query ( domain -- message ) A IN <query> dns-query ;
: dns-AAAA-query ( domain -- message ) AAAA IN <query> dns-query ;
: dns-MX-query ( domain -- message ) MX IN <query> dns-query ;
: dns-NS-query ( domain -- message ) NS IN <query> dns-query ;
: dns-TXT-query ( domain -- message ) TXT IN <query> 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 <byte-reader> [
[ read1 [ read , t ] [ f ] if* ] loop
] with-input-stream
] { } make ;
: TXT-message>strings ( message -- strings )
answer-section>>
[ rdata>>
[
binary <byte-reader> [
[
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 <query> dns-query ;
PTR IN dns-query ;
: reverse-ipv4-lookup ( ip -- message )
ipv4>arpa reverse-lookup ;

View File

@ -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 {

View File

@ -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