[MLton-commit] r5497
Matthew Fluet
fluet at mlton.org
Mon Apr 9 10:02:28 PDT 2007
Use select system call to implement Socket.select
----------------------------------------------------------------------
U mlton/trunk/basis-library/net/socket.sml
U mlton/trunk/basis-library/primitive/basis-ffi.sml
A mlton/trunk/runtime/basis/Net/Socket/select.c
U mlton/trunk/runtime/basis-ffi.h
U mlton/trunk/runtime/gen/basis-ffi.def
U mlton/trunk/runtime/gen/basis-ffi.h
U mlton/trunk/runtime/gen/basis-ffi.sml
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/net/socket.sml
===================================================================
--- mlton/trunk/basis-library/net/socket.sml 2007-04-09 15:08:44 UTC (rev 5496)
+++ mlton/trunk/basis-library/net/socket.sml 2007-04-09 17:02:27 UTC (rev 5497)
@@ -445,51 +445,70 @@
in Syscall.simple (fn () => Prim.shutdown (s, m))
end
-type sock_desc = OS.IO.iodesc
+type sock_desc = FileSys.file_desc
-fun sockDesc sock = FileSys.fdToIOD (sockToFD sock)
+fun sockDesc sock = sockToFD sock
-fun sameDesc (desc1, desc2) =
- OS.IO.compare (desc1, desc2) = EQUAL
+fun sameDesc (desc1, desc2) = desc1 = desc2
fun select {rds: sock_desc list,
wrs: sock_desc list,
exs: sock_desc list,
timeout: Time.time option} =
let
- fun mk poll (sd,pds) =
- let
- val pd = Option.valOf (OS.IO.pollDesc sd)
- val pd = poll pd
- in
- pd::pds
- end
- val pds =
- (List.foldr (mk OS.IO.pollIn)
- (List.foldr (mk OS.IO.pollOut)
- (List.foldr (mk OS.IO.pollPri)
- [] exs) wrs) rds)
- val pis = OS.IO.poll (pds, timeout)
- val {rds, wrs, exs} =
- List.foldr
- (fn (pi,{rds,wrs,exs}) =>
- let
- fun mk (is,l) =
- if is pi
- then (OS.IO.pollToIODesc (OS.IO.infoToPollDesc pi))::l
- else l
- in
- {rds = mk (OS.IO.isIn, rds),
- wrs = mk (OS.IO.isOut, wrs),
- exs = mk (OS.IO.isPri, exs)}
- end)
- {rds = [], wrs = [], exs = []}
- pis
+ local
+ fun mk l =
+ let
+ val vec = Vector.fromList l
+ val arr = Array.array (Vector.length vec, 0)
+ in
+ (vec, arr)
+ end
+ in
+ val (read_vec, read_arr) = mk rds
+ val (write_vec, write_arr) = mk wrs
+ val (except_vec, except_arr) = mk exs
+ end
+ val setTimeout =
+ case timeout of
+ NONE => Prim.setTimeoutNull
+ | SOME t => let
+ val q = LargeInt.quot (Time.toMicroseconds t, 1000000)
+ val q = C_Time.fromLargeInt q
+ val r = LargeInt.rem (Time.toMicroseconds t, 1000000)
+ val r = C_SUSeconds.fromLargeInt r
+ in
+ fn () => Prim.setTimeout (q, r)
+ end
+ val res =
+ Syscall.simpleResult
+ (fn () =>
+ (setTimeout ()
+ ; Prim.select (read_vec, write_vec, except_vec,
+ read_arr, write_arr, except_arr)))
+ val (rds, wrs, exs) =
+ if res = 0
+ then ([],[],[])
+ else
+ let
+ fun mk (l, arr) =
+ (List.rev o #1)
+ (List.foldl (fn (sd, (l, i)) =>
+ (if Array.sub (arr, i) <> 0 then sd::l else l, i + 1))
+ ([],0)
+ l)
+ in
+ (mk (rds, read_arr),
+ mk (wrs, write_arr),
+ mk (exs, except_arr))
+ end
in
- {rds = rds, wrs = wrs, exs = exs}
+ {rds = rds,
+ wrs = wrs,
+ exs = exs}
end
-val ioDesc = sockDesc
+val ioDesc = FileSys.fdToIOD o sockDesc
type out_flags = {don't_route: bool, oob: bool}
Modified: mlton/trunk/basis-library/primitive/basis-ffi.sml
===================================================================
--- mlton/trunk/basis-library/primitive/basis-ffi.sml 2007-04-09 15:08:44 UTC (rev 5496)
+++ mlton/trunk/basis-library/primitive/basis-ffi.sml 2007-04-09 17:02:27 UTC (rev 5497)
@@ -1123,6 +1123,8 @@
val socket = _import "Socket_GenericSock_socket" : C_Int.t * C_Int.t * C_Int.t -> (C_Int.t) C_Errno.t;
val socketPair = _import "Socket_GenericSock_socketPair" : C_Int.t * C_Int.t * C_Int.t * (C_Int.t) array -> (C_Int.t) C_Errno.t;
end
+val getTimeout_sec = _import "Socket_getTimeout_sec" : unit -> C_Time.t;
+val getTimeout_usec = _import "Socket_getTimeout_usec" : unit -> C_SUSeconds.t;
structure INetSock =
struct
structure Ctl =
@@ -1146,10 +1148,13 @@
val MSG_WAITALL = _const "Socket_MSG_WAITALL" : C_Int.t;
val recv = _import "Socket_recv" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t;
val recvFrom = _import "Socket_recvFrom" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t * (Word8.t) array * (C_Socklen.t) ref -> (C_SSize.t) C_Errno.t;
+val select = _import "Socket_select" : (C_Fd.t) vector * (C_Fd.t) vector * (C_Fd.t) vector * (C_Int.t) array * (C_Int.t) array * (C_Int.t) array -> (C_Int.t) C_Errno.t;
val sendArr = _import "Socket_sendArr" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t;
val sendArrTo = _import "Socket_sendArrTo" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t * (Word8.t) vector * C_Socklen.t -> (C_SSize.t) C_Errno.t;
val sendVec = _import "Socket_sendVec" : C_Sock.t * (Word8.t) vector * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t;
val sendVecTo = _import "Socket_sendVecTo" : C_Sock.t * (Word8.t) vector * C_Int.t * C_Size.t * C_Int.t * (Word8.t) vector * C_Socklen.t -> (C_SSize.t) C_Errno.t;
+val setTimeout = _import "Socket_setTimeout" : C_Time.t * C_SUSeconds.t -> unit;
+val setTimeoutNull = _import "Socket_setTimeoutNull" : unit -> unit;
val SHUT_RD = _const "Socket_SHUT_RD" : C_Int.t;
val SHUT_RDWR = _const "Socket_SHUT_RDWR" : C_Int.t;
val SHUT_WR = _const "Socket_SHUT_WR" : C_Int.t;
Added: mlton/trunk/runtime/basis/Net/Socket/select.c
===================================================================
--- mlton/trunk/runtime/basis/Net/Socket/select.c 2007-04-09 15:08:44 UTC (rev 5496)
+++ mlton/trunk/runtime/basis/Net/Socket/select.c 2007-04-09 17:02:27 UTC (rev 5497)
@@ -0,0 +1,93 @@
+#include "platform.h"
+
+static struct timeval timeout;
+static struct timeval *timeoutPtr;
+
+void Socket_setTimeout (C_Time_t sec, C_SUSeconds_t usec) {
+ timeout.tv_sec = sec;
+ timeout.tv_usec = usec;
+ timeoutPtr = &timeout;
+}
+C_Time_t Socket_getTimeout_sec (void) {
+ return timeout.tv_sec;
+}
+C_SUSeconds_t Socket_getTimeout_usec (void) {
+ return timeout.tv_usec;
+}
+void Socket_setTimeoutNull (void) {
+ timeoutPtr = NULL;
+}
+
+C_Errno_t(C_Int_t) Socket_select (Vector(C_Fd_t) read_vec,
+ Vector(C_Fd_t) write_vec,
+ Vector(C_Fd_t) except_vec,
+ Array(C_Int) read_arr,
+ Array(C_Int) write_arr,
+ Array(C_Int) except_arr) {
+ uintmax_t read_len, write_len, except_len;
+ fd_set read_fd_set, write_fd_set, except_fd_set;
+ fd_set *read_fds, *write_fds, *except_fds;
+ int res;
+
+ read_len = GC_getArrayLength((pointer)read_vec);
+ if (read_len > 0) {
+ read_fds = &read_fd_set;
+ FD_ZERO(read_fds);
+ for (unsigned int i = 0; i < read_len; i++) {
+ int fd = ((int *)read_vec)[i];
+ FD_SET (fd, read_fds);
+ }
+ } else {
+ read_fds = NULL;
+ }
+ write_len = GC_getArrayLength((pointer)write_vec);
+ if (write_len > 0) {
+ write_fds = &write_fd_set;
+ FD_ZERO(write_fds);
+ for (unsigned int i = 0; i < write_len; i++) {
+ int fd = ((int *)write_vec)[i];
+ FD_SET (fd, write_fds);
+ }
+ } else {
+ write_fds = NULL;
+ }
+ except_len = GC_getArrayLength((pointer)except_vec);
+ if (except_len > 0) {
+ except_fds = &except_fd_set;
+ FD_ZERO(except_fds);
+ for (unsigned int i = 0; i < except_len; i++) {
+ int fd = ((int *)except_vec)[i];
+ FD_SET (fd, except_fds);
+ }
+ } else {
+ except_fds = NULL;
+ }
+ res = select(FD_SETSIZE, read_fds, write_fds, except_fds, timeoutPtr);
+ if (res == -1)
+ return res;
+ if (read_len > 0) {
+ for (unsigned int i = 0; i < read_len; i++) {
+ int fd = ((int *)read_vec)[i];
+ if (FD_ISSET (fd, read_fds)) {
+ ((int *)read_arr)[i] = 1;
+ }
+ }
+ }
+ if (write_len > 0) {
+ for (unsigned int i = 0; i < write_len; i++) {
+ int fd = ((int *)write_vec)[i];
+ if (FD_ISSET (fd, write_fds)) {
+ ((int *)write_arr)[i] = 1;
+ }
+ }
+ }
+ if (except_len > 0) {
+ for (unsigned int i = 0; i < except_len; i++) {
+ int fd = ((int *)except_vec)[i];
+ if (FD_ISSET (fd, except_fds)) {
+ ((int *)except_arr)[i] = 1;
+ }
+ }
+ }
+ return res;
+}
Modified: mlton/trunk/runtime/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/basis-ffi.h 2007-04-09 15:08:44 UTC (rev 5496)
+++ mlton/trunk/runtime/basis-ffi.h 2007-04-09 17:02:27 UTC (rev 5497)
@@ -923,6 +923,8 @@
C_Int_t Socket_familyOfAddr(Vector(Word8_t));
C_Errno_t(C_Int_t) Socket_GenericSock_socket(C_Int_t,C_Int_t,C_Int_t);
C_Errno_t(C_Int_t) Socket_GenericSock_socketPair(C_Int_t,C_Int_t,C_Int_t,Array(C_Int_t));
+C_Time_t Socket_getTimeout_sec(void);
+C_SUSeconds_t Socket_getTimeout_usec(void);
extern const C_Int_t Socket_INetSock_Ctl_IPPROTO_TCP;
extern const C_Int_t Socket_INetSock_Ctl_TCP_NODELAY;
void Socket_INetSock_fromAddr(Vector(Word8_t));
@@ -940,10 +942,13 @@
extern const C_Int_t Socket_MSG_WAITALL;
C_Errno_t(C_SSize_t) Socket_recv(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t);
C_Errno_t(C_SSize_t) Socket_recvFrom(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t,Array(Word8_t),Ref(C_Socklen_t));
+C_Errno_t(C_Int_t) Socket_select(Vector(C_Fd_t),Vector(C_Fd_t),Vector(C_Fd_t),Array(C_Int_t),Array(C_Int_t),Array(C_Int_t));
C_Errno_t(C_SSize_t) Socket_sendArr(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t);
C_Errno_t(C_SSize_t) Socket_sendArrTo(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t,Vector(Word8_t),C_Socklen_t);
C_Errno_t(C_SSize_t) Socket_sendVec(C_Sock_t,Vector(Word8_t),C_Int_t,C_Size_t,C_Int_t);
C_Errno_t(C_SSize_t) Socket_sendVecTo(C_Sock_t,Vector(Word8_t),C_Int_t,C_Size_t,C_Int_t,Vector(Word8_t),C_Socklen_t);
+void Socket_setTimeout(C_Time_t,C_SUSeconds_t);
+void Socket_setTimeoutNull(void);
extern const C_Int_t Socket_SHUT_RD;
extern const C_Int_t Socket_SHUT_RDWR;
extern const C_Int_t Socket_SHUT_WR;
Modified: mlton/trunk/runtime/gen/basis-ffi.def
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.def 2007-04-09 15:08:44 UTC (rev 5496)
+++ mlton/trunk/runtime/gen/basis-ffi.def 2007-04-09 17:02:27 UTC (rev 5497)
@@ -835,13 +835,18 @@
Socket.close = _import : C_Sock.t -> C_Int.t C_Errno.t
Socket.connect = _import : C_Sock.t * Word8.t vector * C_Socklen.t -> C_Int.t C_Errno.t
Socket.familyOfAddr = _import : Word8.t vector -> C_Int.t
+Socket.getTimeout_sec = _import : unit -> C_Time.t
+Socket.getTimeout_usec = _import : unit -> C_SUSeconds.t
Socket.listen = _import : C_Sock.t * C_Int.t -> C_Int.t C_Errno.t
Socket.recv = _import : C_Sock.t * Word8.t array * C_Int.t * C_Size.t * C_Int.t -> C_SSize.t C_Errno.t
Socket.recvFrom = _import : C_Sock.t * Word8.t array * C_Int.t * C_Size.t * C_Int.t * Word8.t array * C_Socklen.t ref -> C_SSize.t C_Errno.t
+Socket.select = _import : C_Fd.t vector * C_Fd.t vector * C_Fd.t vector * C_Int.t array * C_Int.t array * C_Int.t array -> C_Int.t C_Errno.t
Socket.sendArr = _import : C_Sock.t * Word8.t array * C_Int.t * C_Size.t * C_Int.t -> C_SSize.t C_Errno.t
Socket.sendArrTo = _import : C_Sock.t * Word8.t array * C_Int.t * C_Size.t * C_Int.t * Word8.t vector * C_Socklen.t -> C_SSize.t C_Errno.t
Socket.sendVec = _import : C_Sock.t * Word8.t vector * C_Int.t * C_Size.t * C_Int.t -> C_SSize.t C_Errno.t
Socket.sendVecTo = _import : C_Sock.t * Word8.t vector * C_Int.t * C_Size.t * C_Int.t * Word8.t vector * C_Socklen.t -> C_SSize.t C_Errno.t
+Socket.setTimeout = _import : C_Time.t * C_SUSeconds.t -> unit
+Socket.setTimeoutNull = _import : unit -> unit
Socket.shutdown = _import : C_Sock.t * C_Int.t -> C_Int.t C_Errno.t
Socket.sockAddrStorageLen = _const : C_Size.t
Stdio.print = _import : String8.t -> unit
Modified: mlton/trunk/runtime/gen/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.h 2007-04-09 15:08:44 UTC (rev 5496)
+++ mlton/trunk/runtime/gen/basis-ffi.h 2007-04-09 17:02:27 UTC (rev 5497)
@@ -923,6 +923,8 @@
C_Int_t Socket_familyOfAddr(Vector(Word8_t));
C_Errno_t(C_Int_t) Socket_GenericSock_socket(C_Int_t,C_Int_t,C_Int_t);
C_Errno_t(C_Int_t) Socket_GenericSock_socketPair(C_Int_t,C_Int_t,C_Int_t,Array(C_Int_t));
+C_Time_t Socket_getTimeout_sec(void);
+C_SUSeconds_t Socket_getTimeout_usec(void);
extern const C_Int_t Socket_INetSock_Ctl_IPPROTO_TCP;
extern const C_Int_t Socket_INetSock_Ctl_TCP_NODELAY;
void Socket_INetSock_fromAddr(Vector(Word8_t));
@@ -940,10 +942,13 @@
extern const C_Int_t Socket_MSG_WAITALL;
C_Errno_t(C_SSize_t) Socket_recv(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t);
C_Errno_t(C_SSize_t) Socket_recvFrom(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t,Array(Word8_t),Ref(C_Socklen_t));
+C_Errno_t(C_Int_t) Socket_select(Vector(C_Fd_t),Vector(C_Fd_t),Vector(C_Fd_t),Array(C_Int_t),Array(C_Int_t),Array(C_Int_t));
C_Errno_t(C_SSize_t) Socket_sendArr(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t);
C_Errno_t(C_SSize_t) Socket_sendArrTo(C_Sock_t,Array(Word8_t),C_Int_t,C_Size_t,C_Int_t,Vector(Word8_t),C_Socklen_t);
C_Errno_t(C_SSize_t) Socket_sendVec(C_Sock_t,Vector(Word8_t),C_Int_t,C_Size_t,C_Int_t);
C_Errno_t(C_SSize_t) Socket_sendVecTo(C_Sock_t,Vector(Word8_t),C_Int_t,C_Size_t,C_Int_t,Vector(Word8_t),C_Socklen_t);
+void Socket_setTimeout(C_Time_t,C_SUSeconds_t);
+void Socket_setTimeoutNull(void);
extern const C_Int_t Socket_SHUT_RD;
extern const C_Int_t Socket_SHUT_RDWR;
extern const C_Int_t Socket_SHUT_WR;
Modified: mlton/trunk/runtime/gen/basis-ffi.sml
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.sml 2007-04-09 15:08:44 UTC (rev 5496)
+++ mlton/trunk/runtime/gen/basis-ffi.sml 2007-04-09 17:02:27 UTC (rev 5497)
@@ -1123,6 +1123,8 @@
val socket = _import "Socket_GenericSock_socket" : C_Int.t * C_Int.t * C_Int.t -> (C_Int.t) C_Errno.t;
val socketPair = _import "Socket_GenericSock_socketPair" : C_Int.t * C_Int.t * C_Int.t * (C_Int.t) array -> (C_Int.t) C_Errno.t;
end
+val getTimeout_sec = _import "Socket_getTimeout_sec" : unit -> C_Time.t;
+val getTimeout_usec = _import "Socket_getTimeout_usec" : unit -> C_SUSeconds.t;
structure INetSock =
struct
structure Ctl =
@@ -1146,10 +1148,13 @@
val MSG_WAITALL = _const "Socket_MSG_WAITALL" : C_Int.t;
val recv = _import "Socket_recv" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t;
val recvFrom = _import "Socket_recvFrom" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t * (Word8.t) array * (C_Socklen.t) ref -> (C_SSize.t) C_Errno.t;
+val select = _import "Socket_select" : (C_Fd.t) vector * (C_Fd.t) vector * (C_Fd.t) vector * (C_Int.t) array * (C_Int.t) array * (C_Int.t) array -> (C_Int.t) C_Errno.t;
val sendArr = _import "Socket_sendArr" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t;
val sendArrTo = _import "Socket_sendArrTo" : C_Sock.t * (Word8.t) array * C_Int.t * C_Size.t * C_Int.t * (Word8.t) vector * C_Socklen.t -> (C_SSize.t) C_Errno.t;
val sendVec = _import "Socket_sendVec" : C_Sock.t * (Word8.t) vector * C_Int.t * C_Size.t * C_Int.t -> (C_SSize.t) C_Errno.t;
val sendVecTo = _import "Socket_sendVecTo" : C_Sock.t * (Word8.t) vector * C_Int.t * C_Size.t * C_Int.t * (Word8.t) vector * C_Socklen.t -> (C_SSize.t) C_Errno.t;
+val setTimeout = _import "Socket_setTimeout" : C_Time.t * C_SUSeconds.t -> unit;
+val setTimeoutNull = _import "Socket_setTimeoutNull" : unit -> unit;
val SHUT_RD = _const "Socket_SHUT_RD" : C_Int.t;
val SHUT_RDWR = _const "Socket_SHUT_RDWR" : C_Int.t;
val SHUT_WR = _const "Socket_SHUT_WR" : C_Int.t;
More information about the MLton-commit
mailing list