1/* 2 Title: New Foreign Function Interface 3 4 Copyright (c) 2015, 2018 David C.J. Matthews 5 6 This library is free software; you can redistribute it and/or 7 modify it under the terms of the GNU Lesser General Public 8 License version 2.1 as published by the Free Software Foundation. 9 10 This library is distributed in the hope that it will be useful, 11 but WITHOUT ANY WARRANTY; without even the implied warranty of 12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 Lesser General Public License for more details. 14 15 You should have received a copy of the GNU Lesser General Public 16 License along with this library; if not, write to the Free Software 17 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 18 19*/ 20 21#ifdef HAVE_CONFIG_H 22#include "config.h" 23#elif defined(_WIN32) 24#include "winconfig.h" 25#else 26#error "No configuration file" 27#endif 28 29#if (defined(_WIN32) || (defined(HAVE_DLOPEN))) 30 31#ifdef HAVE_ERRNO_H 32#include <errno.h> 33#endif 34 35#ifdef HAVE_DLFCN_H 36#include <dlfcn.h> 37#endif 38 39#ifdef HAVE_ASSERT_H 40#include <assert.h> 41#define ASSERT(x) assert(x) 42#else 43#define ASSERT(x) 0 44#endif 45 46#ifdef HAVE_STDIO_H 47#include <stdio.h> 48#endif 49 50#ifdef HAVE_STDLIB_H 51#include <stdlib.h> 52#endif 53 54#ifdef HAVE_MALLOC_H 55#include <malloc.h> 56#endif 57 58#ifdef HAVE_STRING_H 59#include <string.h> 60#endif 61 62#include "globals.h" 63// TODO: Do we need this?? 64// We need to include globals.h before <new> in mingw64 otherwise 65// it messes up POLYUFMT/POLYSFMT. 66 67#include <ffi.h> 68#include <new> 69 70#include "arb.h" 71#include "save_vec.h" 72#include "polyffi.h" 73#include "run_time.h" 74#include "sys.h" 75#include "processes.h" 76#include "polystring.h" 77 78#if (defined(_WIN32) && ! defined(__CYGWIN__)) 79#include <windows.h> 80#include "Console.h" /* For hApplicationInstance. */ 81#endif 82 83#include "scanaddrs.h" 84#include "diagnostics.h" 85#include "reals.h" 86#include "rts_module.h" 87#include "rtsentry.h" 88 89static Handle poly_ffi (TaskData *taskData, Handle args, Handle code); 90 91extern "C" { 92 POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGeneral(PolyObject *threadId, PolyWord code, PolyWord arg); 93 POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeFloat(); 94 POLYEXTERNALSYMBOL POLYUNSIGNED PolySizeDouble(); 95 POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFIGetError(PolyWord addr); 96 POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFISetError(PolyWord err); 97 POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtFn(PolyObject *threadId, PolyWord arg); 98 POLYEXTERNALSYMBOL POLYUNSIGNED PolyFFICreateExtData(PolyObject *threadId, PolyWord arg); 99} 100 101static struct _abiTable { const char *abiName; ffi_abi abiCode; } abiTable[] = 102{ 103// Unfortunately the ABI entries are enums rather than #defines so we 104// can't test individual entries. 105#ifdef X86_WIN32 106 {"sysv", FFI_SYSV}, 107 {"stdcall", FFI_STDCALL}, 108 {"thiscall", FFI_THISCALL}, 109 {"fastcall", FFI_FASTCALL}, 110 {"ms_cdecl", FFI_MS_CDECL}, 111#elif defined(X86_WIN64) 112 {"win64", FFI_WIN64}, 113#elif defined(X86_ANY) 114 {"sysv", FFI_SYSV}, 115 {"unix64", FFI_UNIX64}, 116#endif 117 { "default", FFI_DEFAULT_ABI} 118}; 119 120// Table of constants returned by call 51 121static int constantTable[] = 122{ 123 FFI_DEFAULT_ABI, // Default ABI 124 FFI_TYPE_VOID, // Type codes 125 FFI_TYPE_INT, 126 FFI_TYPE_FLOAT, 127 FFI_TYPE_DOUBLE, 128 FFI_TYPE_UINT8, 129 FFI_TYPE_SINT8, 130 FFI_TYPE_UINT16, 131 FFI_TYPE_SINT16, 132 FFI_TYPE_UINT32, 133 FFI_TYPE_SINT32, 134 FFI_TYPE_UINT64, 135 FFI_TYPE_SINT64, 136 FFI_TYPE_STRUCT, 137 FFI_TYPE_POINTER, 138 FFI_SIZEOF_ARG // Minimum size for result space 139}; 140 141// Table of predefined ffi types 142static ffi_type *ffiTypeTable[] = 143{ 144 &ffi_type_void, 145 &ffi_type_uint8, 146 &ffi_type_sint8, 147 &ffi_type_uint16, 148 &ffi_type_sint16, 149 &ffi_type_uint32, 150 &ffi_type_sint32, 151 &ffi_type_uint64, 152 &ffi_type_sint64, 153 &ffi_type_float, 154 &ffi_type_double, 155 &ffi_type_pointer, 156 &ffi_type_uchar, // These are all aliases for the above 157 &ffi_type_schar, 158 &ffi_type_ushort, 159 &ffi_type_sshort, 160 &ffi_type_uint, 161 &ffi_type_sint, 162 &ffi_type_ulong, 163 &ffi_type_slong 164}; 165 166// Callback entry table 167static struct _cbStructEntry { 168 PolyWord mlFunction; // The ML function to call 169 void *closureSpace; // Space allocated for the closure 170 void *resultFunction; // Executable address for the function. Needed to free. 171} *callbackTable; 172static unsigned callBackEntries = 0; 173static PLock callbackTableLock; // Mutex to protect table. 174 175 176static Handle mkAbitab(TaskData *taskData, void*, char *p); 177static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data); 178 179static Handle toSysWord(TaskData *taskData, void *p) 180{ 181 return Make_sysword(taskData, (uintptr_t)p); 182} 183 184Handle poly_ffi(TaskData *taskData, Handle args, Handle code) 185{ 186 unsigned c = get_C_unsigned(taskData, code->Word()); 187 switch (c) 188 { 189 case 0: // malloc 190 { 191 POLYUNSIGNED size = getPolyUnsigned(taskData, args->Word()); 192 return toSysWord(taskData, malloc(size)); 193 } 194 case 1: // free 195 { 196 void *mem = *(void**)(args->WordP()); 197 free(mem); 198 return taskData->saveVec.push(TAGGED(0)); 199 } 200 201 case 2: // Load library 202 { 203 TempString libName(args->Word()); 204#if (defined(_WIN32) && ! defined(__CYGWIN__)) 205 HINSTANCE lib = LoadLibrary(libName); 206 if (lib == NULL) 207 { 208 char buf[256]; 209#if (defined(UNICODE)) 210 _snprintf(buf, sizeof(buf), "Loading <%S> failed. Error %lu", (LPCTSTR)libName, GetLastError()); 211#else 212 _snprintf(buf, sizeof(buf), "Loading <%s> failed. Error %lu", (const char*)libName, GetLastError()); 213#endif 214 buf[sizeof(buf)-1] = 0; // Terminate just in case 215 raise_exception_string(taskData, EXC_foreign, buf); 216 } 217#else 218 void *lib = dlopen(libName, RTLD_LAZY); 219 if (lib == NULL) 220 { 221 char buf[256]; 222 snprintf(buf, sizeof(buf), "Loading <%s> failed: %s", (const char *)libName, dlerror()); 223 buf[sizeof(buf)-1] = 0; // Terminate just in case 224 raise_exception_string(taskData, EXC_foreign, buf); 225 } 226#endif 227 return toSysWord(taskData, lib); 228 } 229 230 case 3: // Load address of executable. 231 { 232#if (defined(_WIN32) && ! defined(__CYGWIN__)) 233 HINSTANCE lib = hApplicationInstance; 234#else 235 void *lib = dlopen(NULL, RTLD_LAZY); 236 if (lib == NULL) 237 { 238 char buf[256]; 239 snprintf(buf, sizeof(buf), "Loading address of executable failed: %s", dlerror()); 240 buf[sizeof(buf)-1] = 0; // Terminate just in case 241 raise_exception_string(taskData, EXC_foreign, buf); 242 } 243#endif 244 return toSysWord(taskData, lib); 245 } 246 case 4: // Unload library - Is this actually going to be used? 247 { 248#if (defined(_WIN32) && ! defined(__CYGWIN__)) 249 HMODULE hMod = *(HMODULE*)(args->WordP()); 250 if (! FreeLibrary(hMod)) 251 raise_syscall(taskData, "FreeLibrary failed", GetLastError()); 252#else 253 void *lib = *(void**)(args->WordP()); 254 if (dlclose(lib) != 0) 255 { 256 char buf[256]; 257 snprintf(buf, sizeof(buf), "dlclose failed: %s", dlerror()); 258 buf[sizeof(buf)-1] = 0; // Terminate just in case 259 raise_exception_string(taskData, EXC_foreign, buf); 260 } 261#endif 262 return taskData->saveVec.push(TAGGED(0)); 263 } 264 case 5: // Load the address of a symbol from a library. 265 { 266 TempCString symName(args->WordP()->Get(1)); 267#if (defined(_WIN32) && ! defined(__CYGWIN__)) 268 HMODULE hMod = *(HMODULE*)(args->WordP()->Get(0).AsAddress()); 269 void *sym = (void*)GetProcAddress(hMod, symName); 270 if (sym == NULL) 271 { 272 char buf[256]; 273 _snprintf(buf, sizeof(buf), "Loading symbol <%s> failed. Error %lu", (LPCSTR)symName, GetLastError()); 274 buf[sizeof(buf)-1] = 0; // Terminate just in case 275 raise_exception_string(taskData, EXC_foreign, buf); 276 } 277#else 278 void *lib = *(void**)(args->WordP()->Get(0).AsAddress()); 279 void *sym = dlsym(lib, symName); 280 if (sym == NULL) 281 { 282 char buf[256]; 283 snprintf(buf, sizeof(buf), "load_sym <%s> : %s", (const char *)symName, dlerror()); 284 buf[sizeof(buf)-1] = 0; // Terminate just in case 285 raise_exception_string(taskData, EXC_foreign, buf); 286 } 287#endif 288 return toSysWord(taskData, sym); 289 } 290 291 // Libffi functions 292 case 50: // Return a list of available ABIs 293 return makeList(taskData, sizeof(abiTable)/sizeof(abiTable[0]), 294 (char*)abiTable, sizeof(abiTable[0]), 0, mkAbitab); 295 296 case 51: // A constant from the table 297 { 298 unsigned index = get_C_unsigned(taskData, args->Word()); 299 if (index >= sizeof(constantTable) / sizeof(constantTable[0])) 300 raise_exception_string(taskData, EXC_foreign, "Index out of range"); 301 return Make_arbitrary_precision(taskData, constantTable[index]); 302 } 303 304 case 52: // Return an FFI type 305 { 306 unsigned index = get_C_unsigned(taskData, args->Word()); 307 if (index >= sizeof(ffiTypeTable) / sizeof(ffiTypeTable[0])) 308 raise_exception_string(taskData, EXC_foreign, "Index out of range"); 309 return toSysWord(taskData, ffiTypeTable[index]); 310 } 311 312 case 53: // Extract fields from ffi type. 313 { 314 ffi_type *ffit = *(ffi_type**)(args->WordP()); 315 Handle sizeHandle = Make_arbitrary_precision(taskData, ffit->size); 316 Handle alignHandle = Make_arbitrary_precision(taskData, ffit->alignment); 317 Handle typeHandle = Make_arbitrary_precision(taskData, ffit->type); 318 Handle elemHandle = toSysWord(taskData, ffit->elements); 319 Handle resHandle = alloc_and_save(taskData, 4); 320 resHandle->WordP()->Set(0, sizeHandle->Word()); 321 resHandle->WordP()->Set(1, alignHandle->Word()); 322 resHandle->WordP()->Set(2, typeHandle->Word()); 323 resHandle->WordP()->Set(3, elemHandle->Word()); 324 return resHandle; 325 } 326 327 case 54: // Construct an ffi type. 328 { 329 // This is probably only used to create structs. 330 size_t size = getPolyUnsigned(taskData, args->WordP()->Get(0)); 331 unsigned short align = get_C_ushort(taskData, args->WordP()->Get(1)); 332 unsigned short type = get_C_ushort(taskData, args->WordP()->Get(2)); 333 unsigned nElems = 0; 334 for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 335 nElems++; 336 size_t space = sizeof(ffi_type); 337 // If we need the elements add space for the elements plus 338 // one extra for the zero terminator. 339 if (nElems != 0) space += (nElems+1) * sizeof(ffi_type *); 340 ffi_type *result = (ffi_type*)calloc(1, space); 341 // Raise an exception rather than returning zero. 342 if (result == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); 343 ffi_type **elem = 0; 344 if (nElems != 0) elem = (ffi_type **)(result+1); 345 result->size = size; 346 result->alignment = align; 347 result->type = type; 348 result->elements = elem; 349 if (elem != 0) 350 { 351 for (PolyWord p = args->WordP()->Get(3); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 352 { 353 PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; 354 *elem++ = *(ffi_type**)(e.AsAddress()); 355 } 356 *elem = 0; 357 } 358 return toSysWord(taskData, result); 359 } 360 361 case 55: // Create a CIF. This contains all the types and some extra information. 362 // The result is in allocated memory followed immediately by the argument type vector. 363 { 364 ffi_abi abi = (ffi_abi)get_C_ushort(taskData, args->WordP()->Get(0)); 365 ffi_type *rtype = *(ffi_type **)args->WordP()->Get(1).AsAddress(); 366 unsigned nArgs = 0; 367 for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 368 nArgs++; 369 // Allocate space for the cif followed by the argument type vector 370 size_t space = sizeof(ffi_cif) + nArgs * sizeof(ffi_type*); 371 ffi_cif *cif = (ffi_cif *)malloc(space); 372 if (cif == 0) raise_syscall(taskData, "Insufficient memory", ENOMEM); 373 ffi_type **atypes = (ffi_type **)(cif+1); 374 // Copy the arguments types. 375 ffi_type **at = atypes; 376 for (PolyWord p = args->WordP()->Get(2); !ML_Cons_Cell::IsNull(p); p = ((ML_Cons_Cell*)p.AsObjPtr())->t) 377 { 378 PolyWord e = ((ML_Cons_Cell*)p.AsObjPtr())->h; 379 *at++ = *(ffi_type**)(e.AsAddress()); 380 } 381 ffi_status status = ffi_prep_cif(cif, abi, nArgs, rtype, atypes); 382 if (status == FFI_BAD_TYPEDEF) 383 raise_exception_string(taskData, EXC_foreign, "Bad typedef in ffi_prep_cif"); 384 else if (status == FFI_BAD_ABI) 385 raise_exception_string(taskData, EXC_foreign, "Bad ABI in ffi_prep_cif"); 386 else if (status != FFI_OK) 387 raise_exception_string(taskData, EXC_foreign, "Error in ffi_prep_cif"); 388 return toSysWord(taskData, cif); 389 } 390 391 case 56: // Call a function. 392 { 393 ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(0).AsAddress(); 394 void *f = *(void**)args->WordP()->Get(1).AsAddress(); 395 void *res = *(void**)args->WordP()->Get(2).AsAddress(); 396 void **arg = *(void***)args->WordP()->Get(3).AsAddress(); 397 // We release the ML memory across the call so a GC can occur 398 // even if this thread is blocked in the C code. 399 processes->ThreadReleaseMLMemory(taskData); 400 ffi_call(cif, FFI_FN(f), res, arg); 401 // Do we need to save the value of errno/GetLastError here? 402 processes->ThreadUseMLMemory(taskData); 403 return taskData->saveVec.push(TAGGED(0)); 404 } 405 406 case 57: // Create a callback. 407 { 408#ifdef INTERPRETED 409 raise_exception_string(taskData, EXC_foreign, "Callbacks are not implemented in the byte code interpreter"); 410#endif 411 Handle mlFunction = taskData->saveVec.push(args->WordP()->Get(0)); 412 ffi_cif *cif = *(ffi_cif **)args->WordP()->Get(1).AsAddress(); 413 414 void *resultFunction; 415 // Allocate the memory. resultFunction is set to the executable address in or related to 416 // the memory. 417 ffi_closure *closure = (ffi_closure *)ffi_closure_alloc(sizeof(ffi_closure), &resultFunction); 418 if (closure == 0) 419 raise_exception_string(taskData, EXC_foreign, "Callbacks not implemented or insufficient memory"); 420 421 PLocker pLocker(&callbackTableLock); 422 // Find a free entry in the table if there is one. 423 unsigned entryNo = 0; 424 while (entryNo < callBackEntries && callbackTable[entryNo].closureSpace != 0) entryNo++; 425 if (entryNo == callBackEntries) 426 { 427 // Need to grow the table. 428 struct _cbStructEntry *newTable = 429 (struct _cbStructEntry*)realloc(callbackTable, (callBackEntries+1)*sizeof(struct _cbStructEntry)); 430 if (newTable == 0) 431 raise_exception_string(taskData, EXC_foreign, "Unable to allocate memory for callback table"); 432 callbackTable = newTable; 433 callBackEntries++; 434 } 435 436 callbackTable[entryNo].mlFunction = mlFunction->Word(); 437 callbackTable[entryNo].closureSpace = closure; 438 callbackTable[entryNo].resultFunction = resultFunction; 439 440 if (ffi_prep_closure_loc(closure, cif, callbackEntryPt, (void*)((uintptr_t)entryNo), resultFunction) != FFI_OK) 441 raise_exception_string(taskData, EXC_foreign,"libffi error: ffi_prep_closure_loc failed"); 442 return toSysWord(taskData, resultFunction); 443 } 444 445 case 58: // Free an existing callback. 446 { 447 // The address returned from call 57 above is the executable address that can 448 // be passed as a callback function. The writable memory address returned 449 // as the result of ffi_closure_alloc may or may not be the same. To be safe 450 // we need to search the table. 451 void *resFun = *(void**)args->Word().AsAddress(); 452 PLocker pLocker(&callbackTableLock); 453 for (unsigned i = 0; i < callBackEntries; i++) 454 { 455 if (callbackTable[i].resultFunction == resFun) 456 { 457 ffi_closure_free(callbackTable[i].closureSpace); 458 callbackTable[i].closureSpace = 0; 459 callbackTable[i].resultFunction = 0; 460 callbackTable[i].mlFunction = TAGGED(0); // Release the ML function 461 return taskData->saveVec.push(TAGGED(0)); 462 } 463 } 464 raise_exception_string(taskData, EXC_foreign, "Invalid callback entry"); 465 } 466 467 default: 468 { 469 char msg[100]; 470 sprintf(msg, "Unknown ffi function: %d", c); 471 raise_exception_string(taskData, EXC_foreign, msg); 472 return 0; 473 } 474 } 475} 476 477// Construct an entry in the ABI table. 478static Handle mkAbitab(TaskData *taskData, void *arg, char *p) 479{ 480 struct _abiTable *ab = (struct _abiTable *)p; 481 // Construct a pair of the string and the code 482 Handle name = taskData->saveVec.push(C_string_to_Poly(taskData, ab->abiName)); 483 Handle code = Make_arbitrary_precision(taskData, ab->abiCode); 484 Handle result = alloc_and_save(taskData, 2); 485 result->WordP()->Set(0, name->Word()); 486 result->WordP()->Set(1, code->Word()); 487 return result; 488} 489 490// This is the C function that will get control when any callback is made. The "data" 491// argument is the index of the entry in the callback table.. 492static void callbackEntryPt(ffi_cif *cif, void *ret, void* args[], void *data) 493{ 494 uintptr_t cbIndex = (uintptr_t)data; 495 ASSERT(cbIndex < callBackEntries); 496 // We should get the task data for the thread that is running this code. 497 // If this thread has been created by the foreign code we will have to 498 // create a new one here. 499 TaskData *taskData = processes->GetTaskDataForThread(); 500 if (taskData == 0) 501 { 502 try { 503 taskData = processes->CreateNewTaskData(0, 0, 0, TAGGED(0)); 504 } 505 catch (std::bad_alloc &) { 506 ::Exit("Unable to create thread data - insufficient memory"); 507 } 508 catch (MemoryException &) { 509 ::Exit("Unable to create thread data - insufficient memory"); 510 } 511 } 512 else processes->ThreadUseMLMemory(taskData); 513 // We may get multiple calls to call-backs and we mustn't risk 514 // overflowing the save-vec. 515 Handle mark = taskData->saveVec.mark(); 516 517 // In the future we might want to call C functions without some of the 518 // overhead that comes with an RTS call which may allocate in ML 519 // memory. If we do that we also have to ensure that callbacks 520 // don't allocate, so this code would have to change. 521 Handle mlEntryHandle; 522 { 523 // Get the ML function. Lock to avoid another thread moving 524 // callbackTable under our feet. 525 PLocker pLocker(&callbackTableLock); 526 struct _cbStructEntry *cbEntry = &callbackTable[cbIndex]; 527 mlEntryHandle = taskData->saveVec.push(cbEntry->mlFunction); 528 } 529 530 // Create a pair of the arg vector and the result pointer. 531 Handle argHandle = toSysWord(taskData, args); 532 Handle resHandle = toSysWord(taskData, ret); // Result must go in here. 533 Handle pairHandle = alloc_and_save(taskData, 2); 534 pairHandle->WordP()->Set(0, argHandle->Word()); 535 pairHandle->WordP()->Set(1, resHandle->Word()); 536 537 taskData->EnterCallbackFunction(mlEntryHandle, pairHandle); 538 539 taskData->saveVec.reset(mark); 540 541 // Release ML memory now we're going back to C. 542 processes->ThreadReleaseMLMemory(taskData); 543} 544 545 546class PolyFFI: public RtsModule 547{ 548public: 549 virtual void GarbageCollect(ScanAddress *process); 550}; 551 552// Declare this. It will be automatically added to the table. 553static PolyFFI polyFFIModule; 554 555// We need to scan the callback table. 556void PolyFFI::GarbageCollect(ScanAddress *process) 557{ 558 for (unsigned i = 0; i < callBackEntries; i++) 559 process->ScanRuntimeWord(&callbackTable[i].mlFunction); 560} 561 562#else 563// The foreign function interface isn't available. 564#include "polyffi.h" 565#include "run_time.h" 566#include "sys.h" 567 568Handle poly_ffi(TaskData *taskData, Handle args, Handle code) 569{ 570 raise_exception_string(taskData, EXC_foreign, "The foreign function interface is not available on this platform"); 571} 572#endif 573 574// General interface to IO. Ideally the various cases will be made into 575// separate functions. 576POLYUNSIGNED PolyFFIGeneral(PolyObject *threadId, PolyWord code, PolyWord arg) 577{ 578 TaskData *taskData = TaskData::FindTaskForId(threadId); 579 ASSERT(taskData != 0); 580 taskData->PreRTSCall(); 581 Handle reset = taskData->saveVec.mark(); 582 Handle pushedCode = taskData->saveVec.push(code); 583 Handle pushedArg = taskData->saveVec.push(arg); 584 Handle result = 0; 585 586 try { 587 result = poly_ffi(taskData, pushedArg, pushedCode); 588 } catch (...) { } // If an ML exception is raised 589 590 taskData->saveVec.reset(reset); 591 taskData->PostRTSCall(); 592 if (result == 0) return TAGGED(0).AsUnsigned(); 593 else return result->Word().AsUnsigned(); 594} 595 596// These functions are needed in the compiler 597POLYUNSIGNED PolySizeFloat() 598{ 599 return TAGGED(ffi_type_float.size).AsUnsigned(); 600} 601 602POLYUNSIGNED PolySizeDouble() 603{ 604 return TAGGED(ffi_type_double.size).AsUnsigned(); 605} 606 607// Get either errno or GetLastError 608POLYUNSIGNED PolyFFIGetError(PolyWord addr) 609{ 610#if (defined(_WIN32) && ! defined(__CYGWIN__)) 611 addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned(GetLastError())); 612#else 613 addr.AsObjPtr()->Set(0, PolyWord::FromUnsigned((POLYUNSIGNED)errno)); 614#endif 615 return 0; 616} 617 618// The argument is a SysWord.word value i.e. the address of a byte cell. 619POLYUNSIGNED PolyFFISetError(PolyWord err) 620{ 621#if (defined(_WIN32) && ! defined(__CYGWIN__)) 622 SetLastError((DWORD)(err.AsObjPtr()->Get(0).AsUnsigned())); 623#else 624 errno = err.AsObjPtr()->Get(0).AsSigned(); 625#endif 626 return 0; 627} 628 629// Create an external function reference. The value returned has space for 630// an address followed by the name of the external symbol. Because the 631// address comes at the beginning it can be used in the same way as the 632// SysWord value returned by the get-symbol call from a library. 633POLYUNSIGNED PolyFFICreateExtFn(PolyObject *threadId, PolyWord arg) 634{ 635 TaskData *taskData = TaskData::FindTaskForId(threadId); 636 ASSERT(taskData != 0); 637 taskData->PreRTSCall(); 638 Handle reset = taskData->saveVec.mark(); 639 Handle pushedArg = taskData->saveVec.push(arg); 640 Handle result = 0; 641 642 try { 643 result = creatEntryPointObject(taskData, pushedArg, true); 644 } 645 catch (...) {} // If an ML exception is raised 646 647 taskData->saveVec.reset(reset); // Ensure the save vec is reset 648 taskData->PostRTSCall(); 649 if (result == 0) return TAGGED(0).AsUnsigned(); 650 else return result->Word().AsUnsigned(); 651} 652 653// Create an external reference to data. On a small number of platforms 654// different forms of relocation are needed for data and for functions. 655POLYUNSIGNED PolyFFICreateExtData(PolyObject *threadId, PolyWord arg) 656{ 657 TaskData *taskData = TaskData::FindTaskForId(threadId); 658 ASSERT(taskData != 0); 659 taskData->PreRTSCall(); 660 Handle reset = taskData->saveVec.mark(); 661 Handle pushedArg = taskData->saveVec.push(arg); 662 Handle result = 0; 663 664 try { 665 result = creatEntryPointObject(taskData, pushedArg, false); 666 } 667 catch (...) {} // If an ML exception is raised 668 669 taskData->saveVec.reset(reset); // Ensure the save vec is reset 670 taskData->PostRTSCall(); 671 if (result == 0) return TAGGED(0).AsUnsigned(); 672 else return result->Word().AsUnsigned(); 673} 674 675struct _entrypts polyFFIEPT[] = 676{ 677 { "PolyFFIGeneral", (polyRTSFunction)&PolyFFIGeneral}, 678 { "PolySizeFloat", (polyRTSFunction)&PolySizeFloat}, 679 { "PolySizeDouble", (polyRTSFunction)&PolySizeDouble}, 680 { "PolyFFIGetError", (polyRTSFunction)&PolyFFIGetError}, 681 { "PolyFFISetError", (polyRTSFunction)&PolyFFISetError}, 682 { "PolyFFICreateExtFn", (polyRTSFunction)&PolyFFICreateExtFn}, 683 { "PolyFFICreateExtData", (polyRTSFunction)&PolyFFICreateExtData }, 684 685 { NULL, NULL} // End of list. 686}; 687 688