// Convert the statistics into ML data. This is further unpicked within ML.
static Handle unpackStats(TaskData *taskData, const polystatistics *stats)
{
// Vector for the counts. Initially created as mutable then locked.
Handle counts = alloc_and_save(taskData, N_PS_COUNTERS, F_MUTABLE_BIT);
for (unsigned i = 0; i < N_PS_COUNTERS; i++)
{
Handle mark = taskData->saveVec.mark();
Handle counterValue = Make_arbitrary_precision(taskData, stats->psCounters[i]);
counts->WordP()->Set(i, counterValue->Word());
taskData->saveVec.reset(mark);
}
// Can now lock the count vector by removing the mutable flag.
counts->WordP()->SetLengthWord(N_PS_COUNTERS);
// Vector for the sizes.
Handle sizes = alloc_and_save(taskData, N_PS_SIZES, F_MUTABLE_BIT);
for (unsigned j = 0; j < N_PS_SIZES; j++)
{
Handle mark = taskData->saveVec.mark();
Handle sizeValue = Make_arbitrary_precision(taskData, stats->psSizes[j]);
sizes->WordP()->Set(j, sizeValue->Word());
taskData->saveVec.reset(mark);
}
sizes->WordP()->SetLengthWord(N_PS_SIZES);
// Vector for the times.
Handle times = alloc_and_save(taskData, N_PS_TIMES, F_MUTABLE_BIT);
for (unsigned k = 0; k < N_PS_TIMES; k++)
{
Handle mark = taskData->saveVec.mark();
#ifdef HAVE_WINDOWS_H
Handle sizeValue = Make_arb_from_Filetime(taskData, stats->psTimers[k]);
#else
Handle sizeValue =
Make_arb_from_pair_scaled(taskData, stats->psTimers[k].tv_sec, stats->psTimers[k].tv_usec, 1000000);
#endif
times->WordP()->Set(k, sizeValue->Word());
taskData->saveVec.reset(mark);
}
times->WordP()->SetLengthWord(N_PS_TIMES);
// Vector for the user stats
Handle users = alloc_and_save(taskData, N_PS_USER, F_MUTABLE_BIT);
for (unsigned l = 0; l < N_PS_USER; l++)
{
Handle mark = taskData->saveVec.mark();
Handle userValue = Make_arbitrary_precision(taskData, stats->psUser[l]);
users->WordP()->Set(l, userValue->Word());
taskData->saveVec.reset(mark);
}
users->WordP()->SetLengthWord(N_PS_USER);
// Result vector
Handle resultVec = alloc_and_save(taskData, 4);
resultVec->WordP()->Set(0, counts->Word());
resultVec->WordP()->Set(1, sizes->Word());
resultVec->WordP()->Set(2, times->Word());
resultVec->WordP()->Set(3, users->Word());
return resultVec;
}
/* convert_string_list return a list of strings. */
Handle convert_string_list(TaskData *mdTaskData, int count, char **strings)
{
Handle saved = mdTaskData->saveVec.mark();
Handle list = SAVE(ListNull);
/* It's simplest to process the strings in reverse order */
for (int i = count - 1; 0 <= i; i--)
{
/*
The order of these declarations is important, becaue we don't
want to have make to make the cons cell mutable. This is only
safe if we promise to initialise it fully before the next
ML heap allocation. SPF 29/11/96
*/
Handle value = SAVE(C_string_to_Poly(mdTaskData, strings[i]));
Handle next = alloc_and_save(mdTaskData, SIZEOF(ML_Cons_Cell));
DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value);
DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list);
/* reset save vector to stop it overflowing */
mdTaskData->saveVec.reset(saved);
list = SAVE(DEREFHANDLE(next));
}
return list;
}
// 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;
}
// 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;
}
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);
}
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;
}
// Concatenate two strings. Now used only internally in the RTS.
Handle strconcatc(TaskData *mdTaskData, Handle y, Handle x)
/* Note: arguments are in the reverse order from Poly */
{
Handle result;
POLYUNSIGNED len, xlen, ylen;
char *from_ptr, *to_ptr;
if (IS_INT(DEREFWORD(x)))
xlen = 1;
else
xlen = DEREFSTRINGHANDLE(x)->length;
/* Don't concatenate with null strings */
if (xlen == 0) return y;
if (IS_INT(DEREFWORD(y)))
ylen = 1;
else
ylen = DEREFSTRINGHANDLE(y)->length;
if (ylen == 0) return x;
len = xlen + ylen;
/* Get store for combined string. Include rounding up to next word and
room for the length word and add in the flag. */
result = alloc_and_save(mdTaskData, (len + sizeof(PolyWord)-1)/sizeof(PolyWord) + 1, F_BYTE_OBJ);
DEREFSTRINGHANDLE(result)->length = len;
/* Copy first string */
to_ptr = DEREFSTRINGHANDLE(result)->chars;
if (xlen == 1)
{
*to_ptr++ = (char)UNTAGGED(DEREFSTRINGHANDLE(x));
}
else
{
from_ptr = DEREFSTRINGHANDLE(x)->chars;
while (xlen-- > 0) (*to_ptr++ = *from_ptr++);
}
/* Add on second */
if (ylen == 1)
{
*to_ptr = (char)UNTAGGED(DEREFSTRINGHANDLE(y));
}
else
{
from_ptr = DEREFSTRINGHANDLE(y)->chars;
while (ylen-- > 0) (*to_ptr++ = *from_ptr++);
}
return(result);
} /* strconcat */
// This is the C function that will get control when any callback is made. The "data"
// argument is the index of the entry in the callback table..
static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data)
{
uintptr_t cbIndex = (uintptr_t)data;
ASSERT(cbIndex >= 0 && cbIndex < callBackEntries);
// We should get the task data for the thread that is running this code.
// If this thread has been created by the foreign code we will have to
// create a new one here.
TaskData *taskData = processes->GetTaskDataForThread();
if (taskData == 0)
{
try {
taskData = processes->CreateNewTaskData(0, 0, 0, TAGGED(0));
}
catch (std::bad_alloc &) {
::Exit("Unable to create thread data - insufficient memory");
}
catch (MemoryException &) {
::Exit("Unable to create thread data - insufficient memory");
}
}
else processes->ThreadUseMLMemory(taskData);
// We may get multiple calls to call-backs and we mustn't risk
// overflowing the save-vec.
Handle mark = taskData->saveVec.mark();
// In the future we might want to call C functions without some of the
// overhead that comes with an RTS call which may allocate in ML
// memory. If we do that we also have to ensure that callbacks
// don't allocate, so this code would have to change.
Handle mlEntryHandle;
{
// Get the ML function. Lock to avoid another thread moving
// callbackTable under our feet.
PLocker pLocker(&callbackTableLock);
struct _cbStructEntry *cbEntry = &callbackTable[cbIndex];
mlEntryHandle = taskData->saveVec.push(cbEntry->mlFunction);
}
// Create a pair of the arg vector and the result pointer.
Handle argHandle = toSysWord(taskData, args);
Handle resHandle = toSysWord(taskData, ret); // Result must go in here.
Handle pairHandle = alloc_and_save(taskData, 2);
pairHandle->WordP()->Set(0, argHandle->Word());
pairHandle->WordP()->Set(1, resHandle->Word());
// TODO: This calls BuildCodeSegment to allocate small stub code.
// They could easily be cached in X86TaskData::SetCallbackFunction at least
// up to the next GC.
taskData->EnterCallbackFunction(mlEntryHandle, pairHandle);
taskData->saveVec.reset(mark);
// Release ML memory now we're going back to C.
processes->ThreadReleaseMLMemory(taskData);
}
// Construct an entry in the ABI table.
static Handle mkAbitab(TaskData *taskData, void *arg, char *p)
{
struct _abiTable *ab = (struct _abiTable *)p;
// Construct a pair of the string and the code
Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName));
Handle code = Make_arbitrary_precision(taskData, ab->abiCode);
Handle result = alloc_and_save(taskData, 2);
result->WordP()->Set(0, name->Word());
result->WordP()->Set(1, code->Word());
return result;
}
Handle ShowHierarchy(TaskData *taskData)
// Return the list of files in the hierarchy.
{
Handle saved = taskData->saveVec.mark();
Handle list = SAVE(ListNull);
// Process this in reverse order.
for (unsigned i = hierarchyDepth; i > 0; i--)
{
Handle value = SAVE(C_string_to_Poly(taskData, hierarchyTable[i-1]->fileName));
Handle next = alloc_and_save(taskData, sizeof(ML_Cons_Cell)/sizeof(PolyWord));
DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value);
DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list);
taskData->saveVec.reset(saved);
list = SAVE(DEREFHANDLE(next));
}
return list;
}
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;
}
// convert_string_list return a list of strings.
// This converts Unicode strings.
Handle convert_string_list(TaskData *mdTaskData, int count, WCHAR **strings)
{
Handle saved = mdTaskData->saveVec.mark();
Handle list = SAVE(ListNull);
// It's simplest to process the strings in reverse order */
for (int i = count - 1; 0 <= i; i--)
{
Handle value = SAVE(C_string_to_Poly(mdTaskData, strings[i]));
Handle next = alloc_and_save(mdTaskData, SIZEOF(ML_Cons_Cell));
DEREFLISTHANDLE(next)->h = DEREFWORDHANDLE(value);
DEREFLISTHANDLE(next)->t = DEREFLISTHANDLE(list);
// reset save vector to stop it overflowing
mdTaskData->saveVec.reset(saved);
list = SAVE(DEREFHANDLE(next));
}
return list;
}
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;
}
}
}
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;
}
}
}
static Handle toSysWord(TaskData *taskData, uintptr_t p)
{
Handle result = alloc_and_save(taskData, 1, F_BYTE_OBJ);
*(uintptr_t*)(result->Word().AsCodePtr()) = p;
return result;
}
