Merge branch 'master' into sorting
commit
ef98730827
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -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>
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
[
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 {
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue