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