// Deal with weak objects
void MTGCCheckWeakRef::ScanAddressesInObject(PolyObject *obj, POLYUNSIGNED L)
{
if (! OBJ_IS_WEAKREF_OBJECT(L)) return;
ASSERT(OBJ_IS_MUTABLE_OBJECT(L)); // Should be a mutable.
ASSERT(OBJ_IS_WORD_OBJECT(L)); // Should be a plain object.
// See if any of the SOME objects contain unreferenced refs.
POLYUNSIGNED length = OBJ_OBJECT_LENGTH(L);
PolyWord *baseAddr = (PolyWord*)obj;
for (POLYUNSIGNED i = 0; i < length; i++)
{
PolyWord someAddr = baseAddr[i];
if (someAddr.IsDataPtr())
{
LocalMemSpace *someSpace = gMem.LocalSpaceForAddress(someAddr.AsAddress());
if (someSpace != 0)
{
PolyObject *someObj = someAddr.AsObjPtr();
// If this is a weak object the SOME value may refer to an unreferenced
// ref. If so we have to set this entry to NONE. For safety we also
// set the contents of the SOME to TAGGED(0).
ASSERT(someObj->Length() == 1 && someObj->IsWordObject()); // Should be a SOME node.
PolyWord refAddress = someObj->Get(0);
LocalMemSpace *space = gMem.LocalSpaceForAddress(refAddress.AsAddress());
if (space != 0)
// If the ref is permanent it's always there.
{
POLYUNSIGNED new_bitno = space->wordNo(refAddress.AsStackAddr());
if (! space->bitmap.TestBit(new_bitno))
{
// It wasn't marked so it's otherwise unreferenced.
baseAddr[i] = TAGGED(0); // Set it to NONE.
someObj->Set(0, TAGGED(0)); // For safety.
convertedWeak = true;
}
}
}
}
}
}
// Process one level of the word data.
// N.B. The length words are updated without any locking. This is safe
// because all length words are initially chain entries and a chain entry
// can be replaced by another chain entry, a forwarding pointer or a normal
// length word. Forwarding pointers and normal length words are only ever
// set once. There is a small chance that we could lose some sharing as a
// result of a race condition if a thread defers an object because it
// contains a pointer with a chain entry and later sees an otherwise
// equal object where another thread has replaced the chain with a
// normal address, adds it to the list for immediate processing and
// so never compares the two.
void SortVector::wordDataTask(GCTaskId*, void *a, void *)
{
SortVector *s = (SortVector*)a;
// Partition the objects between those that have pointers to objects that are
// still to be processed and those that have been processed.
if (s->baseObject.objList == ENDOFLIST)
return;
PolyObject *h = s->baseObject.objList;
s->baseObject.objList = ENDOFLIST;
s->baseObject.objCount = 0;
POLYUNSIGNED words = OBJ_OBJECT_LENGTH(s->lengthWord);
s->carryOver = 0;
for (unsigned i = 0; i < 256; i++)
{
// Clear the entries in the hash table but not the sharing count.
s->processObjects[i].objList = ENDOFLIST;
s->processObjects[i].objCount = 0;
}
while (h != ENDOFLIST)
{
PolyObject *next = h->GetForwardingPtr();
bool deferred = false;
for (POLYUNSIGNED i = 0; i < words; i++)
{
PolyWord w = h->Get(i);
if (w.IsDataPtr())
{
PolyObject *p = w.AsObjPtr();
objectState state = getObjectState(p);
if (state == FORWARDED)
{
// Update the addresses of objects that have been merged
h->Set(i, p->GetForwardingPtr());
s->carryOver++;
break;
}
else if (state == CHAINED)
{
// If it is still to be shared leave it
deferred = true;
break; // from the loop
}
}
}
if (deferred)
{
// We can't do it yet: add it back to the list
h->SetForwardingPtr(s->baseObject.objList);
s->baseObject.objList = h;
s->baseObject.objCount++;
}
else
{
// Add it to the hash table.
unsigned char hash = 0;
for (POLYUNSIGNED i = 0; i < words*sizeof(PolyWord); i++)
hash += h->AsBytePtr()[i];
h->SetForwardingPtr(s->processObjects[hash].objList);
s->processObjects[hash].objList = h;
s->processObjects[hash].objCount++;
}
h = next;
}
s->SortData();
}
bool PImport::DoImport()
{
int ch;
POLYUNSIGNED objNo;
ASSERT(gMem.npSpaces == 0);
ASSERT(gMem.neSpaces == 0);
ASSERT(gMem.ioSpace->bottom == 0);
PolyWord *ioSpace = (PolyWord*)calloc(POLY_SYS_vecsize*IO_SPACING, sizeof(PolyWord));
if (ioSpace == 0)
{
fprintf(stderr, "Unable to allocate memory\n");
return false;
}
gMem.InitIOSpace(ioSpace, POLY_SYS_vecsize*IO_SPACING);
ch = getc(f);
/* Skip the "Mapping" line. */
if (ch == 'M') { while (getc(f) != '\n') ; ch = getc(f); }
ASSERT(ch == 'O'); /* Number of objects. */
while (getc(f) != '\t') ;
fscanf(f, "%" POLYUFMT, &nObjects);
/* Create a mapping table. */
objMap = (PolyObject**)calloc(nObjects, sizeof(PolyObject*));
if (objMap == 0)
{
fprintf(stderr, "Unable to allocate memory\n");
return false;
}
do
{
ch = getc(f);
} while (ch == '\n');
ASSERT(ch == 'R'); /* Root object number. */
while (getc(f) != '\t') ;
fscanf(f, "%" POLYUFMT, &nRoot);
/* Now the objects themselves. */
while (1)
{
bool isMutable = false;
unsigned objBits = 0;
POLYUNSIGNED nWords, nBytes;
do
{
ch = getc(f);
} while (ch == '\r' || ch == '\n');
if (ch == EOF) break;
ungetc(ch, f);
fscanf(f, "%" POLYUFMT, &objNo);
ch = getc(f);
ASSERT(ch == ':');
ASSERT(objNo < nObjects);
/* Modifiers, MNVW. */
do
{
ch = getc(f);
if (ch == 'M') { isMutable = true; objBits |= F_MUTABLE_BIT; }
else if (ch == 'N') objBits |= F_NEGATIVE_BIT;
if (ch == 'V') objBits |= F_NO_OVERWRITE;
if (ch == 'W') objBits |= F_WEAK_BIT;
} while (ch == 'M' || ch == 'N' || ch == 'L' || ch == 'V' || ch == 'W');
/* Object type. */
switch (ch)
{
case 'O': /* Simple object. */
fscanf(f, "%" POLYUFMT, &nWords);
break;
case 'B': /* Byte segment. */
objBits |= F_BYTE_OBJ;
fscanf(f, "%" POLYUFMT, &nBytes);
/* Round up to appropriate number of words. */
nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord);
break;
case 'S': /* String. */
objBits |= F_BYTE_OBJ;
/* The length is the number of characters. */
fscanf(f, "%" POLYUFMT, &nBytes);
/* Round up to appropriate number of words. Need to add
one PolyWord for the length PolyWord. */
nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord) + 1;
break;
case 'C': /* Code segment (old form). */
case 'D': /* Code segment (new form). */
objBits |= F_CODE_OBJ;
/* Read the number of bytes of code and the number of words
for constants. */
fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes);
nWords += ch == 'C' ? 4 : 1; /* Add words for extras. */
/* Add in the size of the code itself. */
nWords += (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord);
break;
default:
fprintf(stderr, "Invalid object type\n");
return false;
}
PolyObject *p = NewObject(nWords, isMutable);
if (p == 0)
return false;
objMap[objNo] = p;
/* Put in length PolyWord and flag bits. */
p->SetLengthWord(nWords, objBits);
/* Skip the object contents. */
while (getc(f) != '\n') ;
}
/* Second pass - fill in the contents. */
fseek(f, 0, SEEK_SET);
/* Skip the information at the start. */
ch = getc(f);
if (ch == 'M')
{
while (getc(f) != '\n') ;
ch = getc(f);
}
ASSERT(ch == 'O'); /* Number of objects. */
while (getc(f) != '\n');
ch = getc(f);
ASSERT(ch == 'R'); /* Root object number. */
while (getc(f) != '\n') ;
while (1)
{
POLYUNSIGNED nWords, nBytes, i;
if (feof(f))
break;
fscanf(f, "%" POLYUFMT, &objNo);
if (feof(f))
break;
ch = getc(f);
ASSERT(ch == ':');
ASSERT(objNo < nObjects);
PolyObject * p = objMap[objNo];
/* Modifiers, M or N. */
do
{
ch = getc(f);
} while (ch == 'M' || ch == 'N' || ch == 'L' || ch == 'V' || ch == 'W');
/* Object type. */
switch (ch)
{
case 'O': /* Simple object. */
fscanf(f, "%" POLYUFMT, &nWords);
ch = getc(f);
ASSERT(ch == '|');
ASSERT(nWords == p->Length());
for (i = 0; i < nWords; i++)
{
if (! ReadValue(p, i))
return false;
ch = getc(f);
ASSERT((ch == ',' && i < nWords-1) ||
(ch == '\n' && i == nWords-1));
}
break;
case 'B': /* Byte segment. */
{
byte *u = (byte*)p;
fscanf(f, "%" POLYUFMT, &nBytes);
ch = getc(f); ASSERT(ch == '|');
for (i = 0; i < nBytes; i++)
{
int n;
fscanf(f, "%02x", &n);
u[i] = n;
}
ch = getc(f);
ASSERT(ch == '\n');
break;
}
case 'S': /* String. */
{
PolyStringObject * ps = (PolyStringObject *)p;
/* The length is the number of characters. */
fscanf(f, "%" POLYUFMT, &nBytes);
ch = getc(f); ASSERT(ch == '|');
ps->length = nBytes;
for (i = 0; i < nBytes; i++)
{
int n;
fscanf(f, "%02x", &n);
ps->chars[i] = n;
}
ch = getc(f);
ASSERT(ch == '\n');
break;
}
case 'C': /* Code segment. */
case 'D':
{
bool oldForm = ch == 'C';
byte *u = (byte*)p;
POLYUNSIGNED length = p->Length();
/* Read the number of bytes of code and the number of words
for constants. */
fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes);
/* Read the code. */
ch = getc(f); ASSERT(ch == '|');
for (i = 0; i < nBytes; i++)
{
int n;
fscanf(f, "%02x", &n);
u[i] = n;
}
machineDependent->FlushInstructionCache(u, nBytes);
ch = getc(f);
ASSERT(ch == '|');
/* Set the constant count. */
p->Set(length-1, PolyWord::FromUnsigned(nWords));
if (oldForm)
{
p->Set(length-1-nWords-1, PolyWord::FromUnsigned(0)); /* Profile count. */
p->Set(length-1-nWords-3, PolyWord::FromUnsigned(0)); /* Marker word. */
p->Set(length-1-nWords-2, PolyWord::FromUnsigned((length-1-nWords-2)*sizeof(PolyWord)));
/* Check - the code should end at the marker word. */
ASSERT(nBytes == ((length-1-nWords-3)*sizeof(PolyWord)));
}
/* Read in the constants. */
for (i = 0; i < nWords; i++)
{
if (! ReadValue(p, i+length-nWords-1))
return false;
ch = getc(f);
ASSERT((ch == ',' && i < nWords-1) ||
((ch == '\n' || ch == '|') && i == nWords-1));
}
// Read in any constants in the code.
if (ch == '|')
{
ch = getc(f);
while (ch != '\n')
{
ungetc(ch, f);
POLYUNSIGNED offset;
int code;
fscanf(f, "%" POLYUFMT ",%d", &offset, &code);
ch = getc(f);
ASSERT(ch == ',');
PolyWord constVal = TAGGED(0);
if (! GetValue(&constVal))
return false;
byte *toPatch = (byte*)p + offset;
ScanAddress::SetConstantValue(toPatch, constVal, (ScanRelocationKind)code);
do ch = getc(f); while (ch == ' ');
}
}
// Adjust the byte count. This is only necessary when importing the interpreted
// code into a machine with a different endian-ness from the exporter.
{
POLYUNSIGNED l = 0;
while (l < length && p->Get(l) != PolyWord::FromUnsigned(0)) l++;
ASSERT(l < length);
l++;
p->Set(l, PolyWord::FromUnsigned(l*sizeof(PolyWord)));
}
break;
}
default:
fprintf(stderr, "Invalid object type\n");
return false;
}
}
return mutSpace.AddToTable() && immutSpace.AddToTable();
}
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 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;
}
}
}
