[MLton-commit] r7198
Wesley Terpstra
wesley at mlton.org
Tue Jun 30 17:52:39 PDT 2009
Fix non-blocking IO on MinGW:
* To fix acceptNB/connectNB, we must expose two new basis-ffi functions,
MinGW_{set,clear}NonBlock to use the Windows specific API calls.
* To fix the recv[From]{Arr,Vec}NB calls we need to admit MSG_DONTWAIT is
missing and implement MLton_recv[from].
----------------------------------------------------------------------
U mlton/trunk/basis-library/net/socket.sml
U mlton/trunk/basis-library/primitive/basis-ffi.sml
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
U mlton/trunk/runtime/platform/mingw.c
U mlton/trunk/runtime/platform/mingw.h
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/net/socket.sml
===================================================================
--- mlton/trunk/basis-library/net/socket.sml 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/basis-library/net/socket.sml 2009-07-01 00:52:37 UTC (rev 7198)
@@ -391,8 +391,10 @@
local
structure PIO = PrimitiveFFI.Posix.IO
-in
- fun withNonBlock (s, f: unit -> 'a) =
+ structure OS = Primitive.MLton.Platform.OS
+ structure MinGW = PrimitiveFFI.MinGW
+
+ fun withNonBlockNormal (s, f: unit -> 'a) =
let
val fd = Sock.toRep s
val flags =
@@ -407,6 +409,20 @@
(f, fn () =>
Syscall.simpleRestart (fn () => PIO.fcntl3 (fd, PIO.F_SETFL, flags)))
end
+
+ fun withNonBlockMinGW (s, f: unit -> 'a) =
+ let
+ val fd = Sock.toRep s
+ val () = MinGW.setNonBlock fd
+ in
+ DynamicWind.wind
+ (f, fn () => MinGW.clearNonBlock fd)
+ end
+in
+ val withNonBlock = fn x =>
+ case OS.host of
+ OS.MinGW => withNonBlockMinGW x
+ | _ => withNonBlockNormal x
end
fun connect (s, SA sa) =
Modified: mlton/trunk/basis-library/primitive/basis-ffi.sml
===================================================================
--- mlton/trunk/basis-library/primitive/basis-ffi.sml 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/basis-library/primitive/basis-ffi.sml 2009-07-01 00:52:37 UTC (rev 7198)
@@ -65,7 +65,9 @@
end
structure MinGW =
struct
+val clearNonBlock = _import "MinGW_clearNonBlock" private : C_Fd.t -> unit;
val getTempPath = _import "MinGW_getTempPath" private : C_Size.t * (Char8.t) array -> C_Size.t;
+val setNonBlock = _import "MinGW_setNonBlock" private : C_Fd.t -> unit;
end
structure MLton =
struct
Modified: mlton/trunk/runtime/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/basis-ffi.h 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/runtime/basis-ffi.h 2009-07-01 00:52:37 UTC (rev 7198)
@@ -44,7 +44,9 @@
PRIVATE extern const C_Int_t IEEEReal_RoundingMode_FE_TOWARDZERO;
PRIVATE extern const C_Int_t IEEEReal_RoundingMode_FE_UPWARD;
PRIVATE C_Int_t IEEEReal_setRoundingMode(C_Int_t);
+PRIVATE void MinGW_clearNonBlock(C_Fd_t);
PRIVATE C_Size_t MinGW_getTempPath(C_Size_t,Array(Char8_t));
+PRIVATE void MinGW_setNonBlock(C_Fd_t);
PRIVATE __attribute__((noreturn)) void MLton_bug(String8_t);
PRIVATE extern const C_Int_t MLton_Itimer_PROF;
PRIVATE extern const C_Int_t MLton_Itimer_REAL;
Modified: mlton/trunk/runtime/gen/basis-ffi.def
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.def 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/runtime/gen/basis-ffi.def 2009-07-01 00:52:37 UTC (rev 7198)
@@ -109,6 +109,8 @@
MLton.Syslog.openlog = _import PRIVATE : NullString8.t * C_Int.t * C_Int.t -> unit
MLton.Syslog.syslog = _import PRIVATE : C_Int.t * NullString8.t -> unit
MinGW.getTempPath = _import PRIVATE : C_Size.t * Char8.t array -> C_Size.t
+MinGW.setNonBlock = _import PRIVATE : C_Fd.t -> unit
+MinGW.clearNonBlock = _import PRIVATE : C_Fd.t -> unit
Net.htonl = _import PRIVATE : Word32.t -> Word32.t
Net.htons = _import PRIVATE : Word16.t -> Word16.t
Net.ntohl = _import PRIVATE : Word32.t -> Word32.t
Modified: mlton/trunk/runtime/gen/basis-ffi.h
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.h 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/runtime/gen/basis-ffi.h 2009-07-01 00:52:37 UTC (rev 7198)
@@ -44,7 +44,9 @@
PRIVATE extern const C_Int_t IEEEReal_RoundingMode_FE_TOWARDZERO;
PRIVATE extern const C_Int_t IEEEReal_RoundingMode_FE_UPWARD;
PRIVATE C_Int_t IEEEReal_setRoundingMode(C_Int_t);
+PRIVATE void MinGW_clearNonBlock(C_Fd_t);
PRIVATE C_Size_t MinGW_getTempPath(C_Size_t,Array(Char8_t));
+PRIVATE void MinGW_setNonBlock(C_Fd_t);
PRIVATE __attribute__((noreturn)) void MLton_bug(String8_t);
PRIVATE extern const C_Int_t MLton_Itimer_PROF;
PRIVATE extern const C_Int_t MLton_Itimer_REAL;
Modified: mlton/trunk/runtime/gen/basis-ffi.sml
===================================================================
--- mlton/trunk/runtime/gen/basis-ffi.sml 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/runtime/gen/basis-ffi.sml 2009-07-01 00:52:37 UTC (rev 7198)
@@ -65,7 +65,9 @@
end
structure MinGW =
struct
+val clearNonBlock = _import "MinGW_clearNonBlock" private : C_Fd.t -> unit;
val getTempPath = _import "MinGW_getTempPath" private : C_Size.t * (Char8.t) array -> C_Size.t;
+val setNonBlock = _import "MinGW_setNonBlock" private : C_Fd.t -> unit;
end
structure MLton =
struct
Modified: mlton/trunk/runtime/platform/mingw.c
===================================================================
--- mlton/trunk/runtime/platform/mingw.c 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/runtime/platform/mingw.c 2009-07-01 00:52:37 UTC (rev 7198)
@@ -1263,6 +1263,34 @@
}
}
+int MLton_recv(int s, void *buf, int len, int flags) {
+ int ret, status = 0;
+
+ if (flags & MSG_DONTWAIT) MinGW_setNonBlock(s);
+ ret = recv(s, buf, len, flags & ~MSG_DONTWAIT);
+
+ /* We need to preserve the error status across non-blocking call */
+ if (ret == -1) status = WSAGetLastError();
+ if (flags & MSG_DONTWAIT) MinGW_clearNonBlock(s);
+ if (ret == -1) WSASetLastError(status);
+
+ return ret;
+}
+
+int MLton_recvfrom(int s, void *buf, int len, int flags, void *from,
+ socklen_t *fromlen) {
+ int ret, status = 0;
+
+ if (flags & MSG_DONTWAIT) MinGW_setNonBlock(s);
+ ret = recvfrom(s, buf, len, flags & ~MSG_DONTWAIT, from, fromlen);
+
+ /* We need to preserve the error status across non-blocking call */
+ if (ret == -1) status = WSAGetLastError();
+ if (flags & MSG_DONTWAIT) MinGW_clearNonBlock(s);
+ if (ret == -1) WSASetLastError(status);
+
+ return ret;
+}
/* ------------------------------------------------- */
/* Syslog */
/* ------------------------------------------------- */
@@ -1313,3 +1341,13 @@
C_Size_t MinGW_getTempPath(C_Size_t buf_size, Array(Char8_t) buf) {
return GetTempPath(buf_size, (char*)buf);
}
+
+void MinGW_setNonBlock(C_Fd_t fd) {
+ unsigned long yes = 1;
+ ioctlsocket(fd, FIONBIO, &yes);
+}
+
+void MinGW_clearNonBlock(C_Fd_t fd) {
+ unsigned long no = 0;
+ ioctlsocket(fd, FIONBIO, &no);
+}
Modified: mlton/trunk/runtime/platform/mingw.h
===================================================================
--- mlton/trunk/runtime/platform/mingw.h 2009-06-30 22:44:15 UTC (rev 7197)
+++ mlton/trunk/runtime/platform/mingw.h 2009-07-01 00:52:37 UTC (rev 7198)
@@ -37,7 +37,7 @@
#define HAS_FPCLASSIFY FALSE
#define HAS_FPCLASSIFY32 FALSE
#define HAS_FPCLASSIFY64 FALSE
-#define HAS_MSG_DONTWAIT TRUE
+#define HAS_MSG_DONTWAIT FALSE
#define HAS_REMAP TRUE
#define HAS_SIGALTSTACK FALSE
#define HAS_SIGNBIT TRUE
@@ -1539,7 +1539,7 @@
#endif
#ifndef MSG_DONTWAIT
-#define MSG_DONTWAIT 0
+#define MSG_DONTWAIT 0x1000000
#endif
#ifndef MSG_EOR
More information about the MLton-commit
mailing list