! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io-internals
-USING: alien errors generic hashtables kernel lists math
-sequences streams strings threads unix-internals vectors ;
+USING: alien assembler errors generic hashtables kernel
+kernel-internals lists math sequences streams strings threads
+unix-internals vectors ;
! We want namespaces::bind to shadow the bind system call from
! unix-internals
USING: namespaces ;
+! This will go elsewhere soon
+: byte-bit ( n alien -- byte bit )
+ over -3 shift alien-unsigned-1 swap 7 bitand ;
+
+: <bit-array> ( n -- array )
+ cell / ceiling <byte-array> ;
+
+: bit-nth ( n alien -- ? )
+ byte-bit 1 swap shift bitand 0 > ;
+
+: set-bit ( ? byte bit -- byte )
+ 1 swap shift rot [ bitor ] [ bitnot bitand ] ifte ;
+
+: set-bit-nth ( ? n alien -- )
+ [ byte-bit set-bit ] 2keep
+ swap -3 shift set-alien-unsigned-1 ;
+
+! Global variables
+SYMBOL: read-fdset
+SYMBOL: read-tasks
+SYMBOL: write-fdset
+SYMBOL: write-tasks
+
! Some general stuff
: file-mode OCT: 0600 ;
-: (io-error) errno strerror throw ;
+: (io-error) err_no strerror throw ;
: check-null ( n -- ) 0 = [ (io-error) ] when ;
: pending-error ( reader -- ) port-error throw ;
: postpone-error ( reader -- )
- errno strerror swap set-port-error ;
+ err_no strerror swap set-port-error ;
! Associates a port with a list of continuations waiting on the
! port to finish I/O
! Multiplexer
GENERIC: do-io-task ( task -- ? )
-GENERIC: io-task-events ( task -- events )
-
-! A hashtable in the global namespace mapping fd numbers to
-! io-tasks. This is not a vector, since we need a quick way
-! to find the number of elements, and a hashtable gives us
-! this with the hash-size call.
-SYMBOL: io-tasks
-
-: io-task ( pollfd -- io-task ) pollfd-fd io-tasks get hash ;
+GENERIC: task-container ( task -- vector )
: io-task-fd io-task-port port-handle ;
: add-io-task ( callback task -- )
[ >r unit r> set-io-task-callbacks ] keep
- dup io-task-fd io-tasks get 2dup hash [
+ dup io-task-fd over task-container 2dup hash [
"Cannot perform multiple I/O ops on the same port" throw
] when set-hash ;
: remove-io-task ( task -- )
- io-task-fd io-tasks get remove-hash ;
+ dup io-task-fd swap task-container remove-hash ;
: pop-callback ( task -- callback )
dup io-task-callbacks uncons dup [
drop swap remove-io-task
] ifte ;
-: handle-fd ( pollfd -- quot )
- io-task dup do-io-task [
- dup io-task-port touch-port pop-callback
+: handle-fd ( task -- )
+ dup do-io-task [
+ dup io-task-port touch-port pop-callback [ call ] when*
] [
- drop f
+ drop
] ifte ;
: timeout? ( port -- ? )
port-cutoff dup 0 = not swap millis < and ;
-: handle-fd? ( pollfd -- ? )
- dup pollfd-revents 0 = not >r
- io-task io-task-port timeout? r> or ;
+: handle-fd? ( fdset task -- ? )
+ dup io-task-port timeout?
+ [ 2drop t ] [ io-task-fd swap bit-nth ] ifte ;
-: do-io-tasks ( pollfds n -- )
+: handle-fdset ( fdset tasks -- )
[
- dup pick pollfd-nth dup handle-fd? [
- handle-fd [ call ] when*
- ] [
- drop
- ] ifte
- ] repeat drop ;
-
-: io-task# io-tasks get hash-size ;
+ cdr tuck handle-fd? [ handle-fd ] [ drop ] ifte
+ ] hash-each-with ;
-: io-task-list io-tasks get hash-values ;
+: init-fdset ( fdset tasks -- )
+ [ car t swap rot set-bit-nth ] hash-each-with ;
-: init-pollfd ( task pollfd -- )
- over io-task-fd over set-pollfd-fd
- swap io-task-events swap set-pollfd-events ;
-
-: make-pollfds ( -- pollfds n )
- io-task# [
- <pollfd-array> 0 io-task-list [
- pick pick swap pollfd-nth init-pollfd 1 +
- ] each drop
- ] keep ;
+: init-fdsets ( -- read write except )
+ read-fdset get [ read-tasks get init-fdset ] keep
+ write-fdset get [ write-tasks get init-fdset ] keep
+ NULL ;
: io-multiplex ( timeout -- )
- >r make-pollfds 2dup r> poll drop do-io-tasks ;
-
-: pending-io? ( -- ? )
- #! Output if there are waiting I/O requests.
- io-tasks get hash-size 0 > ;
+ >r FD_SETSIZE init-fdsets r> make-timeval select drop
+ read-fdset get read-tasks get handle-fdset
+ write-fdset get write-tasks get handle-fdset ;
! Readers
read-line-step
] ifte ;
-M: read-line-task io-task-events ( task -- events )
- drop POLLIN ;
+M: read-line-task task-container drop read-tasks get ;
: wait-to-read-line ( port -- )
dup can-read-line? [
read-step
] ifte ;
-M: read-task io-task-events ( task -- events )
- drop POLLIN ;
+M: read-task task-container drop read-tasks get ;
: wait-to-read ( count port -- )
2dup can-read-count? [
>port< write-step f
] ifte ;
-M: write-task io-task-events ( task -- events )
- drop POLLOUT ;
+M: write-task task-container drop write-tasks get ;
: write-fin ( str writer -- )
dup pending-error >buffer ;
: add-write-io-task ( callback task -- )
- dup io-task-fd io-tasks get hash [
+ dup io-task-fd write-tasks get hash [
dup write-task? [
- [
- nip io-task-callbacks cons
- ] keep set-io-task-callbacks
+ [ nip io-task-callbacks cons ] keep
+ set-io-task-callbacks
] [
drop add-io-task
] ifte
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
- <namespace> io-tasks set
+ <namespace> read-tasks set
+ FD_SETSIZE <bit-array> read-fdset set
+ <namespace> write-tasks set
+ FD_SETSIZE <bit-array> write-fdset set
0 1 t <fd-stream> stdio set
] bind
[ idle-io-task ] in-thread ;
: EINPROGRESS 36 ;
-: errno ( -- n )
- "int" f "factor_errno" [ ] alien-invoke ;
+LIBRARY: factor
+FUNCTION: int err_no ( ) ;
-: strerror ( n -- str )
- "char*" "libc" "strerror" [ "int" ] alien-invoke ;
-
-: open ( path flags prot -- fd )
- "int" "libc" "open" [ "char*" "int" "int" ] alien-invoke ;
-
-: close ( fd -- )
- "void" "libc" "close" [ "int" ] alien-invoke ;
-
-: fcntl ( fd cmd arg -- n )
- "int" "libc" "fcntl" [ "int" "int" "int" ] alien-invoke ;
-
-: read ( fd buf nbytes -- n )
- "ssize_t" "libc" "read" [ "int" "ulong" "size_t" ] alien-invoke ;
-
-: write ( fd buf nbytes -- n )
- "ssize_t" "libc" "write" [ "int" "ulong" "size_t" ] alien-invoke ;
-
-BEGIN-STRUCT: pollfd
- FIELD: int fd
- FIELD: short events
- FIELD: short revents
-END-STRUCT
-
-: poll ( pollfds nfds timeout -- n )
- "int" "libc" "poll" [ "pollfd*" "uint" "int" ] alien-invoke ;
+LIBRARY: libc
+FUNCTION: char* strerror ( int ) ;
+FUNCTION: int open ( char* path, int flags, int prot ) ;
+FUNCTION: void close ( int fd ) ;
+FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
+FUNCTION: ssize_t read ( int fd, ulong buf, size_t nbytes ) ;
+FUNCTION: ssize_t write ( int fd, ulong buf, size_t nbytes ) ;
BEGIN-STRUCT: timeval
FIELD: long sec
FIELD: long usec
END-STRUCT
-: select ( nfds readfds writefds exceptfds timeout -- n )
- "int" "libc" "select" [ "int" "void*" "void*" "void*" "timeval*" ] alien-invoke ;
+: make-timeval ( ms -- timeval )
+ 1000 /mod 1000 *
+ <timeval>
+ [ set-timeval-usec ] keep
+ [ set-timeval-sec ] keep ;
+
+FUNCTION: int select ( int nfds, void* readfds, void* writefds, void* exceptfds, timeval* timeout ) ;
BEGIN-STRUCT: hostent
FIELD: char* name
: PF_INET AF_INET ;
: SOCK_STREAM 1 ;
-: socket ( domain type protocol -- n )
- "int" "libc" "socket" [ "int" "int" "int" ] alien-invoke ;
-
-: setsockopt ( s level optname optval optlen -- n )
- "int" "libc" "setsockopt" [ "int" "int" "int" "void*" "socklen_t" ] alien-invoke ;
-
-: connect ( s name namelen -- n )
- "int" "libc" "connect" [ "int" "sockaddr-in*" "socklen_t" ] alien-invoke ;
-
-: bind ( s sockaddr socklen -- n )
- "int" "libc" "bind" [ "int" "sockaddr-in*" "socklen_t" ] alien-invoke ;
-
-: listen ( s backlog -- n )
- "int" "libc" "listen" [ "int" "int" ] alien-invoke ;
-
-: accept ( s sockaddr socklen -- n )
- "int" "libc" "accept" [ "int" "sockaddr-in*" "void*" ] alien-invoke ;
-
-: htonl ( n -- n )
- "uint" "libc" "htonl" [ "uint" ] alien-invoke ;
-
-: htons ( n -- n )
- "ushort" "libc" "htons" [ "ushort" ] alien-invoke ;
-
-: ntohl ( n -- n )
- "uint" "libc" "ntohl" [ "uint" ] alien-invoke ;
-
-: ntohs ( n -- n )
- "ushort" "libc" "ntohs" [ "ushort" ] alien-invoke ;
+FUNCTION: int socket ( int domain, int type, int protocol ) ;
+FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_t optlen ) ;
+FUNCTION: int connect ( int s, sockaddr-in* name, socklen_t namelen ) ;
+FUNCTION: int bind ( int s, sockaddr-in* name, socklen_t namelen ) ;
+FUNCTION: int listen ( int s, int backlog ) ;
+FUNCTION: int accept ( int s, sockaddr-in* sockaddr, socklen_t* socklen ) ;
+FUNCTION: uint htonl ( uint n ) ;
+FUNCTION: ushort htons ( ushort n ) ;
+FUNCTION: uint ntohl ( uint n ) ;
+FUNCTION: ushort ntohs ( ushort n ) ;
projects / factor.git / commitdiff