// Process a value within the stack.
PolyWord ScanAddress::ScanStackAddress(PolyWord val, StackSpace *stack, bool isCode)
{
PolyWord *base = stack->bottom;
PolyWord *end = stack->top;
// If isCode is set we definitely have a code address. It may have the
// bottom bit set or it may be word aligned.
if (isCode || val.IsCodePtr())
{
/* Find the start of the code segment */
PolyObject *oldObject = ObjCodePtrToPtr(val.AsCodePtr());
// Calculate the byte offset of this value within the code object.
POLYUNSIGNED offset = val.AsCodePtr() - (byte*)oldObject;
PolyObject *newObject = ScanObjectAddress(oldObject);
return PolyWord::FromCodePtr((byte*)newObject + offset);
}
else if (val.IsTagged() || val == PolyWord::FromUnsigned(0) ||
(val.AsAddress() > base && val.AsAddress() <= end))
/* We don't need to process tagged integers (now we've checked it isn't
a code address) and we don't need to process addresses within the
current stack. */
/* N.B. We have "<= end" rather than "< end" because it is possible for
the stack to be completely empty on a terminated thread. */
return val;
else
{
ASSERT(val.IsDataPtr());
return ScanObjectAddress(val.AsObjPtr());
}
}
// Update the addresses in a group of words.
void LoadRelocate::RelocateAddressAt(PolyWord *pt)
{
PolyWord val = *pt;
if (val.IsTagged()) return;
// Which segment is this address in?
unsigned i;
for (i = 0; i < nDescrs; i++)
{
SavedStateSegmentDescr *descr = &descrs[i];
if (val.AsAddress() > descr->originalAddress &&
val.AsAddress() <= (char*)descr->originalAddress + descr->segmentSize)
{
// It's in this segment: relocate it to the current position.
MemSpace *space =
descr->segmentIndex == 0 ? gMem.IoSpace() : gMem.SpaceForIndex(descr->segmentIndex);
// Error if this doesn't match.
byte *setAddress = (byte*)space->bottom + ((char*)val.AsAddress() - (char*)descr->originalAddress);
*pt = PolyWord::FromCodePtr(setAddress);
break;
}
}
if (i == nDescrs)
{
// Error: Not found.
errorMessage = "Unmatched address";
}
}
// The initial entry to process the roots. These may be RTS addresses or addresses in
// a thread stack. Also called recursively to process the addresses of constants in
// code segments. This is used in situations where a scanner may return the
// updated address of an object.
PolyObject *MTGCProcessMarkPointers::ScanObjectAddress(PolyObject *obj)
{
PolyWord val = obj;
LocalMemSpace *space = gMem.LocalSpaceForAddress(val.AsAddress());
if (space == 0)
return obj; // Ignore it if it points to a permanent area
// We may have a forwarding pointer if this has been moved by the
// minor GC.
if (obj->ContainsForwardingPtr())
{
obj = FollowForwarding(obj);
val = obj;
space = gMem.LocalSpaceForAddress(val.AsAddress());
}
ASSERT(obj->ContainsNormalLengthWord());
POLYUNSIGNED L = obj->LengthWord();
if (L & _OBJ_GC_MARK)
return obj; // Already marked
obj->SetLengthWord(L | _OBJ_GC_MARK); // Mark it
if (profileMode == kProfileLiveData || (profileMode == kProfileLiveMutables && obj->IsMutable()))
AddObjectProfile(obj);
POLYUNSIGNED n = OBJ_OBJECT_LENGTH(L);
if (debugOptions & DEBUG_GC_DETAIL)
Log("GC: Mark: %p %" POLYUFMT " %u\n", obj, n, GetTypeBits(L));
if (OBJ_IS_BYTE_OBJECT(L))
return obj;
// If we already have something on the stack we must being called
// recursively to process a constant in a code segment. Just push
// it on the stack and let the caller deal with it.
if (msp != 0)
PushToStack(obj); // Can't check this because it may have forwarding ptrs.
else
{
MTGCProcessMarkPointers::ScanAddressesInObject(obj, L);
// We can only check after we've processed it because if we
// have addresses left over from an incomplete partial GC they
// may need to forwarded.
CheckObject (obj);
}
return obj;
}
// Returns the new address if the argument is the address of an object that
// has moved, otherwise returns the original.
PolyWord SaveFixupAddress::GetNewAddress(PolyWord old)
{
if (old.IsTagged() || old == PolyWord::FromUnsigned(0) || gMem.IsIOPointer(old.AsAddress()))
return old; // Nothing to do.
// When we are updating addresses in the stack or in code segments we may have
// code pointers.
if (old.IsCodePtr())
{
// Find the start of the code segment
PolyObject *oldObject = ObjCodePtrToPtr(old.AsCodePtr());
// Calculate the byte offset of this value within the code object.
POLYUNSIGNED offset = old.AsCodePtr() - (byte*)oldObject;
PolyWord newObject = GetNewAddress(oldObject);
return PolyWord::FromCodePtr(newObject.AsCodePtr() + offset);
}
ASSERT(old.IsDataPtr());
PolyObject *obj = old.AsObjPtr();
if (obj->ContainsForwardingPtr()) // tombstone is a pointer to a moved object
{
PolyObject *newp = obj->GetForwardingPtr();
ASSERT (newp->ContainsNormalLengthWord());
return newp;
}
ASSERT (obj->ContainsNormalLengthWord()); // object is not moved
return old;
}
/* Get the index corresponding to an address. */
PolyWord MachoExport::createRelocation(PolyWord p, void *relocAddr)
{
void *addr = p.AsAddress();
unsigned addrArea = findArea(addr);
POLYUNSIGNED offset = (char*)addr - (char*)memTable[addrArea].mtAddr;
adjustOffset(addrArea, offset);
// It looks as though struct relocation_info entries are only used
// with GENERIC_RELOC_VANILLA types.
struct relocation_info relInfo;
setRelocationAddress(relocAddr, &relInfo.r_address);
relInfo.r_symbolnum = addrArea+1; // Section numbers start at 1
relInfo.r_pcrel = 0;
#if (SIZEOF_VOIDP == 8)
relInfo.r_length = 3; // 8 bytes
relInfo.r_type = X86_64_RELOC_UNSIGNED;
#else
relInfo.r_length = 2; // 4 bytes
relInfo.r_type = GENERIC_RELOC_VANILLA;
#endif
relInfo.r_extern = 0; // r_symbolnum is a section number. It should be 1 if we make the IO area a common.
fwrite(&relInfo, sizeof(relInfo), 1, exportFile);
relocationCount++;
return PolyWord::FromUnsigned(offset);
}
void PExport::printValue(PolyWord q)
{
if (IS_INT(q) || q == PolyWord::FromUnsigned(0))
fprintf(exportFile, "%" POLYSFMT, UNTAGGED(q));
else if (OBJ_IS_CODEPTR(q))
printCodeAddr(q.AsCodePtr());
else
printAddress(q.AsAddress());
}
// 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;
}
}
}
}
}
}
// Create a relocation entry for an address at a given location.
PolyWord SaveStateExport::createRelocation(PolyWord p, void *relocAddr)
{
RelocationEntry reloc;
// Set the offset within the section we're scanning.
setRelocationAddress(relocAddr, &reloc.relocAddress);
void *addr = p.AsAddress();
unsigned addrArea = findArea(addr);
reloc.targetAddress = (char*)addr - (char*)memTable[addrArea].mtAddr;
reloc.targetSegment = (unsigned)memTable[addrArea].mtIndex;
reloc.relKind = PROCESS_RELOC_DIRECT;
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
return p; // Don't change the contents
}
// Returns the new address if the argument is the address of an object that
// has moved, otherwise returns the original.
PolyWord ProcessFixupAddress::GetNewAddress(PolyWord old)
{
if (old.IsTagged() || old == PolyWord::FromUnsigned(0) || gMem.IsIOPointer(old.AsAddress()))
return old; // Nothing to do.
// When we are updating addresses in the stack or in code segments we may have
// code pointers.
if (old.IsCodePtr())
{
// Find the start of the code segment
PolyObject *oldObject = ObjCodePtrToPtr(old.AsCodePtr());
// Calculate the byte offset of this value within the code object.
POLYUNSIGNED offset = old.AsCodePtr() - (byte*)oldObject;
PolyWord newObject = GetNewAddress(oldObject);
return PolyWord::FromCodePtr(newObject.AsCodePtr() + offset);
}
ASSERT(old.IsDataPtr());
PolyObject *obj = old.AsObjPtr();
POLYUNSIGNED L = obj->LengthWord();
// Generally each address will point to an object processed at a lower depth.
// The exception is if we have a cycle and have assigned the rest of the
// structure to a higher depth.
// N.B. We return the original address here but this could actually share
// with something else and not be retained.
if (OBJ_IS_DEPTH(L))
return old;
if (obj->ContainsForwardingPtr()) // tombstone is a pointer to a shared object
{
PolyObject *newp = obj->GetForwardingPtr();
// ASSERT (newp->ContainsNormalLengthWord());
return newp;
}
ASSERT (obj->ContainsNormalLengthWord()); // object is not shared
return old;
}
/* This is called for each constant within the code.
Print a relocation entry for the word and return a value that means
that the offset is saved in original word. */
void SaveStateExport::ScanConstant(byte *addr, ScanRelocationKind code)
{
PolyWord p = GetConstantValue(addr, code);
if (IS_INT(p) || p == PolyWord::FromUnsigned(0))
return;
void *a = p.AsAddress();
unsigned aArea = findArea(a);
// We don't need a relocation if this is relative to the current segment
// since the relative address will already be right.
if (code == PROCESS_RELOC_I386RELATIVE && aArea == findArea(addr))
return;
// Set the value at the address to the offset relative to the symbol.
RelocationEntry reloc;
setRelocationAddress(addr, &reloc.relocAddress);
reloc.targetAddress = (char*)a - (char*)memTable[aArea].mtAddr;
reloc.targetSegment = (unsigned)memTable[aArea].mtIndex;
reloc.relKind = code;
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
}
// We use _OBJ_GC_MARK to detect when we have visited a cell but not yet
// computed the depth. We have to be careful that this bit is removed
// before we finish in the case that we run out of memory and throw an
// exception. PushToStack may throw the exception if the stack needs to
// grow.
POLYUNSIGNED ProcessAddToVector::AddObjectsToDepthVectors(PolyWord old)
{
// If this is a tagged integer or an IO pointer that's simply a constant.
if (old.IsTagged() || old == PolyWord::FromUnsigned(0))
return 0;
MemSpace *space = gMem.SpaceForAddress(old.AsAddress());
if (space == 0 || space->spaceType == ST_IO)
return 0;
PolyObject *obj = old.AsObjPtr();
POLYUNSIGNED L = obj->LengthWord();
if (OBJ_IS_DEPTH(L)) // tombstone contains genuine depth or 0.
return OBJ_GET_DEPTH(L);
if (obj->LengthWord() & _OBJ_GC_MARK)
return 0; // Marked but not yet scanned. Circular structure.
ASSERT (OBJ_IS_LENGTH(L));
if (obj->IsMutable())
{
// Mutable data in the local or permanent areas
if (! obj->IsByteObject())
{
// Add it to the vector so we will update any addresses it contains.
m_parent->AddToVector(0, L, old.AsObjPtr());
// and follow any addresses to try to merge those.
PushToStack(obj);
obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan
}
return 0; // Level is zero
}
if (space->spaceType == ST_PERMANENT &&
((PermanentMemSpace*)space)->hierarchy == 0)
{
// Immutable data in the permanent area can't be merged
// because it's read only. We need to follow the addresses
// because they may point to mutable areas containing data
// that can be. A typical case is the root function pointing
// at the global name table containing new declarations.
Bitmap *bm = &((PermanentMemSpace*)space)->shareBitmap;
if (! bm->TestBit((PolyWord*)obj - space->bottom))
{
bm->SetBit((PolyWord*)obj - space->bottom);
if (! obj->IsByteObject())
PushToStack(obj);
}
return 0;
}
/* There's a problem sharing code objects if they have relative calls/jumps
in them to other code. The code of two functions may be identical (e.g.
they both call functions 100 bytes ahead) and so they will appear the
same but if the functions they jump to are different they are actually
different. For that reason we don't share code segments. DCJM 4/1/01 */
if (obj->IsCodeObject())
{
// We want to update addresses in the code segment.
m_parent->AddToVector(0, L, old.AsObjPtr());
PushToStack(obj);
obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan
return 0;
}
// Byte objects always have depth 1 and can't contain addresses.
if (obj->IsByteObject())
{
m_parent->AddToVector (1, L, old.AsObjPtr());// add to vector at correct depth
obj->SetLengthWord(OBJ_SET_DEPTH(1));
return 1;
}
ASSERT(OBJ_IS_WORD_OBJECT(L)); // That leaves immutable data objects.
PushToStack(obj);
obj->SetLengthWord(L | _OBJ_GC_MARK); // To prevent rescan
return 0;
}
/* This is called for each constant within the code.
Print a relocation entry for the word and return a value that means
that the offset is saved in original word. */
void MachoExport::ScanConstant(byte *addr, ScanRelocationKind code)
{
PolyWord p = GetConstantValue(addr, code);
if (IS_INT(p) || p == PolyWord::FromUnsigned(0))
return;
void *a = p.AsAddress();
unsigned aArea = findArea(a);
// Set the value at the address to the offset relative to the symbol.
POLYUNSIGNED offset = (char*)a - (char*)memTable[aArea].mtAddr;
adjustOffset(aArea, offset);
switch (code)
{
case PROCESS_RELOC_DIRECT: // 32 bit address of target
{
struct relocation_info reloc;
setRelocationAddress(addr, &reloc.r_address);
reloc.r_symbolnum = aArea+1; // Section numbers start at 1
reloc.r_pcrel = 0;
#if (defined(HOSTARCHITECTURE_X86_64))
reloc.r_length = 3; // 8 bytes
reloc.r_type = X86_64_RELOC_UNSIGNED;
#else
reloc.r_length = 2; // 4 bytes
reloc.r_type = GENERIC_RELOC_VANILLA;
#endif
reloc.r_extern = 0; // r_symbolnum is a section number. It should be 1 if we make the IO area a common.
for (unsigned i = 0; i < sizeof(PolyWord); i++)
{
addr[i] = (byte)(offset & 0xff);
offset >>= 8;
}
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
}
break;
#if (defined(HOSTARCHITECTURE_X86) || defined(HOSTARCHITECTURE_X86_64))
case PROCESS_RELOC_I386RELATIVE: // 32 bit relative address
{
unsigned addrArea = findArea(addr);
// If it's in the same area we don't need a relocation because the
// relative offset will be unchanged.
if (addrArea != aArea)
{
struct relocation_info reloc;
setRelocationAddress(addr, &reloc.r_address);
reloc.r_symbolnum = aArea+1; // Section numbers start at 1
reloc.r_pcrel = 1;
reloc.r_length = 2; // 4 bytes
#if (defined(HOSTARCHITECTURE_X86_64))
reloc.r_type = X86_64_RELOC_SIGNED;
#else
reloc.r_type = GENERIC_RELOC_VANILLA;
#endif
reloc.r_extern = 0; // r_symbolnum is a section number.
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
POLYUNSIGNED addrOffset = (char*)addr - (char*)memTable[addrArea].mtAddr;
adjustOffset(addrArea, addrOffset);
offset -= addrOffset + 4;
for (unsigned i = 0; i < 4; i++)
{
addr[i] = (byte)(offset & 0xff);
offset >>= 8;
}
}
}
break;
#endif
default:
ASSERT(0); // Wrong type of relocation for this architecture.
}
}
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;
}
}
}
/* This is called for each constant within the code.
Print a relocation entry for the word and return a value that means
that the offset is saved in original word. */
void MachoExport::ScanConstant(byte *addr, ScanRelocationKind code)
{
PolyWord p = GetConstantValue(addr, code);
if (IS_INT(p) || p == PolyWord::FromUnsigned(0))
return;
void *a = p.AsAddress();
unsigned aArea = findArea(a);
// Set the value at the address to the offset relative to the symbol.
POLYUNSIGNED offset = (char*)a - (char*)memTable[aArea].mtAddr;
adjustOffset(aArea, offset);
switch (code)
{
case PROCESS_RELOC_DIRECT: // 32 bit address of target
{
struct relocation_info reloc;
setRelocationAddress(addr, &reloc.r_address);
reloc.r_symbolnum = aArea+1; // Section numbers start at 1
reloc.r_pcrel = 0;
#if (defined(HOSTARCHITECTURE_X86_64))
reloc.r_length = 3; // 8 bytes
reloc.r_type = X86_64_RELOC_UNSIGNED;
#else
reloc.r_length = 2; // 4 bytes
reloc.r_type = GENERIC_RELOC_VANILLA;
#endif
reloc.r_extern = 0; // r_symbolnum is a section number. It should be 1 if we make the IO area a common.
for (unsigned i = 0; i < sizeof(PolyWord); i++)
{
addr[i] = (byte)(offset & 0xff);
offset >>= 8;
}
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
}
break;
#if (defined(HOSTARCHITECTURE_X86))
case PROCESS_RELOC_I386RELATIVE: // 32 bit relative address
{
unsigned addrArea = findArea(addr);
// If it's in the same area we don't need a relocation because the
// relative offset will be unchanged.
if (addrArea != aArea)
{
struct relocation_info reloc;
setRelocationAddress(addr, &reloc.r_address);
reloc.r_symbolnum = aArea+1; // Section numbers start at 1
reloc.r_pcrel = 1;
reloc.r_length = 2; // 4 bytes
reloc.r_type = GENERIC_RELOC_VANILLA;
reloc.r_extern = 0; // r_symbolnum is a section number.
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
POLYUNSIGNED addrOffset = (char*)addr - (char*)memTable[addrArea].mtAddr;
adjustOffset(addrArea, addrOffset);
offset -= addrOffset + 4;
for (unsigned i = 0; i < sizeof(PolyWord); i++)
{
addr[i] = (byte)(offset & 0xff);
offset >>= 8;
}
}
}
break;
#endif
#ifdef HOSTARCHITECTURE_PPC
case PROCESS_RELOC_PPCDUAL16SIGNED: // Power PC - two consecutive words
case PROCESS_RELOC_PPCDUAL16UNSIGNED:
{
struct relocation_info reloc;
setRelocationAddress(addr, &reloc.r_address);
POLYUNSIGNED hi = offset >> 16; // N.B. No adjustment yet.
POLYUNSIGNED lo = offset & 0xffff;
// We use two consecutive words for our address but Mach-O requires separate
// relocations for each. It stores one half of the address in the instruction
// itself and the other half is carried in a PPC_RELOC_PAIR relocation entry.
// We need four relocations here in total.
reloc.r_symbolnum = aArea+1; // Section numbers start at 1
reloc.r_extern = 0; // r_symbolnum is a section number.
reloc.r_pcrel = 0;
reloc.r_length = 2; // 4 bytes
reloc.r_type = code == PROCESS_RELOC_PPCDUAL16SIGNED ? PPC_RELOC_HA16 : PPC_RELOC_HI16;
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
// Next must be a "pair" containing the low-order part of the address.
// The high-order part is stored in the instruction.
reloc.r_symbolnum = 0xffffff; // Not sure why
reloc.r_type = PPC_RELOC_PAIR;
reloc.r_extern = 0;
reloc.r_pcrel = 0;
reloc.r_address = lo;
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
// Now the low-order part.
setRelocationAddress(addr+sizeof(PolyWord), &reloc.r_address);
reloc.r_symbolnum = aArea+1; // Section numbers start at 1
reloc.r_extern = 0; // r_symbolnum is a section number.
reloc.r_pcrel = 0;
reloc.r_length = 2; // 4 bytes
reloc.r_type = PPC_RELOC_LO16;
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
// Finally a "pair" containing the high-order part of the address to
// match the low-order part in the instruction.
reloc.r_symbolnum = 0xffffff; // Not sure why
reloc.r_type = PPC_RELOC_PAIR;
reloc.r_extern = 0;
reloc.r_pcrel = 0;
reloc.r_address = hi; // Must NOT be adjusted for sign extension.
fwrite(&reloc, sizeof(reloc), 1, exportFile);
relocationCount++;
// Adjust for sign extension and store in the instruction.
if ((lo & 0x8000) && (code == PROCESS_RELOC_PPCDUAL16SIGNED)) hi++;
POLYUNSIGNED *pt = (POLYUNSIGNED *)addr;
// Store the offset into the instructions.
pt[0] = (pt[0] & 0xffff0000) | hi;
pt[1] = (pt[1] & 0xffff0000) | lo;
}
break;
#endif
default:
ASSERT(0); // Wrong type of relocation for this architecture.
}
}