summaryrefslogtreecommitdiff
path: root/otherlibs
diff options
context:
space:
mode:
Diffstat (limited to 'otherlibs')
-rw-r--r--otherlibs/labltk/browser/searchpos.ml7
-rw-r--r--otherlibs/labltk/lib/Makefile2
-rw-r--r--otherlibs/num/Makefile.nt2
-rw-r--r--otherlibs/num/num.mli4
-rw-r--r--otherlibs/unix/unixsupport.c11
-rw-r--r--otherlibs/win32unix/Makefile.nt2
-rw-r--r--otherlibs/win32unix/accept.c15
-rw-r--r--otherlibs/win32unix/channels.c6
-rw-r--r--otherlibs/win32unix/select.c693
-rw-r--r--otherlibs/win32unix/socket.c16
-rw-r--r--otherlibs/win32unix/times.c35
-rw-r--r--otherlibs/win32unix/unix.ml4
-rw-r--r--otherlibs/win32unix/windbug.h6
13 files changed, 489 insertions, 314 deletions
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index f6fb50051b..78087c80d9 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -693,13 +693,6 @@ and search_pos_class_structure ~pos cls =
| Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos
| Cf_val _ -> ()
| Cf_meth (_, exp) -> search_pos_expr exp ~pos
- | Cf_let (_, pel, iel) ->
- List.iter pel ~f:
- begin fun (pat, exp) ->
- search_pos_pat pat ~pos ~env:exp.exp_env;
- search_pos_expr exp ~pos
- end;
- List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos)
| Cf_init exp -> search_pos_expr exp ~pos
end
diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile
index 6be9af0560..35ba8ff680 100644
--- a/otherlibs/labltk/lib/Makefile
+++ b/otherlibs/labltk/lib/Makefile
@@ -71,7 +71,7 @@ $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A)
$(LIBNAME): Makefile $(TOPDIR)/config/Makefile
@echo Generate $@
@echo "#!/bin/sh" > $@
- @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@
+ @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) "$$@"' >> $@
install-script: $(LIBNAME)
cp $(LIBNAME) $(BINDIR)
diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt
index 9d831657af..4ac69c7cad 100644
--- a/otherlibs/num/Makefile.nt
+++ b/otherlibs/num/Makefile.nt
@@ -28,7 +28,7 @@ clean::
rm -f *~
bng.$(O): bng.h bng_digit.c \
- bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c
+ bng_amd64.c bng_ia32.c bng_ppc.c bng_sparc.c
depend:
sed -e 's/\.o/.$(O)/g' .depend > .depend.nt
diff --git a/otherlibs/num/num.mli b/otherlibs/num/num.mli
index 1d421ff29d..1773338470 100644
--- a/otherlibs/num/num.mli
+++ b/otherlibs/num/num.mli
@@ -155,7 +155,9 @@ val approx_num_exp : int -> num -> string
first argument is the number of digits in the mantissa. *)
val num_of_string : string -> num
-(** Convert a string to a number. *)
+(** Convert a string to a number.
+ Raise [Failure "num_of_string"] if the given string is not
+ a valid representation of an integer *)
(** {6 Coercions between numerical types} *)
diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c
index 3138115a6f..4c91adb104 100644
--- a/otherlibs/unix/unixsupport.c
+++ b/otherlibs/unix/unixsupport.c
@@ -165,7 +165,11 @@
#define ESOCKTNOSUPPORT (-1)
#endif
#ifndef EOPNOTSUPP
-#define EOPNOTSUPP (-1)
+# ifdef ENOTSUP
+# define EOPNOTSUPP ENOTSUP
+# else
+# define EOPNOTSUPP (-1)
+# endif
#endif
#ifndef EPFNOSUPPORT
#define EPFNOSUPPORT (-1)
@@ -252,6 +256,11 @@ value unix_error_of_code (int errcode)
int errconstr;
value err;
+#if defined(ENOTSUP) && (EOPNOTSUPP != ENOTSUP)
+ if (errcode == ENOTSUP)
+ errcode = EOPNOTSUPP;
+#endif
+
errconstr =
cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1);
if (errconstr == Val_int(-1)) {
diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt
index 80fcbf35b7..84f1574a34 100644
--- a/otherlibs/win32unix/Makefile.nt
+++ b/otherlibs/win32unix/Makefile.nt
@@ -21,7 +21,7 @@ WIN_FILES = accept.c bind.c channels.c close.c \
mkdir.c open.c pipe.c read.c rename.c \
select.c sendrecv.c \
shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \
- system.c unixsupport.c windir.c winwait.c write.c \
+ system.c times.c unixsupport.c windir.c winwait.c write.c \
winlist.c winworker.c windbug.c
# Files from the ../unix directory
diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c
index 48d028790f..68c7bac7af 100644
--- a/otherlibs/win32unix/accept.c
+++ b/otherlibs/win32unix/accept.c
@@ -26,30 +26,15 @@ CAMLprim value unix_accept(sock)
SOCKET sconn = Socket_val(sock);
SOCKET snew;
value fd = Val_unit, adr = Val_unit, res;
- int oldvalue, oldvaluelen, newvalue, retcode;
union sock_addr_union addr;
socklen_param_type addr_len;
DWORD err = 0;
- oldvaluelen = sizeof(oldvalue);
- retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, &oldvaluelen);
- if (retcode == 0) {
- /* Set sockets to synchronous mode */
- newvalue = SO_SYNCHRONOUS_NONALERT;
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &newvalue, sizeof(newvalue));
- }
addr_len = sizeof(sock_addr);
enter_blocking_section();
snew = accept(sconn, &addr.s_gen, &addr_len);
if (snew == INVALID_SOCKET) err = WSAGetLastError ();
leave_blocking_section();
- if (retcode == 0) {
- /* Restore initial mode */
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, oldvaluelen);
- }
if (snew == INVALID_SOCKET) {
win32_maperr(err);
uerror("accept", Nothing);
diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c
index 2a3774d90e..ea3912720d 100644
--- a/otherlibs/win32unix/channels.c
+++ b/otherlibs/win32unix/channels.c
@@ -20,15 +20,15 @@
#include "unixsupport.h"
#include <fcntl.h>
-extern long _get_osfhandle(int);
-extern int _open_osfhandle(long, int);
+extern intptr_t _get_osfhandle(int);
+extern int _open_osfhandle(intptr_t, int);
int win_CRT_fd_of_filedescr(value handle)
{
if (CRT_fd_val(handle) != NO_CRT_FD) {
return CRT_fd_val(handle);
} else {
- int fd = _open_osfhandle((long) Handle_val(handle), O_BINARY);
+ int fd = _open_osfhandle((intptr_t) Handle_val(handle), O_BINARY);
if (fd == -1) uerror("channel_of_descr", Nothing);
CRT_fd_val(handle) = fd;
return fd;
diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c
index af9766ff87..7069d140fb 100644
--- a/otherlibs/win32unix/select.c
+++ b/otherlibs/win32unix/select.c
@@ -114,9 +114,9 @@ typedef enum _SELECTHANDLETYPE {
typedef enum _SELECTMODE {
SELECT_MODE_NONE = 0,
- SELECT_MODE_READ,
- SELECT_MODE_WRITE,
- SELECT_MODE_EXCEPT,
+ SELECT_MODE_READ = 1,
+ SELECT_MODE_WRITE = 2,
+ SELECT_MODE_EXCEPT = 4,
} SELECTMODE;
typedef enum _SELECTSTATE {
@@ -157,7 +157,9 @@ typedef SELECTQUERY *LPSELECTQUERY;
typedef struct _SELECTDATA {
LIST lst;
SELECTTYPE EType;
- SELECTRESULT aResults[MAXIMUM_SELECT_OBJECTS];
+ /* Sockets may generate a result for all three lists from one single query object
+ */
+ SELECTRESULT aResults[MAXIMUM_SELECT_OBJECTS * 3];
DWORD nResultsCount;
/* Data following are dedicated to APC like call, they
will be initialized if required.
@@ -240,7 +242,7 @@ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int l
DWORD i;
res = 0;
- if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS)
+ if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS * 3)
{
i = lpSelectData->nResultsCount;
lpSelectData->aResults[i].EMode = EMode;
@@ -490,31 +492,38 @@ LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData,
void socket_poll (HANDLE hStop, void *_data)
{
LPSELECTDATA lpSelectData;
- LPSELECTQUERY iterQuery;
- HANDLE aEvents[MAXIMUM_SELECT_OBJECTS];
- DWORD nEvents;
- long maskEvents;
- DWORD i;
- u_long iMode;
+ LPSELECTQUERY iterQuery;
+ HANDLE aEvents[MAXIMUM_SELECT_OBJECTS];
+ DWORD nEvents;
+ long maskEvents;
+ DWORD i;
+ u_long iMode;
+ SELECTMODE mode;
+ WSANETWORKEVENTS events;
lpSelectData = (LPSELECTDATA)_data;
+ DEBUG_PRINT("Worker has %d queries to service", lpSelectData->nQueriesCount);
for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++)
{
iterQuery = &(lpSelectData->aQueries[nEvents]);
aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL);
maskEvents = 0;
- switch (iterQuery->EMode)
+ mode = iterQuery->EMode;
+ if ((mode & SELECT_MODE_READ) != 0)
{
- case SELECT_MODE_READ:
- maskEvents = FD_READ | FD_ACCEPT | FD_CLOSE;
- break;
- case SELECT_MODE_WRITE:
- maskEvents = FD_WRITE | FD_CONNECT | FD_CLOSE;
- break;
- case SELECT_MODE_EXCEPT:
- maskEvents = FD_OOB;
- break;
+ DEBUG_PRINT("Polling read for %d", iterQuery->hFileDescr);
+ maskEvents |= FD_READ | FD_ACCEPT | FD_CLOSE;
+ }
+ if ((mode & SELECT_MODE_WRITE) != 0)
+ {
+ DEBUG_PRINT("Polling write for %d", iterQuery->hFileDescr);
+ maskEvents |= FD_WRITE | FD_CONNECT | FD_CLOSE;
+ }
+ if ((mode & SELECT_MODE_EXCEPT) != 0)
+ {
+ DEBUG_PRINT("Polling exceptions for %d", iterQuery->hFileDescr);
+ maskEvents |= FD_OOB;
}
check_error(lpSelectData,
@@ -548,7 +557,23 @@ void socket_poll (HANDLE hStop, void *_data)
DEBUG_PRINT("Socket %d has pending events", (i - 1));
if (iterQuery != NULL)
{
- select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrigIdx);
+ /* Find out what kind of events were raised
+ */
+ if (WSAEnumNetworkEvents((SOCKET)(iterQuery->hFileDescr), aEvents[i], &events) == 0)
+ {
+ if ((iterQuery->EMode & SELECT_MODE_READ) != 0 && (events.lNetworkEvents & (FD_READ | FD_ACCEPT | FD_CLOSE)) != 0)
+ {
+ select_data_result_add(lpSelectData, SELECT_MODE_READ, iterQuery->lpOrigIdx);
+ }
+ if ((iterQuery->EMode & SELECT_MODE_WRITE) != 0 && (events.lNetworkEvents & (FD_WRITE | FD_CONNECT | FD_CLOSE)) != 0)
+ {
+ select_data_result_add(lpSelectData, SELECT_MODE_WRITE, iterQuery->lpOrigIdx);
+ }
+ if ((iterQuery->EMode & SELECT_MODE_EXCEPT) != 0 && (events.lNetworkEvents & FD_OOB) != 0)
+ {
+ select_data_result_add(lpSelectData, SELECT_MODE_EXCEPT, iterQuery->lpOrigIdx);
+ }
+ }
}
}
/* WSAEventSelect() automatically sets socket to nonblocking mode.
@@ -581,23 +606,88 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData,
unsigned int uFlagsFd)
{
LPSELECTDATA res;
- LPSELECTDATA hd;
+ LPSELECTDATA candidate;
+ DWORD i;
+ LPSELECTQUERY aQueries;
- hd = lpSelectData;
+ res = lpSelectData;
+ candidate = NULL;
+ aQueries = NULL;
+
/* Polling socket can be done mulitple handle at the same time. You just
need one worker to use it. Try to find if there is already a worker
handling this kind of request.
+ Only one event can be associated with a given socket which means that if a socket
+ is in more than one of the fd_sets then we have to find that particular query and update
+ EMode with the additional flag.
*/
DEBUG_PRINT("Scanning list of worker to find one that already handle socket");
- res = select_data_job_search(&hd, SELECT_TYPE_SOCKET);
-
- /* Add a new socket to poll */
- res->funcWorker = socket_poll;
- DEBUG_PRINT("Add socket %x to worker", hFileDescr);
- select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd);
- DEBUG_PRINT("Socket %x added", hFileDescr);
+ /* Search for job */
+ DEBUG_PRINT("Searching for an available job for type %d for descriptor %d", SELECT_TYPE_SOCKET, hFileDescr);
+ while (res != NULL)
+ {
+ if (res->EType == SELECT_TYPE_SOCKET)
+ {
+ i = res->nQueriesCount - 1;
+ aQueries = res->aQueries;
+ while (i >= 0 && aQueries[i].hFileDescr != hFileDescr)
+ {
+ i--;
+ }
+ /* If we didn't find the socket but this worker has available slots, store it
+ */
+ if (i < 0)
+ {
+ if ( res->nQueriesCount < MAXIMUM_SELECT_OBJECTS)
+ {
+ candidate = res;
+ }
+ res = LIST_NEXT(LPSELECTDATA, res);
+ }
+ else
+ {
+ /* Previous socket query located -- we're finished
+ */
+ aQueries = &aQueries[i];
+ break;
+ }
+ }
+ else
+ {
+ res = LIST_NEXT(LPSELECTDATA, res);
+ }
+ }
- return hd;
+ if (res == NULL)
+ {
+ res = candidate;
+
+ /* No matching job found, create one */
+ if (res == NULL)
+ {
+ DEBUG_PRINT("No job for type %d found, create one", SELECT_TYPE_SOCKET);
+ res = select_data_new(lpSelectData, SELECT_TYPE_SOCKET);
+ res->funcWorker = socket_poll;
+ res->nQueriesCount = 1;
+ aQueries = &res->aQueries[0];
+ }
+ else
+ {
+ aQueries = &(res->aQueries[res->nQueriesCount++]);
+ }
+ aQueries->EMode = EMode;
+ aQueries->hFileDescr = hFileDescr;
+ aQueries->lpOrigIdx = lpOrigIdx;
+ aQueries->uFlagsFd = uFlagsFd;
+ DEBUG_PRINT("Socket %x added", hFileDescr);
+ }
+ else
+ {
+ aQueries->EMode |= EMode;
+ DEBUG_PRINT("Socket %x updated to %d", hFileDescr, aQueries->EMode);
+ }
+
+ return res;
}
/***********************/
@@ -817,6 +907,42 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd
#define MAX(a, b) ((a) > (b) ? (a) : (b))
+/* Convert fdlist to an fd_set if all the handles in fdlist are sockets and return 0.
+ * Returns 1 if a non-socket value is encountered.
+ */
+static int fdlist_to_fdset(value fdlist, fd_set *fdset)
+{
+ value l, c;
+ FD_ZERO(fdset);
+ for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
+ c = Field(l, 0);
+ if (Descr_kind_val(c) == KIND_SOCKET) {
+ FD_SET(Socket_val(c), fdset);
+ } else {
+ DEBUG_PRINT("Non socket value encountered");
+ return 0;
+ }
+ }
+ return 1;
+}
+
+static value fdset_to_fdlist(value fdlist, fd_set *fdset)
+{
+ value res = Val_int(0);
+ Begin_roots2(fdlist, res)
+ for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) {
+ value s = Field(fdlist, 0);
+ if (FD_ISSET(Socket_val(s), fdset)) {
+ value newres = alloc_small(2, 0);
+ Field(newres, 0) = s;
+ Field(newres, 1) = res;
+ res = newres;
+ }
+ }
+ End_roots();
+ return res;
+}
+
CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout)
{
/* Event associated to handle */
@@ -860,246 +986,287 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value
CAMLlocal5 (read_list, write_list, except_list, res, l);
CAMLlocal1 (fd);
+ fd_set read, write, except;
+ double tm;
+ struct timeval tv;
+ struct timeval * tvp;
+
DEBUG_PRINT("in select");
- nEventsCount = 0;
- nEventsMax = 0;
- lpEventsDone = NULL;
- lpSelectData = NULL;
- iterSelectData = NULL;
- iterResult = NULL;
- err = 0;
- hasStaticData = 0;
- waitRet = 0;
- readfds_len = caml_list_length(readfds);
- writefds_len = caml_list_length(writefds);
- exceptfds_len = caml_list_length(exceptfds);
- hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len));
-
- hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax);
-
- if (Double_val(timeout) >= 0.0)
- {
- milliseconds = 1000 * Double_val(timeout);
- DEBUG_PRINT("Will wait %d ms", milliseconds);
- }
- else
- {
- milliseconds = INFINITE;
- }
-
-
- /* Create list of select data, based on the different list of fd to watch */
- DEBUG_PRINT("Dispatch read fd");
- handle_set_init(&hds, hdsData, hdsMax);
- i=0;
- for (l = readfds; l != Val_int(0); l = Field(l, 1))
- {
- fd = Field(l, 0);
- if (!handle_set_mem(&hds, Handle_val(fd)))
- {
- handle_set_add(&hds, Handle_val(fd));
- lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++);
- }
- else
- {
- DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd));
- }
- }
- handle_set_reset(&hds);
-
- DEBUG_PRINT("Dispatch write fd");
- handle_set_init(&hds, hdsData, hdsMax);
- i=0;
- for (l = writefds; l != Val_int(0); l = Field(l, 1))
- {
- fd = Field(l, 0);
- if (!handle_set_mem(&hds, Handle_val(fd)))
- {
- handle_set_add(&hds, Handle_val(fd));
- lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++);
- }
- else
- {
- DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd));
+ err = 0;
+ tm = Double_val(timeout);
+ if (readfds == Val_int(0) && writefds == Val_int(0) && exceptfds == Val_int(0)) {
+ DEBUG_PRINT("nothing to do");
+ if ( tm > 0.0 ) {
+ enter_blocking_section();
+ Sleep( (int)(tm * 1000));
+ leave_blocking_section();
}
- }
- handle_set_reset(&hds);
-
- DEBUG_PRINT("Dispatch exceptional fd");
- handle_set_init(&hds, hdsData, hdsMax);
- i=0;
- for (l = exceptfds; l != Val_int(0); l = Field(l, 1))
- {
- fd = Field(l, 0);
- if (!handle_set_mem(&hds, Handle_val(fd)))
- {
- handle_set_add(&hds, Handle_val(fd));
- lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++);
- }
- else
- {
- DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd));
- }
- }
- handle_set_reset(&hds);
-
- /* Building the list of handle to wait for */
- DEBUG_PRINT("Building events done array");
- nEventsMax = list_length((LPLIST)lpSelectData);
- nEventsCount = 0;
- lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax);
-
- iterSelectData = lpSelectData;
- while (iterSelectData != NULL)
- {
- /* Check if it is static data. If this is the case, launch everything
- * but don't wait for events. It helps to test if there are events on
- * any other fd (which are not static), knowing that there is at least
- * one result (the static data).
- */
- if (iterSelectData->EType == SELECT_TYPE_STATIC)
- {
- hasStaticData = TRUE;
- };
-
- /* Execute APC */
- if (iterSelectData->funcWorker != NULL)
- {
- iterSelectData->lpWorker =
- worker_job_submit(
- iterSelectData->funcWorker,
- (void *)iterSelectData);
- DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker);
- lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker);
- nEventsCount++;
- };
- iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
- };
-
- DEBUG_PRINT("Need to watch %d workers", nEventsCount);
-
- /* Processing select itself */
- enter_blocking_section();
- /* There are worker started, waiting to be monitored */
- if (nEventsCount > 0)
- {
- /* Waiting for event */
- if (err == 0 && !hasStaticData)
- {
- DEBUG_PRINT("Waiting for one select worker to be done");
- switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds))
- {
- case WAIT_FAILED:
- err = GetLastError();
- break;
-
- case WAIT_TIMEOUT:
- DEBUG_PRINT("Select timeout");
- break;
-
- default:
- DEBUG_PRINT("One worker is done");
- break;
- };
- }
-
- /* Ordering stop to every worker */
- DEBUG_PRINT("Sending stop signal to every select workers");
- iterSelectData = lpSelectData;
- while (iterSelectData != NULL)
- {
- if (iterSelectData->lpWorker != NULL)
- {
- worker_job_stop(iterSelectData->lpWorker);
- };
- iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
- };
+ read_list = write_list = except_list = Val_int(0);
+ } else {
+ if (fdlist_to_fdset(readfds, &read) && fdlist_to_fdset(writefds, &write) && fdlist_to_fdset(exceptfds, &except)) {
+ DEBUG_PRINT("only sockets to select on, using classic select");
+ if (tm < 0.0) {
+ tvp = (struct timeval *) NULL;
+ } else {
+ tv.tv_sec = (int) tm;
+ tv.tv_usec = (int) (1e6 * (tm - (int) tm));
+ tvp = &tv;
+ }
+ enter_blocking_section();
+ if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) {
+ err = WSAGetLastError();
+ DEBUG_PRINT("Error %ld occurred", err);
+ }
+ leave_blocking_section();
+ if (err) {
+ DEBUG_PRINT("Error %ld occurred", err);
+ win32_maperr(err);
+ uerror("select", Nothing);
+ }
+ read_list = fdset_to_fdlist(readfds, &read);
+ write_list = fdset_to_fdlist(writefds, &write);
+ except_list = fdset_to_fdlist(exceptfds, &except);
+ } else {
+ nEventsCount = 0;
+ nEventsMax = 0;
+ lpEventsDone = NULL;
+ lpSelectData = NULL;
+ iterSelectData = NULL;
+ iterResult = NULL;
+ hasStaticData = 0;
+ waitRet = 0;
+ readfds_len = caml_list_length(readfds);
+ writefds_len = caml_list_length(writefds);
+ exceptfds_len = caml_list_length(exceptfds);
+ hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len));
- DEBUG_PRINT("Waiting for every select worker to be done");
- switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE))
- {
- case WAIT_FAILED:
- err = GetLastError();
- break;
-
- default:
- DEBUG_PRINT("Every worker is done");
- break;
- }
- }
- /* Nothing to monitor but some time to wait. */
- else if (!hasStaticData)
- {
- Sleep(milliseconds);
- }
- leave_blocking_section();
-
- DEBUG_PRINT("Error status: %d (0 is ok)", err);
- /* Build results */
- if (err == 0)
- {
- DEBUG_PRINT("Building result");
- read_list = Val_unit;
- write_list = Val_unit;
- except_list = Val_unit;
-
- iterSelectData = lpSelectData;
- while (iterSelectData != NULL)
- {
- for (i = 0; i < iterSelectData->nResultsCount; i++)
- {
- iterResult = &(iterSelectData->aResults[i]);
- l = alloc_small(2, 0);
- Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds));
- switch (iterResult->EMode)
+ hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax);
+
+ if (tm >= 0.0)
{
- case SELECT_MODE_READ:
- Store_field(l, 1, read_list);
- read_list = l;
- break;
- case SELECT_MODE_WRITE:
- Store_field(l, 1, write_list);
- write_list = l;
- break;
- case SELECT_MODE_EXCEPT:
- Store_field(l, 1, except_list);
- except_list = l;
- break;
+ milliseconds = 1000 * tm;
+ DEBUG_PRINT("Will wait %d ms", milliseconds);
+ }
+ else
+ {
+ milliseconds = INFINITE;
+ }
+
+
+ /* Create list of select data, based on the different list of fd to watch */
+ DEBUG_PRINT("Dispatch read fd");
+ handle_set_init(&hds, hdsData, hdsMax);
+ i=0;
+ for (l = readfds; l != Val_int(0); l = Field(l, 1))
+ {
+ fd = Field(l, 0);
+ if (!handle_set_mem(&hds, Handle_val(fd)))
+ {
+ handle_set_add(&hds, Handle_val(fd));
+ lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++);
+ }
+ else
+ {
+ DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd));
+ }
+ }
+ handle_set_reset(&hds);
+
+ DEBUG_PRINT("Dispatch write fd");
+ handle_set_init(&hds, hdsData, hdsMax);
+ i=0;
+ for (l = writefds; l != Val_int(0); l = Field(l, 1))
+ {
+ fd = Field(l, 0);
+ if (!handle_set_mem(&hds, Handle_val(fd)))
+ {
+ handle_set_add(&hds, Handle_val(fd));
+ lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++);
+ }
+ else
+ {
+ DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd));
+ }
+ }
+ handle_set_reset(&hds);
+
+ DEBUG_PRINT("Dispatch exceptional fd");
+ handle_set_init(&hds, hdsData, hdsMax);
+ i=0;
+ for (l = exceptfds; l != Val_int(0); l = Field(l, 1))
+ {
+ fd = Field(l, 0);
+ if (!handle_set_mem(&hds, Handle_val(fd)))
+ {
+ handle_set_add(&hds, Handle_val(fd));
+ lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++);
+ }
+ else
+ {
+ DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd));
+ }
+ }
+ handle_set_reset(&hds);
+
+ /* Building the list of handle to wait for */
+ DEBUG_PRINT("Building events done array");
+ nEventsMax = list_length((LPLIST)lpSelectData);
+ nEventsCount = 0;
+ lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax);
+
+ iterSelectData = lpSelectData;
+ while (iterSelectData != NULL)
+ {
+ /* Check if it is static data. If this is the case, launch everything
+ * but don't wait for events. It helps to test if there are events on
+ * any other fd (which are not static), knowing that there is at least
+ * one result (the static data).
+ */
+ if (iterSelectData->EType == SELECT_TYPE_STATIC)
+ {
+ hasStaticData = TRUE;
+ };
+
+ /* Execute APC */
+ if (iterSelectData->funcWorker != NULL)
+ {
+ iterSelectData->lpWorker =
+ worker_job_submit(
+ iterSelectData->funcWorker,
+ (void *)iterSelectData);
+ DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker);
+ lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker);
+ nEventsCount++;
+ };
+ iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+ };
+
+ DEBUG_PRINT("Need to watch %d workers", nEventsCount);
+
+ /* Processing select itself */
+ enter_blocking_section();
+ /* There are worker started, waiting to be monitored */
+ if (nEventsCount > 0)
+ {
+ /* Waiting for event */
+ if (err == 0 && !hasStaticData)
+ {
+ DEBUG_PRINT("Waiting for one select worker to be done");
+ switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds))
+ {
+ case WAIT_FAILED:
+ err = GetLastError();
+ break;
+
+ case WAIT_TIMEOUT:
+ DEBUG_PRINT("Select timeout");
+ break;
+
+ default:
+ DEBUG_PRINT("One worker is done");
+ break;
+ };
+ }
+
+ /* Ordering stop to every worker */
+ DEBUG_PRINT("Sending stop signal to every select workers");
+ iterSelectData = lpSelectData;
+ while (iterSelectData != NULL)
+ {
+ if (iterSelectData->lpWorker != NULL)
+ {
+ worker_job_stop(iterSelectData->lpWorker);
+ };
+ iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+ };
+
+ DEBUG_PRINT("Waiting for every select worker to be done");
+ switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE))
+ {
+ case WAIT_FAILED:
+ err = GetLastError();
+ break;
+
+ default:
+ DEBUG_PRINT("Every worker is done");
+ break;
+ }
+ }
+ /* Nothing to monitor but some time to wait. */
+ else if (!hasStaticData)
+ {
+ Sleep(milliseconds);
+ }
+ leave_blocking_section();
+
+ DEBUG_PRINT("Error status: %d (0 is ok)", err);
+ /* Build results */
+ if (err == 0)
+ {
+ DEBUG_PRINT("Building result");
+ read_list = Val_unit;
+ write_list = Val_unit;
+ except_list = Val_unit;
+
+ iterSelectData = lpSelectData;
+ while (iterSelectData != NULL)
+ {
+ for (i = 0; i < iterSelectData->nResultsCount; i++)
+ {
+ iterResult = &(iterSelectData->aResults[i]);
+ l = alloc_small(2, 0);
+ Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds));
+ switch (iterResult->EMode)
+ {
+ case SELECT_MODE_READ:
+ Store_field(l, 1, read_list);
+ read_list = l;
+ break;
+ case SELECT_MODE_WRITE:
+ Store_field(l, 1, write_list);
+ write_list = l;
+ break;
+ case SELECT_MODE_EXCEPT:
+ Store_field(l, 1, except_list);
+ except_list = l;
+ break;
+ }
+ }
+ /* We try to only process the first error, bypass other errors */
+ if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR)
+ {
+ err = iterSelectData->nError;
+ }
+ iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+ }
+ }
+
+ /* Free resources */
+ DEBUG_PRINT("Free selectdata resources");
+ iterSelectData = lpSelectData;
+ while (iterSelectData != NULL)
+ {
+ lpSelectData = iterSelectData;
+ iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
+ select_data_free(lpSelectData);
+ }
+ lpSelectData = NULL;
+
+ /* Free allocated events/handle set array */
+ DEBUG_PRINT("Free local allocated resources");
+ caml_stat_free(lpEventsDone);
+ caml_stat_free(hdsData);
+
+ DEBUG_PRINT("Raise error if required");
+ if (err != 0)
+ {
+ win32_maperr(err);
+ uerror("select", Nothing);
}
- }
- /* We try to only process the first error, bypass other errors */
- if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR)
- {
- err = iterSelectData->nError;
- }
- iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
}
}
- /* Free resources */
- DEBUG_PRINT("Free selectdata resources");
- iterSelectData = lpSelectData;
- while (iterSelectData != NULL)
- {
- lpSelectData = iterSelectData;
- iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData);
- select_data_free(lpSelectData);
- }
- lpSelectData = NULL;
-
- /* Free allocated events/handle set array */
- DEBUG_PRINT("Free local allocated resources");
- caml_stat_free(lpEventsDone);
- caml_stat_free(hdsData);
-
- DEBUG_PRINT("Raise error if required");
- if (err != 0)
- {
- win32_maperr(err);
- uerror("select", Nothing);
- }
-
DEBUG_PRINT("Build final result");
res = alloc_small(3, 0);
Store_field(res, 0, read_list);
diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c
index abdab25f3a..37ad175d26 100644
--- a/otherlibs/win32unix/socket.c
+++ b/otherlibs/win32unix/socket.c
@@ -28,25 +28,9 @@ CAMLprim value unix_socket(domain, type, proto)
value domain, type, proto;
{
SOCKET s;
- int oldvalue, oldvaluelen, newvalue, retcode;
-
- oldvaluelen = sizeof(oldvalue);
- retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, &oldvaluelen);
- if (retcode == 0) {
- /* Set sockets to synchronous mode */
- newvalue = SO_SYNCHRONOUS_NONALERT;
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &newvalue, sizeof(newvalue));
- }
s = socket(socket_domain_table[Int_val(domain)],
socket_type_table[Int_val(type)],
Int_val(proto));
- if (retcode == 0) {
- /* Restore initial mode */
- setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
- (char *) &oldvalue, oldvaluelen);
- }
if (s == INVALID_SOCKET) {
win32_maperr(WSAGetLastError());
uerror("socket", Nothing);
diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c
new file mode 100644
index 0000000000..725895ec15
--- /dev/null
+++ b/otherlibs/win32unix/times.c
@@ -0,0 +1,35 @@
+#include <windows.h>
+#include <mlvalues.h>
+#include "unixsupport.h"
+
+
+double to_sec(FILETIME ft) {
+ ULARGE_INTEGER tmp;
+
+ tmp.u.LowPart = ft.dwLowDateTime;
+ tmp.u.HighPart = ft.dwHighDateTime;
+
+ /* convert to seconds:
+ GetProcessTimes returns number of 100-nanosecond intervals */
+ return tmp.QuadPart / 1e7;
+}
+
+
+value unix_times(value unit) {
+
+ value res;
+ FILETIME creation, exit, stime, utime;
+
+ if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) {
+ win32_maperr(GetLastError());
+ uerror("times", Nothing);
+ }
+
+ res = alloc_small(4 * Double_wosize, Double_array_tag);
+ Store_double_field(res, 0, to_sec(utime));
+ Store_double_field(res, 1, to_sec(stime));
+ Store_double_field(res, 2, 0);
+ Store_double_field(res, 3, 0);
+ return res;
+
+}
diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml
index 56d33bde88..19c278240f 100644
--- a/otherlibs/win32unix/unix.ml
+++ b/otherlibs/win32unix/unix.ml
@@ -408,9 +408,7 @@ external localtime : float -> tm = "unix_localtime"
external mktime : tm -> float * tm = "unix_mktime"
let alarm n = invalid_arg "Unix.alarm not implemented"
external sleep : int -> unit = "unix_sleep"
-let times () =
- { tms_utime = Sys.time(); tms_stime = 0.0;
- tms_cutime = 0.0; tms_cstime = 0.0 }
+external times: unit -> process_times = "unix_times"
external utimes : string -> float -> float -> unit = "unix_utimes"
type interval_timer =
diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h
index 3e23413619..efaeffc011 100644
--- a/otherlibs/win32unix/windbug.h
+++ b/otherlibs/win32unix/windbug.h
@@ -18,13 +18,15 @@
#include <stdio.h>
#include <windows.h>
+/* According to MSDN, MSVC supports the gcc ## operator (to deal with empty argument lists)
+ */
#define DEBUG_PRINT(fmt, ...) \
do \
{ \
if (debug_test()) \
{ \
- fprintf(stderr, "DBUG (pid:%d, tid: %d): ", GetCurrentProcessId(), GetCurrentThreadId()); \
- fprintf(stderr, fmt, __VA_ARGS__); \
+ fprintf(stderr, "DBUG (pid:%ld, tid: %ld): ", GetCurrentProcessId(), GetCurrentThreadId()); \
+ fprintf(stderr, fmt, ##__VA_ARGS__); \
fprintf(stderr, "\n"); \
fflush(stderr); \
}; \
View Lorry Controller Status