// Create a registry key and make an entry in the table for it.
static Handle createRegistryKey(TaskData *taskData, Handle args, HKEY hkParent)
{
TCHAR keyName[MAX_PATH];
LONG lRes;
Handle keyResult, dispRes, pair;
PHANDLETAB pTab;
HKEY hkey;
DWORD dwDisp;
REGSAM sam = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(3));
unsigned opt = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH);
if (length > MAX_PATH)
raise_syscall(taskData, "Key name too long", ENAMETOOLONG);
// Try opening the key.
lRes = RegCreateKeyEx(hkParent, keyName, 0, NULL,
opt ? REG_OPTION_NON_VOLATILE : REG_OPTION_VOLATILE,
sam, NULL, &hkey, &dwDisp);
if (lRes != ERROR_SUCCESS)
raise_syscall(taskData, "RegCreateKeyEx failed", -lRes);
// Make an entry in the table.
keyResult = make_handle_entry(taskData);
pTab = &handleTable[STREAMID(keyResult)];
pTab->entryType = HE_REGISTRY;
pTab->entry.hKey = hkey;
// Record whether this was new or old.
dispRes = Make_arbitrary_precision(taskData, dwDisp == REG_CREATED_NEW_KEY ? 0: 1);
/* Return a pair of the disposition and the token. */
pair = alloc_and_save(taskData, 2);
DEREFHANDLE(pair)->Set(0, DEREFWORDHANDLE(dispRes));
DEREFHANDLE(pair)->Set(1, DEREFWORDHANDLE(keyResult));
return pair;
}
static Handle setRegistryKey(TaskData *taskData, Handle args, HKEY hkey)
{
TCHAR valName[MAX_PATH];
LONG lRes;
PolyWord str = args->WordP()->Get(3);
POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH);
DWORD dwType = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
if (length > MAX_PATH)
raise_syscall(taskData, "Value name too long", ENAMETOOLONG);
// The value is binary. Strings will already have had a null added.
if (IS_INT(str))
{
byte b = (byte)UNTAGGED(str);
// Single byte value.
lRes = RegSetValueEx(hkey, valName, 0, dwType, &b, 1);
}
else
{
PolyStringObject *ps = (PolyStringObject*)str.AsObjPtr();
lRes = RegSetValueEx(hkey, valName, 0, dwType,
(CONST BYTE *)ps->chars, (DWORD)ps->length);
}
if (lRes != ERROR_SUCCESS)
raise_syscall(taskData, "RegSetValue failed", -lRes);
return Make_arbitrary_precision(taskData, 0);
}
Handle LoadState(TaskData *taskData, Handle hFileName)
// Load a saved state file and any ancestors.
{
// Open the load file
TCHAR fileNameBuff[MAXPATHLEN];
POLYUNSIGNED length =
Poly_string_to_C(DEREFHANDLE(hFileName), fileNameBuff, MAXPATHLEN);
if (length > MAXPATHLEN)
raise_syscall(taskData, "File name too long", ENAMETOOLONG);
StateLoader loader(fileNameBuff);
// Request the main thread to do the load. This may set the error string if it failed.
processes->MakeRootRequest(taskData, &loader);
if (loader.errorResult != 0)
{
if (loader.errNumber == 0)
raise_fail(taskData, loader.errorResult);
else
{
char buff[MAXPATHLEN+100];
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "%s: %S", loader.errorResult, loader.fileName);
#else
sprintf(buff, "%s: %s", loader.errorResult, loader.fileName);
#endif
raise_syscall(taskData, buff, loader.errNumber);
}
}
return SAVE(TAGGED(0));
}
// Enumerate a key or a value. Returns a string option containing NONE if
// no key/value could be found or SOME s where s is the name of the key/value.
static Handle enumerateRegistry(TaskData *taskData, Handle args, HKEY hkey, BOOL isKey)
{
DWORD num = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1));
LONG lRes;
TCHAR keyName[MAX_PATH];
DWORD dwLength = sizeof(keyName)/sizeof(keyName[0]);
Handle result, resVal;
if (isKey)
{
FILETIME ftMod;
lRes = RegEnumKeyEx(hkey, num, keyName, &dwLength, NULL, NULL, NULL, &ftMod);
if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS)
raise_syscall(taskData, "RegEnumKeyEx failed", -lRes);
}
else
{
lRes = RegEnumValue(hkey, num, keyName, &dwLength, NULL, NULL, NULL, NULL);
if (lRes != ERROR_SUCCESS && lRes != ERROR_NO_MORE_ITEMS)
raise_syscall(taskData, "RegEnumValue failed", -lRes);
}
if (lRes == ERROR_NO_MORE_ITEMS)
return SAVE(NONE_VALUE); /* NONE. */
resVal = SAVE(C_string_to_Poly(taskData, keyName));
result = alloc_and_save(taskData, 1);
DEREFHANDLE(result)->Set(0, DEREFWORDHANDLE(resVal));
return result;
}
static Handle queryRegistryKey(TaskData *taskData, Handle args, HKEY hkey)
{
TCHAR valName[MAX_PATH];
byte *keyValue = 0;
LONG lRes;
DWORD valSize;
Handle result, resVal, resType;
DWORD dwType;
POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), valName, MAX_PATH);
if (length > MAX_PATH)
raise_syscall(taskData, "Value name too long", ENAMETOOLONG);
// How long is the entry?
lRes = RegQueryValueEx(hkey, valName, 0, NULL, NULL, &valSize);
// When opening HKEY_PERFORMANCE_DATA we don't get a sensible
// answer here.
if (lRes == ERROR_MORE_DATA) valSize = 1024; // Guess
else if (lRes != ERROR_SUCCESS)
raise_syscall(taskData, "RegQueryValueEx failed", -lRes);
// Allocate that much store and get the value. We could
// try reading directly into ML store to save copying but
// it hardly seems worthwhile.
// Note: It seems that valSize can be zero for some items.
if (valSize == 0) resVal = SAVE(C_string_to_Poly(taskData, "", 0));
else
{
do {
byte *newAlloc = (byte*)realloc(keyValue, valSize);
if (newAlloc == 0)
{
free(keyValue);
raise_syscall(taskData, "Insufficient memory", ENOMEM);
}
keyValue = newAlloc;
lRes = RegQueryValueEx(hkey, valName, 0, &dwType, keyValue, &valSize);
// In the special case of HKEY_PERFORMANCE_DATA we may need to keep
// growing the buffer.
if (lRes == ERROR_MORE_DATA) valSize = valSize + 1024;
} while (lRes == ERROR_MORE_DATA);
if (lRes != ERROR_SUCCESS)
{
free(keyValue);
raise_syscall(taskData, "RegQueryValue failed", -lRes);
}
// If we have a string we have to convert this to ANSI/utf-8.
if (dwType == REG_SZ || dwType == REG_MULTI_SZ || dwType == REG_EXPAND_SZ)
resVal = SAVE(C_string_to_Poly(taskData, (TCHAR*)keyValue, valSize / sizeof(TCHAR)));
else resVal = SAVE(C_string_to_Poly(taskData, (char*)keyValue, valSize));
free(keyValue);
}
/* Create a pair containing the type and the value. */
resType = Make_arbitrary_precision(taskData, dwType);
result = alloc_and_save(taskData, 2);
DEREFHANDLE(result)->Set(0, DEREFWORDHANDLE(resType));
DEREFHANDLE(result)->Set(1, DEREFWORDHANDLE(resVal));
return result;
}
Handle ShowParent(TaskData *taskData, Handle hFileName)
// Return the name of the immediate parent stored in a child
{
TCHAR fileNameBuff[MAXPATHLEN+1];
POLYUNSIGNED length =
Poly_string_to_C(DEREFHANDLE(hFileName), fileNameBuff, MAXPATHLEN);
if (length > MAXPATHLEN)
raise_syscall(taskData, "File name too long", ENAMETOOLONG);
AutoClose loadFile(_tfopen(fileNameBuff, _T("rb")));
if ((FILE*)loadFile == NULL)
{
char buff[MAXPATHLEN+1+23];
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "Cannot open load file: %S", fileNameBuff);
#else
sprintf(buff, "Cannot open load file: %s", fileNameBuff);
#endif
raise_syscall(taskData, buff, errno);
}
SavedStateHeader header;
// Read the header and check the signature.
if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1)
raise_fail(taskData, "Unable to load header");
if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0)
raise_fail(taskData, "File is not a saved state");
if (header.headerVersion != SAVEDSTATEVERSION ||
header.headerLength != sizeof(SavedStateHeader) ||
header.segmentDescrLength != sizeof(SavedStateSegmentDescr))
{
raise_fail(taskData, "Unsupported version of saved state file");
}
// Does this have a parent?
if (header.parentNameEntry != 0)
{
TCHAR parentFileName[MAXPATHLEN+1];
size_t toRead = header.stringTableSize-header.parentNameEntry;
if (MAXPATHLEN < toRead) toRead = MAXPATHLEN;
if (header.parentNameEntry >= header.stringTableSize /* Bad entry */ ||
fseek(loadFile, header.stringTable + header.parentNameEntry, SEEK_SET) != 0 ||
fread(parentFileName, 1, toRead, loadFile) != toRead)
{
raise_fail(taskData, "Unable to read parent file name");
}
parentFileName[toRead] = 0; // Should already be null-terminated, but just in case.
// Convert the name into a Poly string and then build a "Some" value.
// It's possible, although silly, to have the empty string as a parent name.
Handle resVal = SAVE(C_string_to_Poly(taskData, parentFileName));
Handle result = alloc_and_save(taskData, 1);
DEREFHANDLE(result)->Set(0, DEREFWORDHANDLE(resVal));
return result;
}
else return SAVE(NONE_VALUE);
}
/* Return a stream, either text or binary, connected to an open process. */
static Handle openProcessHandle(TaskData *taskData, Handle args, BOOL fIsRead, BOOL fIsText)
{
PHANDLETAB hnd = get_handle(args->Word(), HE_PROCESS);
HANDLE hStream;
int mode = 0, ioBits = 0;
if (hnd == 0)
raise_syscall(taskData, "Process is closed", EINVAL);
if (fIsRead) hStream = hnd->entry.process.hInput;
else hStream = hnd->entry.process.hOutput;
/* I had previously assumed that it wasn't possible to get the
same stream twice. The current basis library definition allows
it but warns it may produce unpredictable results. For the moment
we don't allow it because we could get problems with closing
the same handle twice. */
#ifdef _WIN32_WCE
// Not possible in Windows CE.
raise_syscall(taskData, "Process is closed", EBADF);
return 0;
#else
if (hStream == INVALID_HANDLE_VALUE)
raise_syscall(taskData, "Process is closed", EBADF);
if (fIsRead) { mode = _O_RDONLY; ioBits = IO_BIT_READ; }
else { mode = 0; ioBits = IO_BIT_WRITE; }
if (fIsText) mode |= _O_TEXT; else mode |= _O_BINARY;
Handle str_token = make_stream_entry(taskData);
if (str_token == NULL) raise_syscall(taskData, "Insufficient memory", ENOMEM);
PIOSTRUCT strm = &basic_io_vector[STREAMID(str_token)];
strm->device.ioDesc = _open_osfhandle ((POLYSIGNED) hStream, mode);
if (strm->device.ioDesc == -1)
raise_syscall(taskData, "_open_osfhandle failed", errno);
strm->ioBits = ioBits | IO_BIT_OPEN | IO_BIT_PIPE;
/* The responsibility for closing the handle is passed to
the stream package. We need to retain a pointer to the
stream entry so that we can close the stream in "reap". */
if (fIsRead)
{
hnd->entry.process.hInput = INVALID_HANDLE_VALUE;
hnd->entry.process.readToken = strm->token;
// Pass the "input available" event.
strm->hAvailable = hnd->entry.process.hEvent;
hnd->entry.process.hEvent = NULL;
}
else
{
hnd->entry.process.hOutput = INVALID_HANDLE_VALUE;
hnd->entry.process.writeToken = strm->token;
}
return str_token;
#endif
}
// Delete a key. Note that in Windows NT (but not 95) this will fail if
// the key has subkeys.
static Handle deleteRegistryKey(TaskData *taskData, Handle args, HKEY hkParent)
{
TCHAR keyName[MAX_PATH];
LONG lRes;
POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH);
if (length > MAX_PATH)
raise_syscall(taskData, "Key name too long", ENAMETOOLONG);
// Try deleting the key.
lRes = RegDeleteKey(hkParent, keyName);
if (lRes != ERROR_SUCCESS)
/* Return the error. */
raise_syscall(taskData, "RegDeleteKey failed", -lRes);
return Make_arbitrary_precision(taskData, 0);
}
// Open a registry key and make an entry in the table for it.
static Handle openRegistryKey(TaskData *taskData, Handle args, HKEY hkParent)
{
TCHAR keyName[MAX_PATH];
LONG lRes;
Handle result;
PHANDLETAB pTab;
HKEY hkey;
REGSAM sam = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
POLYUNSIGNED length = Poly_string_to_C(args->WordP()->Get(1), keyName, MAX_PATH);
if (length > MAX_PATH)
raise_syscall(taskData, "Key name too long", ENAMETOOLONG);
// Try opening the key.
lRes = RegOpenKeyEx(hkParent, keyName, 0, sam, &hkey);
if (lRes != ERROR_SUCCESS)
raise_syscall(taskData, "RegOpenKeyEx failed", -lRes);
// Make an entry in the table.
result = make_handle_entry(taskData);
pTab = &handleTable[STREAMID(result)];
pTab->entryType = HE_REGISTRY;
pTab->entry.hKey = hkey;
return result;
}
Handle SaveState(TaskData *taskData, Handle args)
{
TCHAR fileNameBuff[MAXPATHLEN];
POLYUNSIGNED length =
Poly_string_to_C(DEREFHANDLE(args)->Get(0), fileNameBuff, MAXPATHLEN);
if (length > MAXPATHLEN)
raise_syscall(taskData, "File name too long", ENAMETOOLONG);
// The value of depth is zero for top-level save so we need to add one for hierarchy.
unsigned newHierarchy = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(1)) + 1;
if (newHierarchy > hierarchyDepth+1)
raise_fail(taskData, "Depth must be no more than the current hierarchy plus one");
// Request a full GC first. The main reason is to avoid running out of memory as a
// result of repeated saves. Old export spaces are turned into local spaces and
// the GC will delete them if they are completely empty
FullGC(taskData);
SaveRequest request(fileNameBuff, newHierarchy);
processes->MakeRootRequest(taskData, &request);
if (request.errorMessage)
raise_syscall(taskData, request.errorMessage, request.errCode);
return SAVE(TAGGED(0));
}
static Handle make_handle_entry(TaskData *taskData)
{
unsigned handle_no;
Handle str_token;
bool have_collected = false;
do {
for(handle_no = 0;
handle_no < maxHandleTab && handleTable[handle_no].token != 0;
handle_no++);
/* Check we have enough space. */
if (handle_no >= maxHandleTab)
{ /* No space. */
/* See if we have unreferenced streams. */
if (! have_collected)
{
FullGC(taskData);
have_collected = true;
}
else /* No space - expand vector. */
{
POLYUNSIGNED oldMax = maxHandleTab;
maxHandleTab += maxHandleTab/2;
void *p = realloc(handleTable, maxHandleTab*sizeof(HANDLETAB));
// If there's insufficient memory leave the old table.
if (p == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
handleTable = (PHANDLETAB)p;
/* Clear the new space. */
memset(handleTable+oldMax, 0, (maxHandleTab-oldMax)*sizeof(HANDLETAB));
}
}
} while (handle_no >= maxHandleTab);
str_token = alloc_and_save(taskData, 1, F_BYTE_OBJ);
STREAMID(str_token) = handle_no;
/* Clear the entry then set the token. */
memset(&handleTable[handle_no], 0, sizeof(HANDLETAB));
handleTable[handle_no].token = DEREFWORDHANDLE(str_token);
return str_token;
}
Handle timing_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORDHANDLE(code));
switch (c)
{
case 0: /* Get ticks per microsecond. */
return Make_arbitrary_precision(taskData, TICKS_PER_MICROSECOND);
case 1: /* Return time since the time base. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ft;
GetSystemTimeAsFileTime(&ft);
return Make_arb_from_Filetime(taskData, ft);
#else
struct timeval tv;
if (gettimeofday(&tv, NULL) != 0)
raise_syscall(taskData, "gettimeofday failed", errno);
return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000);
#endif
}
case 2: /* Return the base year. This is the year which corresponds to
zero in the timing sequence. */
#if (defined(_WIN32) && ! defined(__CYGWIN__))
return Make_arbitrary_precision(taskData, 1601);
#else
return Make_arbitrary_precision(taskData, 1970);
#endif
case 3: /* In both Windows and Unix the time base is 1st of January
in the base year. This function is provided just in case
we are running on a system with a different base. It
returns the number of seconds after 1st January of the
base year that corresponds to zero of the time base. */
return Make_arbitrary_precision(taskData, 0);
case 4: /* Return the time offset which applied/will apply at the
specified time (in seconds). */
{
int localoff = 0;
time_t theTime;
int day = 0;
#if (defined(HAVE_GMTIME_R) || defined(HAVE_LOCALTIME_R))
struct tm result;
#endif
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* Although the offset is in seconds it is since 1601. */
FILETIME ftSeconds; // Not really a file-time because it's a number of seconds.
getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */
ULARGE_INTEGER liTime;
liTime.HighPart = ftSeconds.dwHighDateTime;
liTime.LowPart = ftSeconds.dwLowDateTime;
theTime = (long)(liTime.QuadPart - SECSSINCE1601);
#else
theTime = get_C_long(taskData, DEREFWORDHANDLE(args)); /* May raise exception. */
#endif
{
#ifdef HAVE_GMTIME_R
struct tm *loctime = gmtime_r(&theTime, &result);
#else
PLocker lock(&timeLock);
struct tm *loctime = gmtime(&theTime);
#endif
if (loctime == NULL) raise_exception0(taskData, EXC_size);
localoff = (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec;
day = loctime->tm_yday;
}
{
#ifdef HAVE_LOCALTIME_R
struct tm *loctime = localtime_r(&theTime, &result);
#else
PLocker lock(&timeLock);
struct tm *loctime = localtime(&theTime);
#endif
if (loctime == NULL) raise_exception0(taskData, EXC_size);
localoff -= (loctime->tm_hour*60 + loctime->tm_min)*60 + loctime->tm_sec;
if (loctime->tm_yday != day)
{
// Different day - have to correct it. We can assume that there
// is at most one day to correct.
if (day == loctime->tm_yday+1 || (day == 0 && loctime->tm_yday >= 364))
localoff += 24*60*60;
else localoff -= 24*60*60;
}
}
return Make_arbitrary_precision(taskData, localoff);
}
case 5: /* Find out if Summer Time (daylight saving) was/will be in effect. */
{
time_t theTime;
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ftSeconds; // Not really a file-time because it's a number of seconds.
getFileTimeFromArb(taskData, args, &ftSeconds); /* May raise exception. */
ULARGE_INTEGER liTime;
liTime.HighPart = ftSeconds.dwHighDateTime;
liTime.LowPart = ftSeconds.dwLowDateTime;
theTime = (long)(liTime.QuadPart - SECSSINCE1601);
#else
theTime = get_C_long(taskData, DEREFWORDHANDLE(args)); /* May raise exception. */
#endif
int isDst = 0;
#ifdef HAVE_LOCALTIME_R
struct tm result;
struct tm *loctime = localtime_r(&theTime, &result);
isDst = loctime->tm_isdst;
#else
{
PLocker lock(&timeLock);
struct tm *loctime = localtime(&theTime);
if (loctime == NULL) raise_exception0(taskData, EXC_size);
isDst = loctime->tm_isdst;
}
#endif
return Make_arbitrary_precision(taskData, isDst);
}
case 6: /* Call strftime. It would be possible to do much of this in
ML except that it requires the current locale. */
{
struct tm time;
char *format, buff[2048];
Handle resString;
/* Get the format string. */
format = Poly_string_to_C_alloc(DEREFHANDLE(args)->Get(0));
/* Copy the time information. */
time.tm_year = get_C_int(taskData, DEREFHANDLE(args)->Get(1)) - 1900;
time.tm_mon = get_C_int(taskData, DEREFHANDLE(args)->Get(2));
time.tm_mday = get_C_int(taskData, DEREFHANDLE(args)->Get(3));
time.tm_hour = get_C_int(taskData, DEREFHANDLE(args)->Get(4));
time.tm_min = get_C_int(taskData, DEREFHANDLE(args)->Get(5));
time.tm_sec = get_C_int(taskData, DEREFHANDLE(args)->Get(6));
time.tm_wday = get_C_int(taskData, DEREFHANDLE(args)->Get(7));
time.tm_yday = get_C_int(taskData, DEREFHANDLE(args)->Get(8));
time.tm_isdst = get_C_int(taskData, DEREFHANDLE(args)->Get(9));
#if (defined(_WIN32) && ! defined(__CYGWIN__))
_tzset(); /* Make sure we set the current locale. */
#else
setlocale(LC_TIME, "");
#endif
/* It would be better to dynamically allocate the string rather
than use a fixed size but Unix unlike Windows does not distinguish
between an error in the input and the buffer being too small. */
if (strftime(buff, sizeof(buff), format, &time) <= 0)
{
/* Error */
free(format);
raise_exception0(taskData, EXC_size);
}
resString = taskData->saveVec.push(C_string_to_Poly(taskData, buff));
free(format);
return resString;
}
case 7: /* Return User CPU time since the start. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ut, ct, et, kt;
if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut))
raise_syscall(taskData, "GetProcessTimes failed", 0-GetLastError());
return Make_arb_from_Filetime(taskData, ut);
#else
struct rusage rusage;
if (getrusage(RUSAGE_SELF, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec,
rusage.ru_utime.tv_usec, 1000000);
#endif
}
case 8: /* Return System CPU time since the start. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ct, et, kt, ut;
if (! GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut))
raise_syscall(taskData, "GetProcessTimes failed", 0-GetLastError());
return Make_arb_from_Filetime(taskData, kt);
#else
struct rusage rusage;
if (getrusage(RUSAGE_SELF, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec,
rusage.ru_stime.tv_usec, 1000000);
#endif
}
case 9: /* Return GC time since the start. */
return gHeapSizeParameters.getGCUtime(taskData);
case 10: /* Return real time since the start. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
FILETIME ft;
GetSystemTimeAsFileTime(&ft);
subFiletimes(&ft, &startTime);
return Make_arb_from_Filetime(taskData, ft);
#else
struct timeval tv;
if (gettimeofday(&tv, NULL) != 0)
raise_syscall(taskData, "gettimeofday failed", errno);
subTimevals(&tv, &startTime);
return Make_arb_from_pair_scaled(taskData, tv.tv_sec, tv.tv_usec, 1000000);
#endif
}
/* These next two are used only in the Posix structure. */
case 11: /* Return User CPU time used by child processes. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
return Make_arbitrary_precision(taskData, 0);
#else
struct rusage rusage;
if (getrusage(RUSAGE_CHILDREN, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_utime.tv_sec,
rusage.ru_utime.tv_usec, 1000000);
#endif
}
case 12: /* Return System CPU time used by child processes. */
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
return Make_arbitrary_precision(taskData, 0);
#else
struct rusage rusage;
if (getrusage(RUSAGE_CHILDREN, &rusage) != 0)
raise_syscall(taskData, "getrusage failed", errno);
return Make_arb_from_pair_scaled(taskData, rusage.ru_stime.tv_sec,
rusage.ru_stime.tv_usec, 1000000);
#endif
}
case 13: /* Return GC system time since the start. */
return gHeapSizeParameters.getGCStime(taskData);
default:
{
char msg[100];
sprintf(msg, "Unknown timing function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
Handle process_env_dispatch_c(TaskData *mdTaskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(mdTaskData, DEREFWORDHANDLE(code));
switch (c)
{
case 0: /* Return the program name. */
return SAVE(C_string_to_Poly(mdTaskData, userOptions.programName));
case 1: /* Return the argument list. */
return convert_string_list(mdTaskData, userOptions.user_arg_count, userOptions.user_arg_strings);
case 14: /* Return a string from the environment. */
{
TempString buff(args->Word());
if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", ENOMEM);
TCHAR *res = _tgetenv(buff);
if (res == NULL) raise_syscall(mdTaskData, "Not Found", 0);
else return SAVE(C_string_to_Poly(mdTaskData, res));
}
case 21: // Return the whole environment. Only available in Posix.ProcEnv.
{
/* Count the environment strings */
int env_count = 0;
while (environ[env_count] != NULL) env_count++;
return convert_string_list(mdTaskData, env_count, environ);
}
case 15: /* Return the success value. */
return Make_arbitrary_precision(mdTaskData, EXIT_SUCCESS);
case 16: /* Return a failure value. */
return Make_arbitrary_precision(mdTaskData, EXIT_FAILURE);
case 17: /* Run command. */
{
TempString buff(args->Word());
if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", ENOMEM);
int res = -1;
#if (defined(_WIN32) && ! defined(__CYGWIN__))
// Windows.
TCHAR *argv[4];
argv[0] = _tgetenv(_T("COMSPEC")); // Default CLI.
if (argv[0] == 0) argv[0] = (TCHAR*)_T("cmd.exe"); // Win NT etc.
argv[1] = (TCHAR*)_T("/c");
argv[2] = buff;
argv[3] = NULL;
// If _P_NOWAIT is given the result is the process handle.
// spawnvp does any necessary path searching if argv[0]
// does not contain a full path.
intptr_t pid = _tspawnvp(_P_NOWAIT, argv[0], argv);
if (pid == -1)
raise_syscall(mdTaskData, "Function system failed", errno);
#else
// Cygwin and Unix
char *argv[4];
argv[0] = (char*)"sh";
argv[1] = (char*)"-c";
argv[2] = buff;
argv[3] = NULL;
#if (defined(__CYGWIN__))
CygwinSpawnRequest request(argv);
processes->MakeRootRequest(mdTaskData, &request);
int pid = request.pid;
if (pid < 0)
raise_syscall(mdTaskData, "Function system failed", errno);
#else
// We need to break this down so that we can unblock signals in the
// child process.
// The Unix "system" function seems to set SIGINT and SIGQUIT to
// SIG_IGN in the parent so that the wait will not be interrupted.
// That may make sense in a single-threaded application but is
// that right here?
int pid = vfork();
if (pid == -1)
raise_syscall(mdTaskData, "Function system failed", errno);
else if (pid == 0)
{ // In child
sigset_t sigset;
sigemptyset(&sigset);
sigprocmask(SIG_SETMASK, &sigset, 0);
// Reset other signals?
execve("/bin/sh", argv, environ);
_exit(1);
}
#endif
#endif
while (true)
{
try
{
// Test to see if the child has returned.
#if (defined(_WIN32) && ! defined(__CYGWIN__))
switch (WaitForSingleObject((HANDLE)pid, 0))
{
case WAIT_OBJECT_0:
{
DWORD result;
BOOL fResult = GetExitCodeProcess((HANDLE)pid, &result);
if (! fResult)
raise_syscall(mdTaskData, "Function system failed", -(int)GetLastError());
CloseHandle((HANDLE)pid);
return Make_arbitrary_precision(mdTaskData, result);
}
case WAIT_FAILED:
raise_syscall(mdTaskData, "Function system failed", -(int)GetLastError());
}
// Wait for the process to exit or for the timeout
WaitHandle waiter((HANDLE)pid);
processes->ThreadPauseForIO(mdTaskData, &waiter);
#else
int wRes = waitpid(pid, &res, WNOHANG);
if (wRes > 0)
break;
else if (wRes < 0)
{
raise_syscall(mdTaskData, "Function system failed", errno);
}
// In Unix the best we can do is wait. This may be interrupted
// by SIGCHLD depending on where signals are processed.
// One possibility is for the main thread to somehow wake-up
// the thread when it processes a SIGCHLD.
processes->ThreadPause(mdTaskData);
#endif
}
catch (...)
{
// Either IOException or KillException.
// We're abandoning the wait. This will leave
// a zombie in Unix.
#if (defined(_WIN32) && ! defined(__CYGWIN__))
CloseHandle((HANDLE)pid);
#endif
throw;
}
}
return Make_arbitrary_precision(mdTaskData, res);
}
case 18: /* Register function to run at exit. */
{
PLocker locker(&atExitLock);
if (! exiting)
{
PolyObject *cell = alloc(mdTaskData, 2);
cell->Set(0, at_exit_list);
cell->Set(1, DEREFWORD(args));
at_exit_list = cell;
}
return Make_arbitrary_precision(mdTaskData, 0);
}
case 19: /* Return the next function in the atExit list and set the
"exiting" flag to true. */
{
PLocker locker(&atExitLock);
Handle res;
exiting = true; /* Ignore further calls to atExit. */
if (at_exit_list == TAGGED(0))
raise_syscall(mdTaskData, "List is empty", 0);
PolyObject *cell = at_exit_list.AsObjPtr();
res = SAVE(cell->Get(1));
at_exit_list = cell->Get(0);
return res;
}
case 20: /* Terminate without running the atExit list or flushing buffers. */
{
/* I don't like terminating without some sort of clean up
but we'll do it this way for the moment. */
int i = get_C_int(mdTaskData, DEREFWORDHANDLE(args));
_exit(i);
}
/************ Error codes **************/
case 2: /* Get the name of a numeric error message. */
{
char buff[40];
int e = get_C_int(mdTaskData, DEREFWORDHANDLE(args));
Handle res;
/* First look to see if we have the name in
the error table. They should generally all be
there. */
const char *errorMsg = stringFromErrorCode(e);
if (errorMsg != NULL)
return SAVE(C_string_to_Poly(mdTaskData, errorMsg));
/* We get here if there's an error which isn't in the table. */
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* In the Windows version we may have both errno values
and also GetLastError values. We convert the latter into
negative values before returning them. */
if (e < 0)
{
sprintf(buff, "WINERROR%0d", -e);
res = SAVE(C_string_to_Poly(mdTaskData, buff));
return res;
}
else
#endif
{
sprintf(buff, "ERROR%0d", e);
res = SAVE(C_string_to_Poly(mdTaskData, buff));
}
return res;
}
case 3: /* Get the explanatory message for an error. */
{
return errorMsg(mdTaskData, get_C_int(mdTaskData, DEREFWORDHANDLE(args)));
}
case 4: /* Try to convert an error string to an error number. */
{
char buff[40];
/* Get the string. */
Poly_string_to_C(DEREFWORD(args), buff, sizeof(buff));
/* Look the string up in the table. */
int err = 0;
if (errorCodeFromString(buff, &err))
return Make_arbitrary_precision(mdTaskData, err);
/* If we don't find it then it may have been a constructed
error name. */
if (strncmp(buff, "ERROR", 5) == 0)
{
int i = atoi(buff+5);
if (i > 0) return Make_arbitrary_precision(mdTaskData, i);
}
#if (defined(_WIN32) && ! defined(__CYGWIN__))
if (strncmp(buff, "WINERROR", 8) == 0)
{
int i = atoi(buff+8);
if (i > 0) return Make_arbitrary_precision(mdTaskData, -i);
}
#endif
return Make_arbitrary_precision(mdTaskData, 0);
}
/************ Directory/file paths **************/
case 5: /* Return the string representing the current arc. */
return SAVE(C_string_to_Poly(mdTaskData, "."));
case 6: /* Return the string representing the parent arc. */
/* I don't know that this exists in MacOS. */
return SAVE(C_string_to_Poly(mdTaskData, ".."));
case 7: /* Return the string representing the directory separator. */
return SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR));
case 8: /* Test the character to see if it matches a separator. */
{
int e = get_C_int(mdTaskData, DEREFWORDHANDLE(args));
if (ISPATHSEPARATOR(e))
return Make_arbitrary_precision(mdTaskData, 1);
else return Make_arbitrary_precision(mdTaskData, 0);
}
case 9: /* Are names case-sensitive? */
#if (defined(_WIN32) && ! defined(__CYGWIN__))
/* Windows - no. */
return Make_arbitrary_precision(mdTaskData, 0);
#else
/* Unix - yes. */
return Make_arbitrary_precision(mdTaskData, 1);
#endif
// These are no longer used. The code is handled entirely in ML.
case 10: /* Are empty arcs redundant? */
/* Unix and Windows - yes. */
return Make_arbitrary_precision(mdTaskData, 1);
case 11: /* Match the volume name part of a path. */
{
const TCHAR *volName = NULL;
int isAbs = 0;
int toRemove = 0;
PolyWord path = DEREFHANDLE(args);
/* This examines the start of a string and determines
how much of it represents the volume name and returns
the number of characters to remove, the volume name
and whether it is absolute.
One would assume that if there is a volume name then it
is absolute but there is a peculiar form in Windows/DOS
(e.g. A:b\c) which means the file b\c relative to the
currently selected directory on the volume A.
*/
#if (defined(_WIN32) && ! defined(__CYGWIN__))
TempString buff(path);
if (buff == 0) raise_syscall(mdTaskData, "Insufficient memory", ENOMEM);
size_t length = _tcslen(buff);
if (length >= 2 && buff[1] == ':')
{ /* Volume name? */
if (length >= 3 && ISPATHSEPARATOR(buff[2]))
{
/* Absolute path. */
toRemove = 3; isAbs = 1;
}
else { toRemove = 2; isAbs = 0; }
volName = buff; buff[2] = '\0';
}
else if (length > 3 &&
ISPATHSEPARATOR(buff[0]) &&
ISPATHSEPARATOR(buff[1]) &&
! ISPATHSEPARATOR(buff[2]))
{ /* UNC name? */
int i;
/* Skip the server name. */
for (i = 3; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++);
if (ISPATHSEPARATOR(buff[i]))
{
i++;
/* Skip the share name. */
for (; buff[i] != 0 && !ISPATHSEPARATOR(buff[i]); i++);
toRemove = i;
if (buff[i] != 0) toRemove++;
isAbs = 1;
volName = buff;
buff[i] = '\0';
}
}
else if (ISPATHSEPARATOR(buff[0]))
/* \a\b strictly speaking is relative to the
current drive. It's much easier to treat it
as absolute. */
{ toRemove = 1; isAbs = 1; volName = _T(""); }
#else
/* Unix - much simpler. */
char toTest = 0;
if (IS_INT(path)) toTest = UNTAGGED(path);
else {
PolyStringObject * ps = (PolyStringObject *)path.AsObjPtr();
if (ps->length > 1) toTest = ps->chars[0];
}
if (ISPATHSEPARATOR(toTest))
{ toRemove = 1; isAbs = 1; volName = ""; }
#endif
/* Construct the result. */
{
Handle sVol = SAVE(C_string_to_Poly(mdTaskData, volName));
Handle sRes = ALLOC(3);
DEREFWORDHANDLE(sRes)->Set(0, TAGGED(toRemove));
DEREFHANDLE(sRes)->Set(1, DEREFWORDHANDLE(sVol));
DEREFWORDHANDLE(sRes)->Set(2, TAGGED(isAbs));
return sRes;
}
}
case 12: /* Construct a name from a volume and whether it is
absolute. */
{
unsigned isAbs = get_C_unsigned(mdTaskData, DEREFHANDLE(args)->Get(1));
PolyWord volName = DEREFHANDLE(args)->Get(0);
/* In Unix the volume name will always be empty. */
if (isAbs == 0)
return SAVE(volName);
/* N.B. The arguments to strconcatc are in reverse. */
else return strconcatc(mdTaskData,
SAVE(C_string_to_Poly(mdTaskData, DEFAULTSEPARATOR)),
SAVE(volName));
}
case 13: /* Is the string a valid file name? */
{
PolyWord volName = DEREFWORD(args);
// First check for NULL. This is not allowed in either Unix or Windows.
if (IS_INT(volName))
{
if (volName == TAGGED(0))
return Make_arbitrary_precision(mdTaskData, 0);
}
else
{
PolyStringObject * volume = (PolyStringObject *)(volName.AsObjPtr());
for (POLYUNSIGNED i = 0; i < volume->length; i++)
{
if (volume->chars[i] == '\0')
return Make_arbitrary_precision(mdTaskData, 0);
}
}
#if (defined(_WIN32) && ! defined(__CYGWIN__))
// We need to look for certain invalid characters but only after
// we've converted it to Unicode if necessary.
TempString name(volName);
for (const TCHAR *p = name; *p != 0; p++)
{
switch (*p)
{
case '<': case '>': case ':': case '"':
case '\\': case '|': case '?': case '*': case '\0':
#if (0)
// This currently breaks the build.
case '/':
#endif
return Make_arbitrary_precision(mdTaskData, 0);
}
if (*p >= 0 && *p <= 31) return Make_arbitrary_precision(mdTaskData, 0);
}
// Should we check for special names such as aux, con, prn ??
return Make_arbitrary_precision(mdTaskData, 1);
#else
// That's all we need for Unix.
// TODO: Check for /. It's invalid in a file name arc.
return Make_arbitrary_precision(mdTaskData, 1);
#endif
}
// A group of calls have now been moved to poly_specific.
// This entry is returned for backwards compatibility.
case 100: case 101: case 102: case 103: case 104: case 105:
return poly_dispatch_c(mdTaskData, args, code);
default:
{
char msg[100];
sprintf(msg, "Unknown environment function: %d", c);
raise_exception_string(mdTaskData, EXC_Fail, msg);
return 0;
}
}
}
Handle RenameParent(TaskData *taskData, Handle args)
// Change the name of the immediate parent stored in a child
{
TCHAR fileNameBuff[MAXPATHLEN], parentNameBuff[MAXPATHLEN];
// The name of the file to modify.
POLYUNSIGNED fileLength =
Poly_string_to_C(DEREFHANDLE(args)->Get(0), fileNameBuff, MAXPATHLEN);
if (fileLength > MAXPATHLEN)
raise_syscall(taskData, "File name too long", ENAMETOOLONG);
// The new parent name to insert.
POLYUNSIGNED parentLength =
Poly_string_to_C(DEREFHANDLE(args)->Get(1), parentNameBuff, MAXPATHLEN);
if (parentLength > MAXPATHLEN)
raise_syscall(taskData, "Parent name too long", ENAMETOOLONG);
AutoClose loadFile(_tfopen(fileNameBuff, _T("r+b"))); // Open for reading and writing
if ((FILE*)loadFile == NULL)
{
char buff[MAXPATHLEN+1+23];
#if (defined(_WIN32) && defined(UNICODE))
sprintf(buff, "Cannot open load file: %S", fileNameBuff);
#else
sprintf(buff, "Cannot open load file: %s", fileNameBuff);
#endif
raise_syscall(taskData, buff, errno);
}
SavedStateHeader header;
// Read the header and check the signature.
if (fread(&header, sizeof(SavedStateHeader), 1, loadFile) != 1)
raise_fail(taskData, "Unable to load header");
if (strncmp(header.headerSignature, SAVEDSTATESIGNATURE, sizeof(header.headerSignature)) != 0)
raise_fail(taskData, "File is not a saved state");
if (header.headerVersion != SAVEDSTATEVERSION ||
header.headerLength != sizeof(SavedStateHeader) ||
header.segmentDescrLength != sizeof(SavedStateSegmentDescr))
{
raise_fail(taskData, "Unsupported version of saved state file");
}
// Does this actually have a parent?
if (header.parentNameEntry == 0)
raise_fail(taskData, "File does not have a parent");
// At the moment the only entry in the string table is the parent
// name so we can simply write a new one on the end of the file.
// This makes the file grow slightly each time but it shouldn't be
// significant.
fseek(loadFile, 0, SEEK_END);
header.stringTable = ftell(loadFile); // Remember where this is
_fputtc(0, loadFile); // First byte of string table is zero
_fputts(parentNameBuff, loadFile);
_fputtc(0, loadFile); // A terminating null.
header.stringTableSize = (_tcslen(parentNameBuff) + 2)*sizeof(TCHAR);
// Now rewind and write the header with the revised string table.
fseek(loadFile, 0, SEEK_SET);
fwrite(&header, sizeof(header), 1, loadFile);
return SAVE(TAGGED(0));
}
Handle poly_ffi(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, code->Word());
switch (c)
{
case 0: // malloc
{
POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word());
return toSysWord(taskData, malloc(size));
}
case 1: // free
{
void *mem = *(void**)(args->WordP());
free(mem);
return taskData->saveVec.push(TAGGED(0));
}
case 2: // Load library
{
TempString libName(args->Word());
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HINSTANCE lib = LoadLibrary(libName);
if (lib == NULL)
{
char buf[256];
#if (defined(UNICODE))
_snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", libName, GetLastError());
#else
_snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", libName, GetLastError());
#endif
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = dlopen(libName, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char *)libName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 3: // Load address of executable.
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HINSTANCE lib = hApplicationInstance;
#else
void *lib = dlopen(NULL, RTLD_LAZY);
if (lib == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, lib);
}
case 4: // Unload library - Is this actually going to be used?
{
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HMODULE hMod = *(HMODULE*)(args->WordP());
if (! FreeLibrary(hMod))
raise_syscall(taskData, "FreeLibrary failed", -(int)GetLastError());
#else
void *lib = *(void**)(args->WordP());
if (dlclose(lib) != 0)
{
char buf[256];
snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return taskData->saveVec.push(TAGGED(0));
}
case 5: // Load the address of a symbol from a library.
{
TempCString symName(args->WordP()->Get(1));
#if (defined(_WIN32) && ! defined(__CYGWIN__))
HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress());
void *sym = (void*)GetProcAddress(hMod, symName);
if (sym == NULL)
{
char buf[256];
_snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", symName, GetLastError());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#else
void *lib = *(void**)(args->WordP()->Get(0).AsAddress());
void *sym = dlsym(lib, symName);
if (sym == NULL)
{
char buf[256];
snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char *)symName, dlerror());
buf[sizeof(buf)-1] = 0; // Terminate just in case
raise_exception_string(taskData, EXC_foreign, buf);
}
#endif
return toSysWord(taskData, sym);
}
// Libffi functions
case 50: // Return a list of available ABIs
return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]),
(char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab);
case 51: // A constant from the table
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(constantTable) / sizeof(constantTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return Make_arbitrary_precision(taskData, constantTable[index]);
}
case 52: // Return an FFI type
{
unsigned index = get_C_unsigned(taskData, args->Word());
if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0]))
raise_exception_string(taskData, EXC_foreign, "Index out of range");
return toSysWord(taskData, ffiTypeTable[index]);
}
case 53: // Extract fields from ffi type.
{
ffi_type *ffit = *(ffi_type**)(args->WordP());
Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size);
Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment);
Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type);
Handle elemHandle = toSysWord(taskData, ffit->elements);
Handle resHandle = alloc_and_save(taskData, 4);
resHandle->WordP()->Set(0, sizeHandle->Word());
resHandle->WordP()->Set(1, alignHandle->Word());
resHandle->WordP()->Set(2, typeHandle->Word());
resHandle->WordP()->Set(3, elemHandle->Word());
return resHandle;
}
case 54: // Construct an ffi type.
{
// This is probably only used to create structs.
size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0));
unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1));
unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2));
unsigned nElems = 0;
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nElems++;
size_t space = sizeof(ffi_type);
// If we need the elements add space for the elements plus
// one extra for the zero terminator.
if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *);
ffi_type *result = (ffi_type*)malloc(space);
// Raise an exception rather than returning zero.
if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **elem = 0;
if (nElems != 0) elem = (ffi_type **)(result+1);
memset(result, 0, sizeof(ffi_type)); // Zero it in case they add fields
result->size = size;
result->alignment = align;
result->type = type;
result->elements = elem;
if (elem != 0)
{
for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*elem++ = *(ffi_type**)(e.AsAddress());
}
*elem = 0;
}
return toSysWord(taskData, result);
}
case 55: // Create a CIF. This contains all the types and some extra information.
// The result is in allocated memory followed immediately by the argument type vector.
{
ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0));
ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress();
unsigned nArgs = 0;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
nArgs++;
// Allocate space for the cif followed by the argument type vector
size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*);
ffi_cif *cif = (ffi_cif *)malloc(space);
if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM);
ffi_type **atypes = (ffi_type **)(cif+1);
// Copy the arguments types.
ffi_type **at = atypes;
for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t)
{
PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h;
*at++ = *(ffi_type**)(e.AsAddress());
}
ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes);
if (status == FFI_BAD_TYPEDEF)
raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif");
else if (status == FFI_BAD_ABI)
raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif");
else if (status != FFI_OK)
raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif");
return toSysWord(taskData, cif);
}
case 56: // Call a function.
{
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress();
void *f = *(void**)args->WordP()->Get(1).AsAddress();
void *res = *(void**)args->WordP()->Get(2).AsAddress();
void **arg = *(void***)args->WordP()->Get(3).AsAddress();
// We release the ML memory across the call so a GC can occur
// even if this thread is blocked in the C code.
processes->ThreadReleaseMLMemory(taskData);
ffi_call(cif, FFI_FN(f), res, arg);
processes->ThreadUseMLMemory(taskData);
return taskData->saveVec.push(TAGGED(0));
}
case 57: // Create a callback.
{
#ifdef INTERPRETED
raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter");
#endif
Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0));
ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress();
void *resultFunction;
// Allocate the memory. resultFunction is set to the executable address in or related to
// the memory.
ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction);
if (closure == 0)
raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory");
PLocker pLocker(&callbackTableLock);
// Find a free entry in the table if there is one.
unsigned entryNo = 0;
while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++;
if (entryNo == callBackEntries)
{
// Need to grow the table.
struct _cbStructEntry *newTable =
(struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry));
if (newTable == 0)
raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table");
callbackTable = newTable;
callBackEntries++;
}
callbackTable[entryNo].mlFunction = mlFunction->Word();
callbackTable[entryNo].closureSpace = closure;
callbackTable[entryNo].resultFunction = resultFunction;
if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK)
raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed");
return toSysWord(taskData, resultFunction);
}
case 58: // Free an existing callback.
{
// The address returned from call 57 above is the executable address that can
// be passed as a callback function. The writable memory address returned
// as the result of ffi_closure_alloc may or may not be the same. To be safe
// we need to search the table.
void *resFun = *(void**)args->Word().AsAddress();
PLocker pLocker(&callbackTableLock);
unsigned i = 0;
while (i < callBackEntries)
{
if (callbackTable[i].resultFunction == resFun)
{
ffi_closure_free(callbackTable[i].closureSpace);
callbackTable[i].closureSpace = 0;
callbackTable[i].resultFunction = 0;
callbackTable[i].mlFunction = TAGGED(0); // Release the ML function
return taskData->saveVec.push(TAGGED(0));
}
}
raise_exception_string(taskData, EXC_foreign, "Invalid callback entry");
}
default:
{
char msg[100];
sprintf(msg, "Unknown ffi function: %d", c);
raise_exception_string(taskData, EXC_foreign, msg);
return 0;
}
}
}
Handle poly_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORDHANDLE(code));
switch (c)
{
case 1:
return exportNative(taskData, args); // Export
case 2:
raise_syscall(taskData, "C Export has been withdrawn", 0);
return 0;
case 3:
return exportPortable(taskData, args); // Export as portable format
case 9: // Return the GIT version if appropriate
{
return SAVE(C_string_to_Poly(taskData, GitVersion));
}
case 10: // Return the RTS version string.
{
const char *version;
switch (machineDependent->MachineArchitecture())
{
case MA_Interpreted: version = "Portable-" TextVersion; break;
case MA_I386: version = "I386-" TextVersion; break;
case MA_X86_64: version = "X86_64-" TextVersion; break;
default: version = "Unknown-" TextVersion; break;
}
return SAVE(C_string_to_Poly(taskData, version));
}
case 11: // Return the RTS copyright string
return SAVE(C_string_to_Poly(taskData, poly_runtime_system_copyright));
case 12: // Return the architecture
{
const char *arch;
switch (machineDependent->MachineArchitecture())
{
case MA_Interpreted: arch = "Interpreted"; break;
case MA_I386: arch = "I386"; break;
case MA_X86_64: arch = "X86_64"; break;
default: arch = "Unknown"; break;
}
return SAVE(C_string_to_Poly(taskData, arch));
}
case 13: // Share common immutable data.
{
ShareData(taskData, args);
return SAVE(TAGGED(0));
}
// ObjSize and ShowSize have their own IO vector entries but really they don't
// need them. Include them here and add ObjProfile.
case 14:
return ObjSize(taskData, args);
case 15:
return ShowSize(taskData, args);
case 16:
return ObjProfile(taskData, args);
/* 17 and 18 are no longer used. */
case 19: // Return the RTS argument help string.
return SAVE(C_string_to_Poly(taskData, RTSArgHelp()));
case 20: // Write a saved state file.
return SaveState(taskData, args);
case 21: // Load a saved state file and any ancestors.
return LoadState(taskData, false, args);
case 22: // Show the hierarchy.
return ShowHierarchy(taskData);
case 23: // Change the name of the immediate parent stored in a child
return RenameParent(taskData, args);
case 24: // Return the name of the immediate parent stored in a child
return ShowParent(taskData, args);
case 25: // Old statistics - now removed
case 26:
raise_exception_string(taskData, EXC_Fail, "No statistics available");
case 27: // Get number of user statistics available
return Make_arbitrary_precision(taskData, N_PS_USER);
case 28: // Set an entry in the user stats table.
{
unsigned index = get_C_unsigned(taskData, DEREFHANDLE(args)->Get(0));
if (index >= N_PS_USER)
raise_exception0(taskData, EXC_subscript);
POLYSIGNED value = getPolySigned(taskData, DEREFHANDLE(args)->Get(1));
globalStats.setUserCounter(index, value);
Make_arbitrary_precision(taskData, 0);
}
case 29: // Get local statistics.
return globalStats.getLocalStatistics(taskData);
case 30: // Get remote statistics. The argument is the process ID to get the statistics.
return globalStats.getRemoteStatistics(taskData, getPolyUnsigned(taskData, DEREFHANDLE(args)));
case 31: // Store a module
return StoreModule(taskData, args);
case 32: // Load a module
return LoadModule(taskData, args);
case 33: // Load hierarchy. This provides a complete list of children and parents.
return LoadState(taskData, true, args);
case 34: // Return the system directory for modules. This is configured differently
// in Unix and in Windows.
#if (defined(MODULEDIR))
return SAVE(C_string_to_Poly(taskData, Xstr(MODULEDIR)));
#elif (defined(_WIN32) && ! defined(__CYGWIN__))
{
// This registry key is configured when Poly/ML is installed using the installer.
// It gives the path to the Poly/ML installation directory. We return the
// Modules subdirectory.
HKEY hk;
if (RegOpenKeyEx(HKEY_LOCAL_MACHINE,
_T("SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\App Paths\\PolyML.exe"), 0,
KEY_QUERY_VALUE, &hk) == ERROR_SUCCESS)
{
DWORD valSize;
if (RegQueryValueEx(hk, _T("Path"), 0, NULL, NULL, &valSize) == ERROR_SUCCESS)
{
#define MODULEDIR _T("Modules")
TempString buff((TCHAR*)malloc(valSize + (_tcslen(MODULEDIR) + 1)*sizeof(TCHAR)));
DWORD dwType;
if (RegQueryValueEx(hk, _T("Path"), 0, &dwType, (LPBYTE)(LPTSTR)buff, &valSize) == ERROR_SUCCESS)
{
RegCloseKey(hk);
// The registry entry should end with a backslash.
_tcscat(buff, MODULEDIR);
return SAVE(C_string_to_Poly(taskData, buff));
}
}
RegCloseKey(hk);
}
return SAVE(C_string_to_Poly(taskData, ""));
}
#else
return SAVE(C_string_to_Poly(taskData, ""));
#endif
case 50: // GCD
return gcd_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1)));
case 51: // LCM
return lcm_arbitrary(taskData, SAVE(DEREFHANDLE(args)->Get(0)), SAVE(DEREFHANDLE(args)->Get(1)));
// These next ones were originally in process_env and have now been moved here,
case 100: /* Return the maximum word segment size. */
return taskData->saveVec.push(TAGGED(MAX_OBJECT_SIZE));
case 101: /* Return the maximum string size (in bytes).
It is the maximum number of bytes in a segment
less one word for the length field. */
return taskData->saveVec.push(TAGGED((MAX_OBJECT_SIZE)*sizeof(PolyWord) - sizeof(PolyWord)));
case 102: /* Test whether the supplied address is in the io area.
This was previously done by having get_flags return
256 but this was changed so that get_flags simply
returns the top byte of the length word. */
{
PolyWord *pt = (PolyWord*)DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
return Make_arbitrary_precision(taskData, 1);
else return Make_arbitrary_precision(taskData, 0);
}
case 103: /* Return the register mask for the given function.
This is used by the code-generator to find out
which registers are modified by the function and
so need to be saved if they are used by the caller. */
{
PolyObject *pt = DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
{
/* IO area. We need to get this from the vector. */
int i;
for (i=0; i < POLY_SYS_vecsize; i++)
{
if (pt == (PolyObject*)IoEntry(i))
{
int regMask = taskData->GetIOFunctionRegisterMask(i);
POLYUNSIGNED props = rtsProperties(taskData, i);
return taskData->saveVec.push(TAGGED(regMask | props));
}
}
raise_exception_string(taskData, EXC_Fail, "Io pointer not found");
}
else
{
/* We may have a pointer to the code or a pointer to
a closure. If it's a closure we have to find the
code. */
if (! pt->IsCodeObject() && ! pt->IsByteObject())
pt = pt->Get(0).AsObjPtr();
/* Should now be a code object. */
if (pt->IsCodeObject())
{
/* Compiled code. This is the second constant in the
constant area. */
PolyWord *codePt = pt->ConstPtrForCode();
PolyWord mask = codePt[1];
// A real mask will be an integer.
if (IS_INT(mask)) return SAVE(mask);
else raise_exception_string(taskData, EXC_Fail, "Invalid mask");
}
else raise_exception_string(taskData, EXC_Fail, "Not a code pointer");
}
}
case 104: return Make_arbitrary_precision(taskData, POLY_version_number);
case 105: /* Get the name of the function. */
{
PolyObject *pt = DEREFWORDHANDLE(args);
if (gMem.IsIOPointer(pt))
{
/* IO area. */
int i;
for (i=0; i < POLY_SYS_vecsize; i++)
{
if (pt == (PolyObject*)IoEntry(i))
{
char buff[8];
sprintf(buff, "RTS%d", i);
return SAVE(C_string_to_Poly(taskData, buff));
}
}
raise_syscall(taskData, "Io pointer not found", 0);
}
else if (pt->IsCodeObject()) /* Should now be a code object. */
{
/* Compiled code. This is the first constant in the constant area. */
PolyWord *codePt = pt->ConstPtrForCode();
PolyWord name = codePt[0];
/* May be zero indicating an anonymous segment - return null string. */
if (name == PolyWord::FromUnsigned(0))
return SAVE(C_string_to_Poly(taskData, ""));
else return SAVE(name);
}
else raise_syscall(taskData, "Not a code pointer", 0);
}
default:
{
char msg[100];
sprintf(msg, "Unknown poly-specific function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}
static Handle simpleExecute(TaskData *taskData, Handle args)
{
HANDLE hNull = INVALID_HANDLE_VALUE;
PROCESS_INFORMATION processInfo;
Handle handToken;
PHANDLETAB pTab;
TCHAR *commandName = Poly_string_to_T_alloc(args->WordP()->Get(0));
TCHAR *arguments = Poly_string_to_T_alloc(args->WordP()->Get(1));
STARTUPINFO startupInfo;
// Open a handle to NUL for input and output.
hNull = CreateFile(_T("NUL"), GENERIC_READ|GENERIC_WRITE,
FILE_SHARE_READ|FILE_SHARE_WRITE, NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, NULL);
// Create a STARTUPINFO structure in which to pass hNULL as stdin
// and stdout to the new process.
memset(&startupInfo, 0, sizeof(startupInfo));
startupInfo.cb = sizeof(startupInfo);
startupInfo.dwFlags = STARTF_USESTDHANDLES;
startupInfo.hStdInput = hNull;
startupInfo.hStdOutput = hNull;
startupInfo.hStdError = hNull;
STARTUPINFO *start = &startupInfo;
// Treat the empty string as NULL. This is non-standard.
if (!CreateProcess(commandName[0] == 0 ? NULL : commandName,
arguments[0] == 0 ? NULL : arguments, // Command line
NULL, NULL, // Security attributes
TRUE, CREATE_NO_WINDOW, // Inherit handles, creation flags
NULL, NULL, // Inherit our environment and directory
start,
&processInfo)) {
int nErr = GetLastError();
// Clean up
free(commandName);
free(arguments);
CloseHandle(hNull);
raise_syscall(taskData, "CreateProcess failed", -nErr);
}
free(commandName);
free(arguments);
/* Close thread handle since we don't need it. */
CloseHandle(processInfo.hThread);
#ifndef _WIN32_WCE
CloseHandle(hNull); // We no longer need this
#endif
handToken = make_handle_entry(taskData);
pTab = &handleTable[STREAMID(handToken)];
pTab->entryType = HE_PROCESS;
pTab->entry.process.hProcess = processInfo.hProcess;
// We only use the process handle entry.
pTab->entry.process.hInput = INVALID_HANDLE_VALUE;
pTab->entry.process.hOutput = INVALID_HANDLE_VALUE;
pTab->entry.process.hEvent = NULL;
pTab->entry.process.readToken = 0;
pTab->entry.process.writeToken = 0;
return(handToken);
}
/*
The Windows version of this is more complicated than the Unix version because
we can't manipulate the pipe handles in the child process. Everything has to be
set up in the parent. As with Unix we create two pipes and pass one end of each
pipe to the child. The end we pass to the child is "inheritable" (i.e. duplicated
in the child as with Unix file descriptors) while the ends we keep in the parent
are non-inheritable (i.e. not duplicated in the child).
DCJM: December 1999.
This is now further complicated to improve the performance. In Unix we can pass
the file ID to "select" which will return immediately when input is available (we
ignore blocking on output at the moment). That allows the ML process to respond
immediately. There's no easy way to do that in Windows since the pipe handle is
signalled whether there is input available or not. One possibility would be to
use overlapped IO but that requires using the ReadFile call directly and some
contortions to create a pipe with overlapped IO. The other, taken here, is to
interpose a thread which can signal an event when input is available.
*/
static Handle execute(TaskData *taskData, Handle args)
{
LPCSTR lpszError = "";
HANDLE hWriteToChild = INVALID_HANDLE_VALUE,
hReadFromParent = INVALID_HANDLE_VALUE,
hWriteToParent = INVALID_HANDLE_VALUE,
hReadFromChild = INVALID_HANDLE_VALUE;
HANDLE hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
HANDLE hTemp;
STARTUPINFO startupInfo;
PROCESS_INFORMATION processInfo;
Handle handToken = make_handle_entry(taskData);
PHANDLETAB pTab = &handleTable[STREAMID(handToken)];
LPTSTR commandName = Poly_string_to_T_alloc(args->WordP()->Get(0));
LPTSTR arguments = Poly_string_to_T_alloc(args->WordP()->Get(1));
// Create pipes for connection. Setting the security argument to NULL creates
// the pipe handles as non-inheritable. We have to make sure that the
// child process does not inherit handles for the parent end of the
// connection otherwise the pipe will remain open after the parent has
// closed its end, causing the child process to sit around even after
// the parent process has gone away.
if (!CreatePipe(&hReadFromParent, &hWriteToChild, NULL, 0)) {
lpszError = "Could not create pipe";
goto error;
}
if (!CreatePipe(&hReadFromChild, &hWriteToParent, NULL, 0)) {
lpszError = "Could not create pipe";
goto error;
}
// Create the copying thread.
hTemp = CreateCopyPipe(hReadFromChild, hEvent);
if (hTemp == NULL) {
lpszError = "Could not create pipe";
goto error;
}
hReadFromChild = hTemp;
// Convert the handles we want to pass to the child into inheritable
// handles by duplicating and replacing them with the duplicates.
if (! DuplicateHandle(GetCurrentProcess(), hWriteToParent, GetCurrentProcess(),
&hTemp, 0, TRUE, // inheritable
DUPLICATE_SAME_ACCESS )) {
lpszError = "Could not create pipe";
goto error;
}
CloseHandle(hWriteToParent);
hWriteToParent = hTemp;
if (! DuplicateHandle(GetCurrentProcess(), hReadFromParent, GetCurrentProcess(),
&hTemp, 0, TRUE, // inheritable
DUPLICATE_SAME_ACCESS )) {
lpszError = "Could not create pipe";
goto error;
}
CloseHandle(hReadFromParent);
hReadFromParent = hTemp;
// Create a STARTUPINFO structure in which to pass the pipes as stdin
// and stdout to the new process.
memset(&startupInfo, 0, sizeof(startupInfo));
startupInfo.cb = sizeof(startupInfo);
startupInfo.dwFlags = STARTF_USESTDHANDLES;
startupInfo.hStdInput = hReadFromParent;
startupInfo.hStdOutput = hWriteToParent;
// What should we do about the stderr? For the moment, inherit the original.
startupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE);
// Treat the empty string as NULL. This is non-standard.
if (!CreateProcess(commandName[0] == 0 ? NULL: commandName,
arguments[0] == 0 ? NULL: arguments, // Command line
NULL, NULL, TRUE, // Security attributes. Inherit handles
CREATE_NO_WINDOW, // creation flags
NULL, NULL, // Inherit our environment and directory
&startupInfo,
&processInfo)) {
lpszError = "Could not create process";
goto error;
}
free(commandName);
free(arguments);
/* Close thread handle since we don't need it. */
CloseHandle(processInfo.hThread);
/* Close the sides of the pipes we don't use in the parent. */
CloseHandle(hReadFromParent);
CloseHandle(hWriteToParent);
pTab->entryType = HE_PROCESS;
pTab->entry.process.hProcess = processInfo.hProcess;
pTab->entry.process.hInput = hReadFromChild;
pTab->entry.process.hOutput = hWriteToChild;
pTab->entry.process.hEvent = hEvent;
pTab->entry.process.readToken = 0;
pTab->entry.process.writeToken = 0;
return(handToken);
error:
{
int err = GetLastError();
free(commandName);
free(arguments);
// Close all the pipe handles.
if (hWriteToChild != INVALID_HANDLE_VALUE) CloseHandle(hWriteToChild);
if (hReadFromParent != INVALID_HANDLE_VALUE) CloseHandle(hReadFromParent);
if (hWriteToParent != INVALID_HANDLE_VALUE) CloseHandle(hWriteToParent);
if (hReadFromChild != INVALID_HANDLE_VALUE) CloseHandle(hReadFromChild);
if (hEvent) CloseHandle(hEvent);
raise_syscall(taskData, lpszError, -err);
return NULL; // Never reached.
}
}
Handle OS_spec_dispatch_c(TaskData *taskData, Handle args, Handle code)
{
unsigned c = get_C_unsigned(taskData, DEREFWORD(code));
switch (c)
{
case 0: /* Return our OS type. Not in any structure. */
return Make_arbitrary_precision(taskData, 1); /* 1 for Windows. */
/* Windows-specific functions. */
case 1000: /* execute */
return execute(taskData, args);
case 1001: /* Get input stream as text. */
return openProcessHandle(taskData, args, TRUE, TRUE);
case 1002: /* Get output stream as text. */
return openProcessHandle(taskData, args, FALSE, TRUE);
case 1003: /* Get input stream as binary. */
return openProcessHandle(taskData, args, TRUE, FALSE);
case 1004: /* Get output stream as binary. */
return openProcessHandle(taskData, args, FALSE, FALSE);
case 1005: /* Get result of process. */
{
PHANDLETAB hnd = get_handle(DEREFWORD(args), HE_PROCESS);
if (hnd == 0)
raise_syscall(taskData, "Process is closed", EINVAL);
// Close the streams. Either of them may have been
// passed to the stream package.
if (hnd->entry.process.hInput != INVALID_HANDLE_VALUE)
CloseHandle(hnd->entry.process.hInput);
hnd->entry.process.hInput = INVALID_HANDLE_VALUE;
if (hnd->entry.process.hEvent)
CloseHandle(hnd->entry.process.hEvent);
hnd->entry.process.hEvent = NULL;
if (hnd->entry.process.readToken)
{
PIOSTRUCT strm =
get_stream(hnd->entry.process.readToken);
if (strm != NULL) close_stream(strm);
}
hnd->entry.process.readToken = 0;
if (hnd->entry.process.hOutput != INVALID_HANDLE_VALUE)
CloseHandle(hnd->entry.process.hOutput);
hnd->entry.process.hOutput = INVALID_HANDLE_VALUE;
if (hnd->entry.process.writeToken)
{
PIOSTRUCT strm =
get_stream(hnd->entry.process.writeToken);
if (strm != NULL) close_stream(strm);
}
hnd->entry.process.writeToken = 0;
// See if it's finished.
while (true) {
DWORD dwResult;
if (GetExitCodeProcess(hnd->entry.process.hProcess, &dwResult) == 0)
raise_syscall(taskData, "GetExitCodeProcess failed",
-(int)GetLastError());
if (dwResult != STILL_ACTIVE) {
/* Finished - return the result. */
/* Note: we haven't closed the handle because we might want to ask
for the result again. We only close it when we've garbage-collected
the token. Doing this runs the risk of running out of handles.
Maybe change it and remember the result in ML. */
return Make_arbitrary_precision(taskData, dwResult);
}
// Block and try again.
WaitHandle waiter(hnd->entry.process.hProcess);
processes->ThreadPauseForIO(taskData, &waiter);
}
}
case 1006: /* Return a constant. */
{
unsigned i = get_C_unsigned(taskData, DEREFWORD(args));
if (i >= sizeof(winConstVec)/sizeof(winConstVec[0]))
raise_syscall(taskData, "Invalid index", 0);
return Make_arbitrary_precision(taskData, winConstVec[i]);
}
/* Registry functions. */
case 1007: // Open a key within one of the roots.
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return openRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1008: // Open a subkey of an opened key.
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return openRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1009: // Create a subkey within one of the roots.
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return createRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1010: // Create a subkey within an opened key.
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return createRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1011: // Close a registry handle.
{
PHANDLETAB hnd = get_handle(DEREFWORD(args), HE_REGISTRY);
if (hnd != 0) close_handle(hnd);
return Make_arbitrary_precision(taskData, 0);
}
case 1012: // Get a value
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return queryRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1013: // Get a value
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return queryRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1014: // Delete a subkey
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return deleteRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1015: // Delete a subkey
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return deleteRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1016: // Set a value
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return setRegistryKey(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1017: // Set a value
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return setRegistryKey(taskData, args, hnd->entry.hKey);
}
case 1018: // Enumerate a key in the predefined keys
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], TRUE);
}
case 1019: // Enumerate a key in an opened key
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return enumerateRegistry(taskData, args, hnd->entry.hKey, TRUE);
}
case 1020: // Enumerate a value in the predefined keys
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return enumerateRegistry(taskData, args, hkPredefinedKeyTab[keyIndex], FALSE);
}
case 1021: // Enumerate a value in an opened key
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return enumerateRegistry(taskData, args, hnd->entry.hKey, FALSE);
}
case 1022: // Delete a value
{
unsigned keyIndex = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(0));
// This should only ever happen as a result of a fault in
// the Windows structure.
if (keyIndex >= sizeof(hkPredefinedKeyTab)/sizeof(hkPredefinedKeyTab[0]))
raise_syscall(taskData, "Invalid index", 0);
return deleteRegistryValue(taskData, args, hkPredefinedKeyTab[keyIndex]);
}
case 1023: // Delete a value
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_REGISTRY);
if (hnd == 0)
raise_syscall(taskData, "Handle is closed", -ERROR_INVALID_HANDLE);
return deleteRegistryValue(taskData, args, hnd->entry.hKey);
}
case 1030: // Convert UTC time values to local time. -- No longer used??
{
FILETIME ftUTC, ftLocal;
/* Get the file time. */
getFileTimeFromArb(taskData, args, &ftUTC);
if (! FileTimeToLocalFileTime(&ftUTC, &ftLocal))
raise_syscall(taskData, "FileTimeToLocalFileTime failed",
-(int)GetLastError());
return Make_arb_from_Filetime(taskData, ftLocal);
}
case 1031: // Convert local time values to UTC. -- No longer used??
{
FILETIME ftUTC, ftLocal;
/* Get the file time. */
getFileTimeFromArb(taskData, args, &ftLocal);
if (! LocalFileTimeToFileTime(&ftLocal, &ftUTC))
raise_syscall(taskData, "LocalFileTimeToFileTime failed",
-(int)GetLastError());
return Make_arb_from_Filetime(taskData, ftUTC);
}
case 1032: // Get volume information.
{
TCHAR rootName[MAX_PATH], volName[MAX_PATH], sysName[MAX_PATH];
DWORD dwVolSerial, dwMaxComponentLen, dwFlags;
Handle volHandle, sysHandle, serialHandle, maxCompHandle;
Handle resultHandle;
POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), rootName, MAX_PATH);
if (length > MAX_PATH)
raise_syscall(taskData, "Root name too long", ENAMETOOLONG);
if (!GetVolumeInformation(rootName, volName, MAX_PATH,
&dwVolSerial, &dwMaxComponentLen, &dwFlags,
sysName, MAX_PATH))
raise_syscall(taskData, "GetVolumeInformation failed",
-(int)GetLastError());
volHandle = SAVE(C_string_to_Poly(taskData, volName));
sysHandle = SAVE(C_string_to_Poly(taskData, sysName));
serialHandle = Make_arbitrary_precision(taskData, dwVolSerial);
maxCompHandle = Make_arbitrary_precision(taskData, dwMaxComponentLen);
resultHandle = alloc_and_save(taskData, 4);
DEREFHANDLE(resultHandle)->Set(0, DEREFWORDHANDLE(volHandle));
DEREFHANDLE(resultHandle)->Set(1, DEREFWORDHANDLE(sysHandle));
DEREFHANDLE(resultHandle)->Set(2, DEREFWORDHANDLE(serialHandle));
DEREFHANDLE(resultHandle)->Set(3, DEREFWORDHANDLE(maxCompHandle));
return resultHandle;
}
case 1033:
{
TCHAR fileName[MAX_PATH], execName[MAX_PATH];
POLYUNSIGNED length = Poly_string_to_C(DEREFWORD(args), fileName, MAX_PATH);
HINSTANCE hInst;
if (length > MAX_PATH)
raise_syscall(taskData, "File name too long", ENAMETOOLONG);
hInst = FindExecutable(fileName, NULL, execName);
if ((POLYUNSIGNED)hInst <= 32)
{
raise_syscall(taskData, "FindExecutable failed", -(int)(POLYUNSIGNED)hInst);
}
return SAVE(C_string_to_Poly(taskData, execName));
}
case 1034: // Open a document
{
SHELLEXECUTEINFO shellEx;
memset(&shellEx, 0, sizeof(shellEx));
shellEx.cbSize = sizeof(shellEx);
shellEx.lpVerb = _T("open");
shellEx.lpFile = Poly_string_to_T_alloc(DEREFWORD(args));
shellEx.hwnd = hMainWindow;
shellEx.nShow = SW_SHOWNORMAL;
BOOL fRes = ShellExecuteEx(&shellEx);
free((void*)shellEx.lpFile);
if (! fRes)
raise_syscall(taskData, "ShellExecuteEx failed", 0-GetLastError());
return Make_arbitrary_precision(taskData, 0);
}
case 1035: // Launch an application.
{
SHELLEXECUTEINFO shellEx;
memset(&shellEx, 0, sizeof(shellEx));
shellEx.cbSize = sizeof(shellEx);
shellEx.lpVerb = _T("open");
shellEx.lpFile = Poly_string_to_T_alloc(args->WordP()->Get(0));
shellEx.lpParameters = Poly_string_to_T_alloc(args->WordP()->Get(1));
shellEx.nShow = SW_SHOWNORMAL;
BOOL fRes = ShellExecuteEx(&shellEx);
free((void*)shellEx.lpFile);
free((void*)shellEx.lpParameters);
if (! fRes)
raise_syscall(taskData, "ShellExecuteEx failed", 0-GetLastError());
return Make_arbitrary_precision(taskData, 0);
}
case 1036: // Does the process have its own console?
return Make_arbitrary_precision(taskData, hMainWindow != NULL ? 1: 0);
case 1037: // Simple execute.
return simpleExecute(taskData, args);
// DDE
case 1038: // Start DDE dialogue.
{
Handle handToken;
PHANDLETAB pTab;
HCONV hcDDEConv;
TCHAR *serviceName = Poly_string_to_T_alloc(args->WordP()->Get(0));
TCHAR *topicName = Poly_string_to_T_alloc(args->WordP()->Get(1));
/* Send a request to the main thread to do the work. */
hcDDEConv = StartDDEConversation(serviceName, topicName);
free(serviceName); free(topicName);
if (hcDDEConv == 0) raise_syscall(taskData, "DdeConnect failed", 0);
// Create an entry to return the conversation.
handToken = make_handle_entry(taskData);
pTab = &handleTable[STREAMID(handToken)];
pTab->entryType = HE_DDECONVERSATION;
pTab->entry.hcDDEConv = hcDDEConv;
return handToken;
}
case 1039: // Send DDE execute request.
{
PHANDLETAB hnd =
get_handle(DEREFHANDLE(args)->Get(0), HE_DDECONVERSATION);
LRESULT res;
char *command;
if (hnd == NULL)
{
raise_syscall(taskData, "DDE Conversation is closed", 0);
}
command = Poly_string_to_C_alloc(args->WordP()->Get(1));
/* Send a request to the main thread to do the work. */
res = ExecuteDDE(command, hnd->entry.hcDDEConv);
free(command);
if (res == -1) raise_syscall(taskData, "DdeClientTransaction failed", 0);
else return Make_arbitrary_precision(taskData, res);
}
case 1040: // Close a DDE conversation.
{
PHANDLETAB hnd = get_handle(args->Word(), HE_DDECONVERSATION);
if (hnd != 0) close_handle(hnd);
return Make_arbitrary_precision(taskData, 0);
}
// Configuration functions.
case 1050: // Get version data
{
OSVERSIONINFO osver;
ZeroMemory(&osver, sizeof(OSVERSIONINFO));
osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
// GetVersionEx is deprecated in Windows 8.1
if (! GetVersionEx(&osver))
raise_syscall(taskData, "GetVersionEx failed", -(int)GetLastError());
Handle major = Make_arbitrary_precision(taskData, osver.dwMajorVersion);
Handle minor = Make_arbitrary_precision(taskData, osver.dwMinorVersion);
Handle build = Make_arbitrary_precision(taskData, osver.dwBuildNumber);
Handle platform = Make_arbitrary_precision(taskData, osver.dwPlatformId);
Handle version = SAVE(C_string_to_Poly(taskData, osver.szCSDVersion));
Handle resVal = alloc_and_save(taskData, 5);
DEREFHANDLE(resVal)->Set(0, DEREFWORDHANDLE(major));
DEREFHANDLE(resVal)->Set(1, DEREFWORDHANDLE(minor));
DEREFHANDLE(resVal)->Set(2, DEREFWORDHANDLE(build));
DEREFHANDLE(resVal)->Set(3, DEREFWORDHANDLE(platform));
DEREFHANDLE(resVal)->Set(4, DEREFWORDHANDLE(version));
return resVal;
}
case 1051: // Get windows directory
{
TCHAR path[MAX_PATH+1];
if (GetWindowsDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0)
raise_syscall(taskData, "GetWindowsDirectory failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, path));
}
case 1052: // Get system directory
{
TCHAR path[MAX_PATH+1];
if (GetSystemDirectory(path, sizeof(path)/sizeof(TCHAR)) == 0)
raise_syscall(taskData, "GetSystemDirectory failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, path));
}
case 1053: // Get computer name
{
TCHAR name[MAX_COMPUTERNAME_LENGTH +1];
DWORD dwSize = MAX_COMPUTERNAME_LENGTH +1;
if (GetComputerName(name, &dwSize) == 0)
raise_syscall(taskData, "GetComputerName failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, name));
}
case 1054: // Get user name
{
TCHAR name[UNLEN +1];
DWORD dwSize = UNLEN +1;
if (GetUserName(name, &dwSize) == 0)
raise_syscall(taskData, "GetUserName failed", -(int)GetLastError());
return SAVE(C_string_to_Poly(taskData, name));
}
case 1100: // Get the error result from the last call.
// This is saved when we make a call to a foreign function.
{
return(SAVE(TAGGED(taskData->lastError)));
}
case 1101: // Wait for a message.
{
HWND hwnd = *(HWND*)(DEREFWORDHANDLE(args)->Get(0).AsCodePtr());
UINT wMsgFilterMin = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(1));
UINT wMsgFilterMax = get_C_unsigned(taskData, DEREFWORDHANDLE(args)->Get(2));
while (1)
{
MSG msg;
processes->ThreadReleaseMLMemory(taskData);
// N.B. PeekMessage may directly call the window proc resulting in a
// callback to ML. For this to work a callback must not overwrite "args".
BOOL result = PeekMessage(&msg, hwnd, wMsgFilterMin, wMsgFilterMax, PM_NOREMOVE);
processes->ThreadUseMLMemory(taskData);
if (result) return Make_arbitrary_precision(taskData, 0);
// Pause until a message arrives.
processes->ThreadPause(taskData);
}
}
// case 1102: // Return the address of the window callback function.
case 1103: // Return the application instance.
{
Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ);
*(HINSTANCE*)(result->Word().AsCodePtr()) = hApplicationInstance;
return result;
}
case 1104: // Return the main window handle
{
Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ);
*(HWND*)(result->Word().AsCodePtr()) = hMainWindow;
return result;
}
// case 1105: // Set the callback function
default:
{
char msg[100];
sprintf(msg, "Unknown windows-specific function: %d", c);
raise_exception_string(taskData, EXC_Fail, msg);
return 0;
}
}
}