Merge git://factorcode.org/git/factor
Doug Coleman
commit
9337850473
|
|
@ -48,7 +48,11 @@ IN: bootstrap.stage2
|
|||
|
||||
"Compiling remaining words..." print flush
|
||||
|
||||
all-words [ compiled? not ] subset recompile-hook get call
|
||||
"bootstrap.compiler" vocab [
|
||||
vocabs [
|
||||
words "compile" "compiler" lookup execute
|
||||
] each
|
||||
] when
|
||||
] with-compiler-errors
|
||||
|
||||
f error set-global
|
||||
|
|
|
|||
|
|
@ -205,3 +205,27 @@ DEFER: generic-then-not-generic-test-2
|
|||
[ ] [ "IN: temporary USE: math : generic-then-not-generic-test-1 1 + ;" eval ] unit-test
|
||||
|
||||
[ 4 ] [ generic-then-not-generic-test-2 ] unit-test
|
||||
|
||||
DEFER: foldable-test-2
|
||||
|
||||
[ ] [ "IN: temporary : foldable-test-1 3 ; foldable" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : foldable-test-2 foldable-test-1 ;" eval ] unit-test
|
||||
|
||||
[ 3 ] [ foldable-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : foldable-test-1 4 ; foldable" eval ] unit-test
|
||||
|
||||
[ 4 ] [ foldable-test-2 ] unit-test
|
||||
|
||||
DEFER: flushable-test-2
|
||||
|
||||
[ ] [ "IN: temporary USE: kernel : flushable-test-1 drop 3 ; flushable" eval ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: kernel : flushable-test-2 V{ } dup flushable-test-1 drop ;" eval ] unit-test
|
||||
|
||||
[ V{ } ] [ flushable-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USING: kernel sequences ; : flushable-test-1 3 over push ;" eval ] unit-test
|
||||
|
||||
[ V{ 3 } ] [ flushable-test-2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init kernel system ;
|
||||
USING: init kernel system namespaces ;
|
||||
IN: io.backend
|
||||
|
||||
SYMBOL: io-backend
|
||||
|
|
@ -21,3 +21,6 @@ M: object normalize-pathname ;
|
|||
|
||||
[ init-io embedded? [ init-stdio ] unless ]
|
||||
"io.backend" add-init-hook
|
||||
|
||||
: set-io-backend ( backend -- )
|
||||
io-backend set-global init-io init-stdio ;
|
||||
|
|
|
|||
|
|
@ -209,7 +209,7 @@ HELP: bitxor
|
|||
|
||||
HELP: shift
|
||||
{ $values { "x" integer } { "n" integer } { "y" integer } }
|
||||
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "y" } " bits if " { $snippet "y" } " is positive, or " { $snippet "-y" } " bits to the right if " { $snippet "y" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
|
||||
{ $description "Shifts " { $snippet "x" } " to the left by " { $snippet "n" } " bits if " { $snippet "n" } " is positive, or " { $snippet "-n" } " bits to the right if " { $snippet "n" } " is negative. A left shift of a fixnum may overflow, yielding a bignum. A right shift may result in bits ``falling off'' the right hand side and being discarded." }
|
||||
{ $examples { $example "BIN: 101 5 shift .b" "10100000" } { $example "BIN: 11111 -2 shift .b" "111" } } ;
|
||||
|
||||
HELP: bitnot
|
||||
|
|
|
|||
|
|
@ -17,17 +17,17 @@ SYMBOL: optimizer-changed
|
|||
|
||||
GENERIC: optimize-node* ( node -- node/t changed? )
|
||||
|
||||
: ?union ( hash/f hash -- hash )
|
||||
: ?union ( assoc/f assoc -- hash )
|
||||
over [ union ] [ nip ] if ;
|
||||
|
||||
: add-node-literals ( hash node -- )
|
||||
: add-node-literals ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
[ node-literals ?union ] keep set-node-literals
|
||||
] if ;
|
||||
|
||||
: add-node-classes ( hash node -- )
|
||||
: add-node-classes ( assoc node -- )
|
||||
over assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
|
|
@ -324,6 +324,7 @@ M: #dispatch optimize-node*
|
|||
] if ;
|
||||
|
||||
: flush-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup node-out-d length f <repetition> inline-literals ;
|
||||
|
||||
: partial-eval? ( #call -- ? )
|
||||
|
|
@ -337,9 +338,9 @@ M: #dispatch optimize-node*
|
|||
dup node-in-d [ node-literal ] with map ;
|
||||
|
||||
: partial-eval ( #call -- node )
|
||||
dup node-param +inlined+ depends-on
|
||||
dup literal-in-d over node-param 1quotation
|
||||
[ with-datastack ] catch
|
||||
[ 3drop t ] [ inline-literals ] if ;
|
||||
[ with-datastack inline-literals ] [ 2drop 2drop t ] recover ;
|
||||
|
||||
: define-identities ( words identities -- )
|
||||
[ "identities" set-word-prop ] curry each ;
|
||||
|
|
|
|||
|
|
@ -44,8 +44,7 @@ ARTICLE: "vocabulary-search-errors" "Word lookup errors"
|
|||
"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:"
|
||||
{ $list
|
||||
{ "If there are no words having this name at all, an error is thrown and parsing stops." }
|
||||
{ "If there is exactly one vocabulary having a word with this name, the vocabulary is automatically added to the search path. This behavior is intended for interactive use and exploratory programming only, and production code should contain full " { $link POSTPONE: USING: } " declarations." }
|
||||
{ "If there is more than one vocabulary which contains a word with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
|
||||
{ "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." }
|
||||
}
|
||||
"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -175,3 +175,14 @@ SYMBOL: quot-uses-b
|
|||
|
||||
[ t ] [ "symbol-generic" "temporary" lookup symbol? ] unit-test
|
||||
[ f ] [ "symbol-generic" "temporary" lookup generic? ] unit-test
|
||||
|
||||
! Regressions
|
||||
[ ] [ "IN: temporary : decl-forget-test ; foldable" eval ] unit-test
|
||||
[ t ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
|
||||
[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
|
||||
[ f ] [ "decl-forget-test" "temporary" lookup "foldable" word-prop ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary : decl-forget-test ; flushable" eval ] unit-test
|
||||
[ t ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test
|
||||
[ ] [ "IN: temporary : decl-forget-test ;" eval ] unit-test
|
||||
[ f ] [ "decl-forget-test" "temporary" lookup "flushable" word-prop ] unit-test
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ SYMBOL: changed-words
|
|||
: reset-word ( word -- )
|
||||
{
|
||||
"unannotated-def"
|
||||
"parsing" "inline" "foldable"
|
||||
"parsing" "inline" "foldable" "flushable"
|
||||
"predicating"
|
||||
"reading" "writing"
|
||||
"constructing"
|
||||
|
|
|
|||
|
|
@ -10,6 +10,3 @@ IN: bootstrap.io
|
|||
{ [ wince? ] [ "windows.ce" ] }
|
||||
} cond append require
|
||||
] when
|
||||
|
||||
init-io
|
||||
init-stdio
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: io io.buffers io.backend help.markup help.syntax kernel
|
||||
strings sbufs ;
|
||||
strings sbufs words ;
|
||||
IN: io.nonblocking
|
||||
|
||||
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
|
||||
|
|
@ -40,7 +40,7 @@ $nl
|
|||
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
|
||||
{ { $link port-timeout } " - a timeout, specifying the maximum length of time, in milliseconds, for which input operations can block before throwing an error. A value of 0 denotes no timeout is desired." }
|
||||
{ { $link port-cutoff } " - the time when the current timeout expires; if no input data arrives before this time, an error is thrown" }
|
||||
{ { $link port-type } " - a symbol identifying the port's intended purpose. Can be " { $link input } ", " { $link output } ", " { $link closed } ", or any other symbol" }
|
||||
{ { $link port-type } " - a symbol identifying the port's intended purpose" }
|
||||
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
|
||||
} } ;
|
||||
|
||||
|
|
@ -55,7 +55,7 @@ HELP: init-handle
|
|||
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
|
||||
|
||||
HELP: <port>
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "port" "a new " { $link port } } }
|
||||
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
|
||||
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
|
||||
$low-level-note ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,38 +12,36 @@ SYMBOL: default-buffer-size
|
|||
! Common delegate of native stream readers and writers
|
||||
TUPLE: port handle error timeout cutoff type eof? ;
|
||||
|
||||
SYMBOL: input
|
||||
SYMBOL: output
|
||||
SYMBOL: closed
|
||||
|
||||
PREDICATE: port input-port port-type input eq? ;
|
||||
PREDICATE: port output-port port-type output eq? ;
|
||||
PREDICATE: port input-port port-type input-port eq? ;
|
||||
PREDICATE: port output-port port-type output-port eq? ;
|
||||
|
||||
GENERIC: init-handle ( handle -- )
|
||||
GENERIC: close-handle ( handle -- )
|
||||
|
||||
: <port> ( handle buffer -- port )
|
||||
over init-handle
|
||||
: <port> ( handle buffer type -- port )
|
||||
pick init-handle
|
||||
0 0 {
|
||||
set-port-handle
|
||||
set-delegate
|
||||
set-port-type
|
||||
set-port-timeout
|
||||
set-port-cutoff
|
||||
} port construct ;
|
||||
|
||||
: <buffered-port> ( handle -- port )
|
||||
default-buffer-size get <buffer> <port> ;
|
||||
: <buffered-port> ( handle type -- port )
|
||||
default-buffer-size get <buffer> swap <port> ;
|
||||
|
||||
: <reader> ( handle -- stream )
|
||||
<buffered-port> input over set-port-type <line-reader> ;
|
||||
input-port <buffered-port> <line-reader> ;
|
||||
|
||||
: <writer> ( handle -- stream )
|
||||
<buffered-port> output over set-port-type <plain-writer> ;
|
||||
output-port <buffered-port> <plain-writer> ;
|
||||
|
||||
: handle>duplex-stream ( in-handle out-handle -- stream )
|
||||
<writer>
|
||||
[ >r <reader> r> <duplex-stream> ]
|
||||
[ ] [ stream-close ]
|
||||
[ >r <reader> r> <duplex-stream> ] [ ] [ stream-close ]
|
||||
cleanup ;
|
||||
|
||||
: touch-port ( port -- )
|
||||
|
|
@ -162,7 +160,7 @@ M: output-port stream-flush ( port -- )
|
|||
M: port stream-close
|
||||
dup port-type closed eq? [
|
||||
dup port-type >r closed over set-port-type r>
|
||||
output eq? [ dup port-flush ] when
|
||||
output-port eq? [ dup port-flush ] when
|
||||
dup port-handle close-handle
|
||||
dup delegate [ buffer-free ] when*
|
||||
f over set-delegate
|
||||
|
|
@ -170,8 +168,8 @@ M: port stream-close
|
|||
|
||||
TUPLE: server-port addr client ;
|
||||
|
||||
: <server-port> ( port addr -- server )
|
||||
server-port pick set-port-type
|
||||
: <server-port> ( handle addr -- server )
|
||||
>r f server-port <port> r>
|
||||
{ set-delegate set-server-port-addr }
|
||||
server-port construct ;
|
||||
|
||||
|
|
@ -180,8 +178,8 @@ TUPLE: server-port addr client ;
|
|||
|
||||
TUPLE: datagram-port addr packet packet-addr ;
|
||||
|
||||
: <datagram-port> ( port addr -- datagram )
|
||||
datagram-port pick set-port-type
|
||||
: <datagram-port> ( handle addr -- datagram )
|
||||
>r f datagram-port <port> r>
|
||||
{ set-delegate set-datagram-port-addr }
|
||||
datagram-port construct ;
|
||||
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ M: unix-io <sniffer> ( obj -- sniffer )
|
|||
] keep
|
||||
dupd sniffer-spec-ifname ioctl-sniffer-fd
|
||||
dup make-ioctl-buffer
|
||||
<port> input over set-port-type <line-reader>
|
||||
input-port <port> <line-reader>
|
||||
\ sniffer construct-delegate
|
||||
] with-destructors ;
|
||||
|
||||
|
|
|
|||
|
|
@ -7,19 +7,60 @@ continuations system libc qualified namespaces ;
|
|||
QUALIFIED: io
|
||||
IN: io.unix.backend
|
||||
|
||||
! Multiplexer protocol
|
||||
SYMBOL: unix-io-backend
|
||||
MIXIN: unix-io
|
||||
|
||||
HOOK: init-unix-io unix-io-backend ( -- )
|
||||
HOOK: register-io-task unix-io-backend ( task -- )
|
||||
HOOK: unregister-io-task unix-io-backend ( task -- )
|
||||
HOOK: unix-io-multiplex unix-io-backend ( timeval -- )
|
||||
! I/O tasks
|
||||
TUPLE: io-task port callbacks ;
|
||||
|
||||
TUPLE: unix-io ;
|
||||
: io-task-fd io-task-port port-handle ;
|
||||
|
||||
! Global variables
|
||||
SYMBOL: read-tasks
|
||||
SYMBOL: write-tasks
|
||||
: <io-task> ( port continuation class -- task )
|
||||
>r 1vector io-task construct-boa r> construct-delegate ;
|
||||
inline
|
||||
|
||||
TUPLE: input-task ;
|
||||
|
||||
: <input-task> ( port continuation class -- task )
|
||||
>r input-task <io-task> r> construct-delegate ; inline
|
||||
|
||||
TUPLE: output-task ;
|
||||
|
||||
: <output-task> ( port continuation class -- task )
|
||||
>r output-task <io-task> r> construct-delegate ; inline
|
||||
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: io-task-container ( mx task -- hashtable )
|
||||
|
||||
! I/O multiplexers
|
||||
TUPLE: mx fd reads writes ;
|
||||
|
||||
M: input-task io-task-container drop mx-reads ;
|
||||
|
||||
M: output-task io-task-container drop mx-writes ;
|
||||
|
||||
: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
|
||||
|
||||
: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
|
||||
|
||||
GENERIC: register-io-task ( task mx -- )
|
||||
GENERIC: unregister-io-task ( task mx -- )
|
||||
GENERIC: wait-for-events ( ms mx -- )
|
||||
|
||||
: fd/container ( task mx -- task fd container )
|
||||
over io-task-container >r dup io-task-fd r> ; inline
|
||||
|
||||
: check-io-task ( task mx -- )
|
||||
fd/container key? nip [
|
||||
"Cannot perform multiple reads from the same port" throw
|
||||
] when ;
|
||||
|
||||
M: mx register-io-task ( task mx -- )
|
||||
2dup check-io-task fd/container set-at ;
|
||||
|
||||
: add-io-task ( task -- ) mx get-global register-io-task ;
|
||||
|
||||
M: mx unregister-io-task ( task mx -- )
|
||||
fd/container delete-at drop ;
|
||||
|
||||
! Some general stuff
|
||||
: file-mode OCT: 0666 ;
|
||||
|
|
@ -52,43 +93,15 @@ M: integer close-handle ( fd -- )
|
|||
err_no dup ignorable-error?
|
||||
[ 2drop f ] [ strerror swap report-error t ] if ;
|
||||
|
||||
! Associates a port with a list of continuations waiting on the
|
||||
! port to finish I/O
|
||||
TUPLE: io-task port callbacks ;
|
||||
|
||||
: <io-task> ( port continuation class -- task )
|
||||
>r 1vector io-task construct-boa r> construct-delegate ;
|
||||
inline
|
||||
|
||||
! Multiplexer
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: task-container ( task -- vector )
|
||||
|
||||
: io-task-fd io-task-port port-handle ;
|
||||
|
||||
: check-io-task ( task -- )
|
||||
dup io-task-fd swap task-container at [
|
||||
"Cannot perform multiple reads from the same port" throw
|
||||
] when ;
|
||||
|
||||
: add-io-task ( task -- )
|
||||
dup check-io-task
|
||||
dup register-io-task
|
||||
dup io-task-fd over task-container set-at ;
|
||||
|
||||
: remove-io-task ( task -- )
|
||||
dup io-task-fd over task-container delete-at
|
||||
unregister-io-task ;
|
||||
|
||||
: pop-callbacks ( task -- )
|
||||
dup remove-io-task
|
||||
: pop-callbacks ( mx task -- )
|
||||
dup rot unregister-io-task
|
||||
io-task-callbacks [ schedule-thread ] each ;
|
||||
|
||||
: handle-fd ( task -- )
|
||||
: handle-io-task ( mx task -- )
|
||||
dup io-task-port touch-port
|
||||
dup do-io-task [ pop-callbacks ] [ drop ] if ;
|
||||
dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
|
||||
|
||||
: handle-timeout ( task -- )
|
||||
: handle-timeout ( mx task -- )
|
||||
"Timeout" over io-task-port report-error pop-callbacks ;
|
||||
|
||||
! Readers
|
||||
|
|
@ -113,15 +126,12 @@ GENERIC: task-container ( task -- vector )
|
|||
TUPLE: read-task ;
|
||||
|
||||
: <read-task> ( port continuation -- task )
|
||||
read-task <io-task> ;
|
||||
read-task <input-task> ;
|
||||
|
||||
M: read-task do-io-task
|
||||
io-task-port dup refill
|
||||
[ [ reader-eof ] [ drop ] if ] keep ;
|
||||
|
||||
M: read-task task-container
|
||||
drop read-tasks get-global ;
|
||||
|
||||
M: input-port (wait-to-read)
|
||||
[ <read-task> add-io-task stop ] callcc0 pending-error ;
|
||||
|
||||
|
|
@ -133,19 +143,16 @@ M: input-port (wait-to-read)
|
|||
TUPLE: write-task ;
|
||||
|
||||
: <write-task> ( port continuation -- task )
|
||||
write-task <io-task> ;
|
||||
write-task <output-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup buffer-empty? over port-error or
|
||||
[ 0 swap buffer-reset t ] [ write-step ] if ;
|
||||
|
||||
M: write-task task-container
|
||||
drop write-tasks get-global ;
|
||||
|
||||
: add-write-io-task ( port continuation -- )
|
||||
over port-handle write-tasks get-global at
|
||||
over port-handle mx get-global mx-writes at*
|
||||
[ io-task-callbacks push drop ]
|
||||
[ <write-task> add-io-task ] if* ;
|
||||
[ drop <write-task> add-io-task ] if ;
|
||||
|
||||
: (wait-to-write) ( port -- )
|
||||
[ add-write-io-task stop ] callcc0 drop ;
|
||||
|
|
@ -154,16 +161,26 @@ M: port port-flush ( port -- )
|
|||
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: unix-io io-multiplex ( ms -- )
|
||||
unix-io-multiplex ;
|
||||
|
||||
M: unix-io init-io ( -- )
|
||||
H{ } clone read-tasks set-global
|
||||
H{ } clone write-tasks set-global
|
||||
init-unix-io ;
|
||||
mx get-global wait-for-events ;
|
||||
|
||||
M: unix-io init-stdio ( -- )
|
||||
0 1 handle>duplex-stream io:stdio set-global
|
||||
2 <writer> io:stderr set-global ;
|
||||
|
||||
! mx io-task for embedding an fd-based mx inside another mx
|
||||
TUPLE: mx-port mx ;
|
||||
|
||||
: <mx-port> ( mx -- port )
|
||||
dup mx-fd f mx-port <port>
|
||||
{ set-mx-port-mx set-delegate } mx-port construct ;
|
||||
|
||||
TUPLE: mx-task ;
|
||||
|
||||
: <mx-task> ( port -- task )
|
||||
f io-task construct-boa mx-task construct-delegate ;
|
||||
|
||||
M: mx-task do-io-task
|
||||
io-task-port mx-port-mx 0 swap wait-for-events f ;
|
||||
|
||||
: multiplexer-error ( n -- )
|
||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||
|
|
|
|||
|
|
@ -1,106 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
io.unix.sockets sequences assocs unix unix.kqueue math
|
||||
namespaces classes combinators ;
|
||||
IN: io.unix.backend.kqueue
|
||||
|
||||
TUPLE: unix-kqueue-io ;
|
||||
|
||||
! Global variables
|
||||
SYMBOL: kqueue-fd
|
||||
SYMBOL: kqueue-added
|
||||
SYMBOL: kqueue-deleted
|
||||
SYMBOL: kqueue-events
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
#! constant...
|
||||
256 ; inline
|
||||
|
||||
M: unix-kqueue-io init-unix-io ( -- )
|
||||
H{ } clone kqueue-added set-global
|
||||
H{ } clone kqueue-deleted set-global
|
||||
max-events "kevent" <c-array> kqueue-events set-global
|
||||
kqueue dup io-error kqueue-fd set-global ;
|
||||
|
||||
M: unix-kqueue-io register-io-task ( task -- )
|
||||
dup io-task-fd kqueue-added get-global key? [ drop ] [
|
||||
dup io-task-fd kqueue-deleted get-global key? [
|
||||
io-task-fd kqueue-deleted get-global delete-at
|
||||
] [
|
||||
dup io-task-fd kqueue-added get-global set-at
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: unix-kqueue-io unregister-io-task ( task -- )
|
||||
dup io-task-fd kqueue-deleted get-global key? [ drop ] [
|
||||
dup io-task-fd kqueue-added get-global key? [
|
||||
io-task-fd kqueue-added get-global delete-at
|
||||
] [
|
||||
dup io-task-fd kqueue-deleted get-global set-at
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: io-task-filter ( task -- n )
|
||||
class {
|
||||
{ read-task [ EVFILT_READ ] }
|
||||
{ accept-task [ EVFILT_READ ] }
|
||||
{ receive-task [ EVFILT_READ ] }
|
||||
{ write-task [ EVFILT_WRITE ] }
|
||||
{ connect-task [ EVFILT_WRITE ] }
|
||||
{ send-task [ EVFILT_WRITE ] }
|
||||
} case ;
|
||||
|
||||
: make-kevent ( task -- event )
|
||||
"kevent" <c-object>
|
||||
over io-task-fd over set-kevent-ident
|
||||
swap io-task-filter over set-kevent-filter ;
|
||||
|
||||
: make-add-kevent ( task -- event )
|
||||
make-kevent
|
||||
EV_ADD over set-kevent-flags ;
|
||||
|
||||
: make-delete-kevent ( task -- event )
|
||||
make-kevent
|
||||
EV_DELETE over set-kevent-flags ;
|
||||
|
||||
: kqueue-additions ( -- kevents )
|
||||
kqueue-added get-global
|
||||
dup clear-assoc values
|
||||
[ make-add-kevent ] map ;
|
||||
|
||||
: kqueue-deletions ( -- kevents )
|
||||
kqueue-deleted get-global
|
||||
dup clear-assoc values
|
||||
[ make-delete-kevent ] map ;
|
||||
|
||||
: kqueue-changelist ( -- byte-array n )
|
||||
kqueue-additions kqueue-deletions append
|
||||
dup concat f like swap length ;
|
||||
|
||||
: kqueue-eventlist ( -- byte-array n )
|
||||
kqueue-events get-global max-events ;
|
||||
|
||||
: do-kevent ( timespec -- n )
|
||||
>r
|
||||
kqueue-fd get-global
|
||||
kqueue-changelist
|
||||
kqueue-eventlist
|
||||
r> kevent dup multiplexer-error ;
|
||||
|
||||
: kevent-task ( kevent -- task )
|
||||
dup kevent-ident swap kevent-filter {
|
||||
{ [ dup EVFILT_READ = ] [ read-tasks ] }
|
||||
{ [ dup EVFILT_WRITE = ] [ write-tasks ] }
|
||||
} cond nip get at ;
|
||||
|
||||
: handle-kevents ( n eventlist -- )
|
||||
[ kevent-nth kevent-task handle-fd ] curry each ;
|
||||
|
||||
M: unix-kqueue-io unix-io-multiplex ( ms -- )
|
||||
make-timespec
|
||||
do-kevent
|
||||
kqueue-events get-global handle-kevents ;
|
||||
|
||||
T{ unix-kqueue-io } unix-io-backend set-global
|
||||
|
|
@ -1,52 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax kernel io.nonblocking io.unix.backend
|
||||
bit-arrays sequences assocs unix math namespaces structs ;
|
||||
IN: io.unix.backend.select
|
||||
|
||||
TUPLE: unix-select-io ;
|
||||
|
||||
! Global variables
|
||||
SYMBOL: read-fdset
|
||||
SYMBOL: write-fdset
|
||||
|
||||
M: unix-select-io init-unix-io ( -- )
|
||||
FD_SETSIZE 8 * <bit-array> read-fdset set-global
|
||||
FD_SETSIZE 8 * <bit-array> write-fdset set-global ;
|
||||
|
||||
: handle-fdset ( fdset tasks -- )
|
||||
swap [
|
||||
swap dup io-task-port timeout? [
|
||||
nip handle-timeout
|
||||
] [
|
||||
tuck io-task-fd swap nth
|
||||
[ handle-fd ] [ drop ] if
|
||||
] if drop
|
||||
] curry assoc-each ;
|
||||
|
||||
: init-fdset ( fdset tasks -- )
|
||||
swap dup clear-bits
|
||||
[ >r drop t swap r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
read-fdset get-global read-tasks get-global ;
|
||||
|
||||
: write-fdset/tasks
|
||||
write-fdset get-global write-tasks get-global ;
|
||||
|
||||
: init-fdsets ( -- read write except )
|
||||
read-fdset/tasks dupd init-fdset
|
||||
write-fdset/tasks dupd init-fdset
|
||||
f ;
|
||||
|
||||
M: unix-select-io register-io-task ( task -- ) drop ;
|
||||
|
||||
M: unix-select-io unregister-io-task ( task -- ) drop ;
|
||||
|
||||
M: unix-select-io unix-io-multiplex ( timeval -- )
|
||||
make-timeval >r FD_SETSIZE init-fdsets r>
|
||||
select multiplexer-error
|
||||
read-fdset/tasks handle-fdset
|
||||
write-fdset/tasks handle-fdset ;
|
||||
|
||||
T{ unix-select-io } unix-io-backend set-global
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.unix.bsd
|
||||
USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
|
||||
io.unix.launcher namespaces kernel assocs threads continuations
|
||||
;
|
||||
|
||||
! On *BSD and Mac OS X, we use select() for the top-level
|
||||
! multiplexer, and we hang a kqueue off of it but file change
|
||||
! notification and process exit notification.
|
||||
|
||||
! kqueue is buggy with files and ptys so we can't use it as the
|
||||
! main multiplexer.
|
||||
|
||||
TUPLE: bsd-io ;
|
||||
|
||||
INSTANCE: bsd-io unix-io
|
||||
|
||||
M: bsd-io init-io ( -- )
|
||||
<select-mx> mx set-global
|
||||
<kqueue-mx> kqueue-mx set-global
|
||||
kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
|
||||
2dup mx get-global mx-reads set-at
|
||||
mx get-global mx-writes set-at ;
|
||||
|
||||
M: bsd-io wait-for-process ( pid -- status )
|
||||
[ kqueue-mx get-global add-pid-task stop ] curry callcc1 ;
|
||||
|
||||
T{ bsd-io } set-io-backend
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
bit-arrays sequences assocs unix unix.linux.epoll math
|
||||
namespaces structs ;
|
||||
IN: io.unix.epoll
|
||||
|
||||
TUPLE: epoll-mx events ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
#! constant...
|
||||
256 ; inline
|
||||
|
||||
: <epoll-mx> ( -- mx )
|
||||
epoll-mx construct-mx
|
||||
max-events epoll_create dup io-error over set-mx-fd
|
||||
max-events "epoll-event" <c-array> over set-epoll-mx-events ;
|
||||
|
||||
GENERIC: io-task-events ( task -- n )
|
||||
|
||||
M: input-task io-task-events drop EPOLLIN ;
|
||||
|
||||
M: output-task io-task-events drop EPOLLOUT ;
|
||||
|
||||
: make-event ( task -- event )
|
||||
"epoll-event" <c-object>
|
||||
over io-task-events over set-epoll-event-events
|
||||
swap io-task-fd over set-epoll-event-fd ;
|
||||
|
||||
: do-epoll-ctl ( task mx what -- )
|
||||
>r mx-fd r> rot dup io-task-fd swap make-event
|
||||
epoll_ctl io-error ;
|
||||
|
||||
M: epoll-mx register-io-task ( task mx -- )
|
||||
2dup EPOLL_CTL_ADD do-epoll-ctl
|
||||
delegate register-io-task ;
|
||||
|
||||
M: epoll-mx unregister-io-task ( task mx -- )
|
||||
2dup delegate unregister-io-task
|
||||
EPOLL_CTL_DEL do-epoll-ctl ;
|
||||
|
||||
: wait-event ( mx timeout -- n )
|
||||
>r { mx-fd epoll-mx-events } get-slots max-events
|
||||
r> epoll_wait dup multiplexer-error ;
|
||||
|
||||
: epoll-read-task ( mx fd -- )
|
||||
over mx-reads at* [ handle-io-task ] [ 2drop ] if ;
|
||||
|
||||
: epoll-write-task ( mx fd -- )
|
||||
over mx-writes at* [ handle-io-task ] [ 2drop ] if ;
|
||||
|
||||
: handle-event ( mx kevent -- )
|
||||
epoll-event-fd 2dup epoll-read-task epoll-write-task ;
|
||||
|
||||
: handle-events ( mx n -- )
|
||||
[
|
||||
over epoll-mx-events epoll-event-nth handle-event
|
||||
] with each ;
|
||||
|
||||
M: epoll-mx wait-for-events ( ms mx -- )
|
||||
dup rot wait-event handle-events ;
|
||||
|
|
@ -0,0 +1,86 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
sequences assocs unix unix.kqueue unix.process math namespaces
|
||||
combinators threads vectors ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx events processes ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
#! constant...
|
||||
256 ; inline
|
||||
|
||||
: <kqueue-mx> ( -- mx )
|
||||
kqueue-mx construct-mx
|
||||
kqueue dup io-error over set-mx-fd
|
||||
H{ } clone over set-kqueue-mx-processes
|
||||
max-events "kevent" <c-array> over set-kqueue-mx-events ;
|
||||
|
||||
GENERIC: io-task-filter ( task -- n )
|
||||
|
||||
M: input-task io-task-filter drop EVFILT_READ ;
|
||||
|
||||
M: output-task io-task-filter drop EVFILT_WRITE ;
|
||||
|
||||
: make-kevent ( task flags -- event )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
over io-task-fd over set-kevent-ident
|
||||
swap io-task-filter over set-kevent-filter ;
|
||||
|
||||
: register-kevent ( kevent mx -- )
|
||||
mx-fd swap 1 f 0 f kevent io-error ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
over EV_ADD make-kevent over register-kevent
|
||||
delegate register-io-task ;
|
||||
|
||||
M: kqueue-mx unregister-io-task ( task mx -- )
|
||||
2dup delegate unregister-io-task
|
||||
swap EV_DELETE make-kevent swap register-kevent ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
|
||||
dup multiplexer-error ;
|
||||
|
||||
: kevent-read-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
|
||||
: kevent-write-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
|
||||
: kevent-proc-task ( mx pid -- )
|
||||
dup (wait-for-pid) spin kqueue-mx-processes delete-at* [
|
||||
[ schedule-thread-with ] with each
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: handle-kevent ( mx kevent -- )
|
||||
dup kevent-ident swap kevent-filter {
|
||||
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
|
||||
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
|
||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
|
||||
} cond ;
|
||||
|
||||
: handle-kevents ( mx n -- )
|
||||
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
||||
|
||||
M: kqueue-mx wait-for-events ( ms mx -- )
|
||||
swap make-timespec dupd wait-kevent handle-kevents ;
|
||||
|
||||
: make-proc-kevent ( pid -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-ident
|
||||
EV_ADD over set-kevent-flags
|
||||
EVFILT_PROC over set-kevent-filter
|
||||
NOTE_EXIT over set-kevent-fflags ;
|
||||
|
||||
: add-pid-task ( continuation pid mx -- )
|
||||
2dup kqueue-mx-processes at* [
|
||||
2nip push
|
||||
] [
|
||||
drop
|
||||
over make-proc-kevent over register-kevent
|
||||
>r >r 1vector r> r> kqueue-mx-processes set-at
|
||||
] if ;
|
||||
|
|
@ -1,14 +1,18 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.launcher io.unix.backend io.nonblocking
|
||||
sequences kernel namespaces math system alien.c-types
|
||||
debugger continuations arrays assocs combinators unix.process
|
||||
USING: io io.backend io.launcher io.unix.backend io.nonblocking
|
||||
sequences kernel namespaces math system alien.c-types debugger
|
||||
continuations arrays assocs combinators unix.process
|
||||
parser-combinators memoize promises strings ;
|
||||
IN: io.unix.launcher
|
||||
|
||||
! Search unix first
|
||||
USE: unix
|
||||
|
||||
HOOK: wait-for-process io-backend ( pid -- status )
|
||||
|
||||
M: unix-io wait-for-process ( pid -- status ) wait-for-pid ;
|
||||
|
||||
! Our command line parser. Supported syntax:
|
||||
! foo bar baz -- simple tokens
|
||||
! foo\ bar -- escaping the space
|
||||
|
|
@ -44,28 +48,26 @@ MEMO: 'arguments' ( -- parser )
|
|||
|
||||
: (spawn-process) ( -- )
|
||||
[
|
||||
pass-environment? [
|
||||
get-arguments get-environment assoc>env exec-args-with-env
|
||||
] [
|
||||
get-arguments exec-args-with-path
|
||||
] if io-error
|
||||
get-arguments
|
||||
pass-environment?
|
||||
[ get-environment assoc>env exec-args-with-env ]
|
||||
[ exec-args-with-path ] if
|
||||
io-error
|
||||
] [ error. :c flush ] recover 1 exit ;
|
||||
|
||||
: wait-for-process ( pid -- )
|
||||
0 <int> 0 waitpid drop ;
|
||||
|
||||
: spawn-process ( -- pid )
|
||||
[ (spawn-process) ] [ ] with-fork ;
|
||||
|
||||
: spawn-detached ( -- )
|
||||
[ spawn-process 0 exit ] [ ] with-fork wait-for-process ;
|
||||
[ spawn-process 0 exit ] [ ] with-fork
|
||||
wait-for-process drop ;
|
||||
|
||||
M: unix-io run-process* ( desc -- )
|
||||
[
|
||||
+detached+ get [
|
||||
spawn-detached
|
||||
] [
|
||||
spawn-process wait-for-process
|
||||
spawn-process wait-for-process drop
|
||||
] if
|
||||
] with-descriptor ;
|
||||
|
||||
|
|
@ -85,15 +87,16 @@ M: unix-io run-process* ( desc -- )
|
|||
-rot 2dup second close first close
|
||||
] with-fork first swap second rot ;
|
||||
|
||||
TUPLE: pipe-stream pid ;
|
||||
TUPLE: pipe-stream pid status ;
|
||||
|
||||
: <pipe-stream> ( in out pid -- stream )
|
||||
pipe-stream construct-boa
|
||||
f pipe-stream construct-boa
|
||||
-rot handle>duplex-stream over set-delegate ;
|
||||
|
||||
M: pipe-stream stream-close
|
||||
dup delegate stream-close
|
||||
pipe-stream-pid wait-for-process ;
|
||||
dup pipe-stream-pid wait-for-process
|
||||
swap set-pipe-stream-status ;
|
||||
|
||||
M: unix-io process-stream*
|
||||
[ spawn-process-stream <pipe-stream> ] with-descriptor ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.unix.linux
|
||||
USING: io.backend io.unix.backend io.unix.launcher io.unix.select
|
||||
namespaces kernel assocs unix.process ;
|
||||
|
||||
TUPLE: linux-io ;
|
||||
|
||||
INSTANCE: linux-io unix-io
|
||||
|
||||
M: linux-io init-io ( -- )
|
||||
<select-mx> mx set-global
|
||||
start-wait-loop ;
|
||||
|
||||
M: linux-io wait-for-process ( pid -- status )
|
||||
wait-for-pid ;
|
||||
|
||||
T{ linux-io } set-io-backend
|
||||
|
|
@ -0,0 +1,47 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
bit-arrays sequences assocs unix math namespaces structs ;
|
||||
IN: io.unix.select
|
||||
|
||||
TUPLE: select-mx read-fdset write-fdset ;
|
||||
|
||||
! Factor's bit-arrays are an array of bytes, OS X expects
|
||||
! FD_SET to be an array of cells, so we have to account for
|
||||
! byte order differences on big endian platforms
|
||||
: little-endian? 1 <int> *char 1 = ; foldable
|
||||
|
||||
: munge ( i -- i' )
|
||||
little-endian? [ BIN: 11000 bitxor ] unless ; inline
|
||||
|
||||
: <select-mx> ( -- mx )
|
||||
select-mx construct-mx
|
||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
|
||||
FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
|
||||
|
||||
: handle-fd ( fd task fdset mx -- )
|
||||
roll munge rot nth [ swap handle-io-task ] [ 2drop ] if ;
|
||||
|
||||
: handle-fdset ( tasks fdset mx -- )
|
||||
[ handle-fd ] 2curry assoc-each ;
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
dup clear-bits
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
{ mx-reads select-mx-read-fdset } get-slots ;
|
||||
|
||||
: write-fdset/tasks
|
||||
{ mx-writes select-mx-write-fdset } get-slots ;
|
||||
|
||||
: init-fdsets ( mx -- read write except )
|
||||
[ read-fdset/tasks tuck init-fdset ] keep
|
||||
write-fdset/tasks tuck init-fdset
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
swap >r FD_SETSIZE over init-fdsets r> make-timeval
|
||||
select multiplexer-error
|
||||
dup read-fdset/tasks pick handle-fdset
|
||||
dup write-fdset/tasks rot handle-fdset ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov, Ivan Tikhonov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
! We need to fiddle with the exact search order here, since
|
||||
|
|
@ -34,14 +34,12 @@ M: unix-io addrinfo-error ( n -- )
|
|||
TUPLE: connect-task ;
|
||||
|
||||
: <connect-task> ( port continuation -- task )
|
||||
connect-task <io-task> ;
|
||||
connect-task <output-task> ;
|
||||
|
||||
M: connect-task do-io-task
|
||||
io-task-port dup port-handle f 0 write
|
||||
0 < [ defer-error ] [ drop t ] if ;
|
||||
|
||||
M: connect-task task-container drop write-tasks get-global ;
|
||||
|
||||
: wait-to-connect ( port -- )
|
||||
[ <connect-task> add-io-task stop ] callcc0 drop ;
|
||||
|
||||
|
|
@ -68,9 +66,7 @@ USE: unix
|
|||
TUPLE: accept-task ;
|
||||
|
||||
: <accept-task> ( port continuation -- task )
|
||||
accept-task <io-task> ;
|
||||
|
||||
M: accept-task task-container drop read-tasks get ;
|
||||
accept-task <input-task> ;
|
||||
|
||||
: accept-sockaddr ( port -- fd sockaddr )
|
||||
dup port-handle swap server-port-addr sockaddr-type
|
||||
|
|
@ -101,7 +97,6 @@ M: unix-io <server> ( addrspec -- stream )
|
|||
[
|
||||
SOCK_STREAM server-fd
|
||||
dup 10 listen zero? [ dup close (io-error) ] unless
|
||||
f <port>
|
||||
] keep <server-port> ;
|
||||
|
||||
M: unix-io accept ( server -- client )
|
||||
|
|
@ -113,7 +108,7 @@ M: unix-io accept ( server -- client )
|
|||
|
||||
! Datagram sockets - UDP and Unix domain
|
||||
M: unix-io <datagram>
|
||||
[ SOCK_DGRAM server-fd f <port> ] keep <datagram-port> ;
|
||||
[ SOCK_DGRAM server-fd ] keep <datagram-port> ;
|
||||
|
||||
SYMBOL: receive-buffer
|
||||
|
||||
|
|
@ -139,7 +134,7 @@ packet-size <byte-array> receive-buffer set-global
|
|||
TUPLE: receive-task ;
|
||||
|
||||
: <receive-task> ( stream continuation -- task )
|
||||
receive-task <io-task> ;
|
||||
receive-task <input-task> ;
|
||||
|
||||
M: receive-task do-io-task
|
||||
io-task-port
|
||||
|
|
@ -152,8 +147,6 @@ M: receive-task do-io-task
|
|||
2drop defer-error
|
||||
] if ;
|
||||
|
||||
M: receive-task task-container drop read-tasks get ;
|
||||
|
||||
: wait-receive ( stream -- )
|
||||
[ <receive-task> add-io-task stop ] callcc0 drop ;
|
||||
|
||||
|
|
@ -170,7 +163,7 @@ M: unix-io receive ( datagram -- packet addrspec )
|
|||
TUPLE: send-task packet sockaddr len ;
|
||||
|
||||
: <send-task> ( packet sockaddr len stream continuation -- task )
|
||||
send-task <io-task> [
|
||||
send-task <output-task> [
|
||||
{
|
||||
set-send-task-packet
|
||||
set-send-task-sockaddr
|
||||
|
|
@ -185,8 +178,6 @@ M: send-task do-io-task
|
|||
[ send-task-len do-send ] keep
|
||||
swap 0 < [ io-task-port defer-error ] [ drop t ] if ;
|
||||
|
||||
M: send-task task-container drop write-tasks get ;
|
||||
|
||||
: wait-send ( packet sockaddr len stream -- )
|
||||
[ <send-task> add-io-task stop ] callcc0 2drop 2drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,10 +3,8 @@ io.unix.launcher io.unix.mmap io.backend combinators namespaces
|
|||
system vocabs.loader ;
|
||||
|
||||
{
|
||||
! kqueue is a work in progress
|
||||
! { [ macosx? ] [ "io.unix.backend.kqueue" ] }
|
||||
! { [ bsd? ] [ "io.unix.backend.kqueue" ] }
|
||||
{ [ unix? ] [ "io.unix.backend.select" ] }
|
||||
{ [ bsd? ] [ "io.unix.bsd" ] }
|
||||
{ [ macosx? ] [ "io.unix.bsd" ] }
|
||||
{ [ linux? ] [ "io.unix.linux" ] }
|
||||
{ [ solaris? ] [ "io.unix.solaris" ] }
|
||||
} cond require
|
||||
|
||||
T{ unix-io } io-backend set-global
|
||||
|
|
|
|||
|
|
@ -3,4 +3,4 @@ io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
|
|||
namespaces io.windows.mmap ;
|
||||
IN: io.windows.ce
|
||||
|
||||
T{ windows-ce-io } io-backend set-global
|
||||
T{ windows-ce-io } set-io-backend
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ M: windows-ce-io <server> ( addrspec -- duplex-stream )
|
|||
[
|
||||
windows.winsock:SOCK_STREAM server-fd
|
||||
dup listen-on-socket
|
||||
<win32-socket> f <port>
|
||||
<win32-socket>
|
||||
] keep <server-port> ;
|
||||
|
||||
M: windows-ce-io accept ( server -- client )
|
||||
|
|
@ -58,7 +58,7 @@ M: windows-ce-io accept ( server -- client )
|
|||
|
||||
M: windows-ce-io <datagram> ( addrspec -- datagram )
|
||||
[
|
||||
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
|
||||
windows.winsock:SOCK_DGRAM server-fd <win32-socket>
|
||||
] keep <datagram-port> ;
|
||||
|
||||
: packet-size 65536 ; inline
|
||||
|
|
|
|||
|
|
@ -9,4 +9,4 @@ USE: io.windows.mmap
|
|||
USE: io.backend
|
||||
USE: namespaces
|
||||
|
||||
T{ windows-nt-io } io-backend set-global
|
||||
T{ windows-nt-io } set-io-backend
|
||||
|
|
|
|||
|
|
@ -149,7 +149,7 @@ M: windows-nt-io <server> ( addrspec -- server )
|
|||
[
|
||||
SOCK_STREAM server-fd dup listen-on-socket
|
||||
dup add-completion
|
||||
<win32-socket> f <port>
|
||||
<win32-socket>
|
||||
] keep <server-port>
|
||||
] with-destructors ;
|
||||
|
||||
|
|
@ -158,7 +158,7 @@ M: windows-nt-io <datagram> ( addrspec -- datagram )
|
|||
[
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
<win32-socket> f <port>
|
||||
<win32-socket>
|
||||
] keep <datagram-port>
|
||||
] with-destructors ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: unix.linux.epoll
|
||||
USING: alien.syntax math ;
|
||||
|
||||
FUNCTION: int epoll_create ( int size ) ;
|
||||
|
||||
FUNCTION: int epoll_ctl ( int epfd, int op, int fd, epoll_event* event ) ;
|
||||
|
||||
C-STRUCT: epoll-event
|
||||
{ "uint" "events" }
|
||||
{ "uint" "fd" }
|
||||
{ "uint" "padding" } ;
|
||||
|
||||
FUNCTION: int epoll_wait ( int epfd, epoll_event* events, int maxevents, int timeout ) ;
|
||||
|
||||
: EPOLL_CTL_ADD 1 ; inline ! Add a file decriptor to the interface.
|
||||
: EPOLL_CTL_DEL 2 ; inline ! Remove a file decriptor from the interface.
|
||||
: EPOLL_CTL_MOD 3 ; inline ! Change file decriptor epoll_event structure.
|
||||
|
||||
: EPOLLIN HEX: 001 ; inline
|
||||
: EPOLLPRI HEX: 002 ; inline
|
||||
: EPOLLOUT HEX: 004 ; inline
|
||||
: EPOLLRDNORM HEX: 040 ; inline
|
||||
: EPOLLRDBAND HEX: 080 ; inline
|
||||
: EPOLLWRNORM HEX: 100 ; inline
|
||||
: EPOLLWRBAND HEX: 200 ; inline
|
||||
: EPOLLMSG HEX: 400 ; inline
|
||||
: EPOLLERR HEX: 008 ; inline
|
||||
: EPOLLHUP HEX: 010 ; inline
|
||||
: EPOLLET 31 2^ ; inline
|
||||
|
|
@ -1,53 +1,55 @@
|
|||
|
||||
USING: kernel alien.c-types sequences math unix combinators.cleave ;
|
||||
USING: kernel alien.c-types sequences math unix
|
||||
combinators.cleave vectors kernel namespaces continuations
|
||||
threads assocs vectors ;
|
||||
|
||||
IN: unix.process
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
! Low-level Unix process launching utilities. These are used
|
||||
! to implement io.launcher on Unix. User code should use
|
||||
! io.launcher instead.
|
||||
|
||||
: >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: exec ( pathname argv -- int )
|
||||
[ malloc-char-string ] [ >argv ] bi* execv ;
|
||||
[ malloc-char-string ] [ >argv ] bi* execv ;
|
||||
|
||||
: exec-with-path ( filename argv -- int )
|
||||
[ malloc-char-string ] [ >argv ] bi* execvp ;
|
||||
[ malloc-char-string ] [ >argv ] bi* execvp ;
|
||||
|
||||
: exec-with-env ( filename argv envp -- int )
|
||||
[ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
|
||||
[ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: exec-args ( seq -- int )
|
||||
[ first ] [ ] bi exec ;
|
||||
|
||||
: exec-args ( seq -- int ) [ first ] [ ] bi exec ;
|
||||
: exec-args-with-path ( seq -- int ) [ first ] [ ] bi exec-with-path ;
|
||||
: exec-args-with-path ( seq -- int )
|
||||
[ first ] [ ] bi exec-with-path ;
|
||||
|
||||
: exec-args-with-env ( seq seq -- int ) >r [ first ] [ ] bi r> exec-with-env ;
|
||||
: exec-args-with-env ( seq seq -- int )
|
||||
>r [ first ] [ ] bi r> exec-with-env ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
: with-fork ( child parent -- )
|
||||
fork dup zero? -roll swap curry if ; inline
|
||||
|
||||
: with-fork ( child parent -- ) fork dup zero? -roll swap curry if ; inline
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: kernel alien.c-types namespaces continuations threads assocs unix
|
||||
combinators.cleave ;
|
||||
! Lame polling strategy for getting process exit codes. On
|
||||
! BSD, we use kqueue which is more efficient.
|
||||
|
||||
SYMBOL: pid-wait
|
||||
|
||||
! KEY | VALUE
|
||||
! -----------
|
||||
! pid | continuation
|
||||
: (wait-for-pid) ( pid -- status )
|
||||
0 <int> [ 0 waitpid drop ] keep *int ;
|
||||
|
||||
: init-pid-wait ( -- ) H{ } clone pid-wait set-global ;
|
||||
|
||||
: wait-for-pid ( pid -- status ) [ pid-wait get set-at stop ] curry callcc1 ;
|
||||
: wait-for-pid ( pid -- status )
|
||||
[ pid-wait get-global [ ?push ] change-at stop ] curry
|
||||
callcc1 ;
|
||||
|
||||
: wait-loop ( -- )
|
||||
-1 0 <int> tuck WNOHANG waitpid ! &status return
|
||||
[ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
|
||||
dup [ schedule-thread-with ] [ 2drop ] if
|
||||
250 sleep wait-loop ;
|
||||
-1 0 <int> tuck WNOHANG waitpid ! &status return
|
||||
[ *int ] [ pid-wait get delete-at* drop ] bi* ! status ?
|
||||
[ schedule-thread-with ] with each
|
||||
250 sleep
|
||||
wait-loop ;
|
||||
|
||||
: start-wait-loop ( -- ) init-pid-wait [ wait-loop ] in-thread ;
|
||||
: start-wait-loop ( -- )
|
||||
H{ } clone pid-wait set-global
|
||||
[ wait-loop ] in-thread ;
|
||||
Loading…
Reference in New Issue