implement Kernel.Call for CPfront using libffi

diff --git a/make.sh b/make.sh
index 7626314d428cf63578604ff7a2ee95b0c1684815..af287d95d50bba19ba9f130fcf00ad95ee7fd416 100755 (executable)
--- a/make.sh
+++ b/make.sh
@@ -118,7 +118,7 @@ cpfront_link() {
     done
     local _cc_cflags=
     case "$CC" in
-      *gcc)  _cc_cflags="-Wno-int-conversion -Wno-int-to-pointer-cast -Wno-incompatible-pointer-types -Wno-implicit-function-declaration" ;;
+      *gcc)  _cc_cflags="-g -Wno-int-conversion -Wno-int-to-pointer-cast -Wno-incompatible-pointer-types -Wno-implicit-function-declaration" ;;
       *)  _cc_cflags="" ;;
     esac
     local _cpu_cflags=
@@ -132,7 +132,7 @@ cpfront_link() {
       cygwin)  _system_cflags="-liconv" ;;
       *)  _system_cflags="" ;;
     esac
-    "$CC" $_cc_cflags $_cpu_cflags $CFLAGS -o "${_main}" -I "$_this/C" "$_this/C/SYSTEM.c" $_list -lm -ldl $_system_cflags
+    "$CC" $_cc_cflags $_cpu_cflags $CFLAGS -o "${_main}" -I "$_this/C" "$_this/C/SYSTEM.c" $_list -lm -ldl -lffi $_system_cflags
   fi
 }
 
@@ -167,6 +167,9 @@ compile_all() {
       Posix/Mod/Cdlfcn.cp Posix/Mod/Csignal.cp Posix/Mod/Csetjmp.cp \
       Posix/Mod/Clibgen.cp \
       Posix/Mod/Cmacro.cp
+    if [ "$_target" = "cpfront" ]; then
+      compile Lib/Mod/FFI.cp
+    fi
   fi
 
   ###^^^^^^^^^^^^^^^^^^^^^^^^^^^^###

diff --git a/src/cpfront/486/Lib/Mod/FFI.cp b/src/cpfront/486/Lib/Mod/FFI.cp
new file mode 100644 (file)
index 0000000..02f61d3
--- /dev/null
+++ b/src/cpfront/486/Lib/Mod/FFI.cp
@@ -0,0 +1,89 @@
+MODULE LibFFI ["ffi.h"];
+
+  IMPORT SYSTEM, types := PosixCtypes, sys_types := PosixCsys_types;
+
+  CONST
+    SIZEOF_ARG* = 4;
+
+  CONST (* abi *)
+    FIRST_ABI* = 0;
+    SYSV* = 1;
+    STDCALL_WIN32* = 2; (* FFI_STDCALL for win32 *)
+    THISCALL* = 3;
+    FASTCALL* = 4;
+    MS_CDECL_WIN32* = 5; (* FFI_MS_CDECL for win32 *)
+    STDCALL_GENERIC* = 5; (* FFI_STDCALL for ~win32 *)
+    PASCAL* = 6;
+    REGISTER* = 7;
+    LAST_ABI* = 7;
+    DEFAULT_ABI* = SYSV;
+
+  CONST (* status *)
+    OK* = 0; BAD_TYPEDEF* = 1; BAD_ABI* = 2;
+
+  CONST
+    TYPE_VOID* = 0;
+    TYPE_INT* = 1;
+    TYPE_FLOAT* = 2;
+    TYPE_DOUBLE* = 3;
+    TYPE_LONGDOUBLE* = 4;
+    TYPE_UINT8* = 5;
+    TYPE_SINT8* = 6;
+    TYPE_UINT16* = 7;
+    TYPE_SINT16* = 8;
+    TYPE_UINT32* = 9;
+    TYPE_SINT32* = 10;
+    TYPE_UINT64* = 11;
+    TYPE_SINT64* = 12;
+    TYPE_STRUCT* = 13;
+    TYPE_POINTER* = 14;
+    TYPE_COMPLEX* = 15;
+    TYPE_LAST* = TYPE_COMPLEX;
+
+  TYPE
+    abi* ["ffi_abi"] = types.int; (* !!! enum *)
+    status* ["ffi_status"] = types.int; (* !!! enum *)
+
+    (* Ptype* = POINTER [untagged] TO type;
+    PPtype* = POINTER [untagged] TO ARRAY [untagged] OF Ptype; *)
+    type* ["ffi_type"] = RECORD [untagged]
+      size*: sys_types.size_t;
+      alignment*: types.unsigned_short;
+      type*: types.unsigned_short;
+      elements*: POINTER [untagged] TO ARRAY [untagged] OF POINTER TO type;
+    END;
+
+    (* Pcif* = POINTER TO cif; *)
+    cif* ["ffi_cif"] = RECORD [untagged]
+      abi*: abi;
+      nargs*: types.unsigned;
+      arg_type*: POINTER [untagged] TO ARRAY [untagged] OF POINTER TO type;
+      rtype*: POINTER TO type;
+      bytes*: types.unsigned;
+      flags*: types.unsigned;
+    END;
+
+  VAR
+    type_void- ["ffi_type_void"]: type;
+    type_uint8- ["ffi_type_uint8"]: type;
+    type_sint8- ["ffi_type_sint8"]: type;
+    type_uint16- ["ffi_type_uint16"]: type;
+    type_sint16- ["ffi_type_sint16"]: type;
+    type_uint32- ["ffi_type_uint32"]: type;
+    type_sint32- ["ffi_type_sint32"]: type;
+    type_uint64- ["ffi_type_uint64"]: type;
+    type_sint64- ["ffi_type_sint64"]: type;
+    type_float- ["ffi_type_float"]: type;
+    type_double- ["ffi_type_double"]: type;
+    type_pointer- ["ffi_type_pointer"]: type;
+    type_longdouble- ["ffi_type_longdouble"]: type;
+
+    type_complex_single- ["ffi_type_complex_single"]: type;
+    type_complex_double- ["ffi_type_complex_double"]: type;
+    type_complex_longdouble- ["ffi_type_complex_longdouble"]: type;
+
+  PROCEDURE [ccall] prep_cif* ["ffi_prep_cif"] (VAR c: cif; a: abi; nargs: types.unsigned_int; rtype: POINTER TO type; atypes: POINTER [untagged] TO ARRAY [untagged] OF POINTER TO type): status;
+  PROCEDURE [ccall] prep_cif_var* ["ffi_prep_cif_var"] (VAR c: cif; a: abi; nfixedargs, ntotalargs: types.unsigned_int; rtype: POINTER TO type; atypes: POINTER [untagged] TO ARRAY [untagged] OF POINTER TO type): status;
+  PROCEDURE [ccall] call* ["ffi_call"] (VAR c: cif; fn, rvalue, avalue: SYSTEM.ADDRESS);
+
+END LibFFI.

diff --git a/src/cpfront/posix/generic/System/Mod/Kernel.cp b/src/cpfront/posix/generic/System/Mod/Kernel.cp
index 622e0b10cc31ffb511333206090233333c0fd193..279fef9483a2960fa170d6ef66c71e7771eae372 100644 (file)
--- a/src/cpfront/posix/generic/System/Mod/Kernel.cp
+++ b/src/cpfront/posix/generic/System/Mod/Kernel.cp
@@ -3,7 +3,8 @@ MODULE Kernel;
   IMPORT S := SYSTEM, stdlib := PosixCstdlib, stdio := PosixCstdio,
     time := PosixCtime, wctype := PosixCwctype, sysmman := PosixCsys_mman,
     dlfcn := PosixCdlfcn, fcntl := PosixCfcntl, types := PosixCtypes,
-    unistd := PosixCunistd, signal := PosixCsignal, setjmp := PosixCsetjmp;
+    unistd := PosixCunistd, signal := PosixCsignal, setjmp := PosixCsetjmp,
+    LibFFI;
 
   (* init fpu? *)
   (* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *)
@@ -911,10 +912,180 @@ MODULE Kernel;
 
   (* -------------------- dynamic procedure call  --------------------- *)
 
-  PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
-  BEGIN
-    HALT(126); (* !!! *)
-    RETURN 0
+  (*
+    type           par
+    32 bit scalar  value
+    64 bit scalar  low hi
+    var scalar     address
+    record         address tag
+    array          address size
+    open array     address length .. length
+  *)
+
+  PROCEDURE Call* (adr: ADDRESS; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
+    CONST
+      (* obj.id MOD 16 *)
+      mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
+      (* typ *)
+      mBool = 1; mChar8 = 2; mChar16 = 3; mInt8 = 4; mInt16 = 5; mInt32 = 6;
+      mReal32 = 7; mReal64 = 8; mSet = 9; mInt64 = 10; mAnyRec = 11; mAnyPtr = 12; mSysPtr = 13;
+      (* typ.id MOD 4 *)
+      mProctyp = 0; mRecord = 1; mArray = 2; mPointer = 3;
+      (* ??? obj.id DIV 16 MOD 16 *)
+      mInternal = 1; mReadonly = 2; mPrivate = 3; mExported = 4;
+      (* sig.par[].id MOD 16 *)
+      mValue = 10; mInPar = 11; mOutPar = 12; mVarPar = 13;
+      mInterface = 32; mGuid = 33; mResult = 34;
+      (* implementation restrictions *)
+      maxPars = 127;
+      maxStrs = 127;
+      maxElms = 256;
+    TYPE
+      Ptype = POINTER TO LibFFI.type;
+      PPtype = POINTER TO ARRAY [untagged] OF Ptype;
+    VAR
+      status: LibFFI.status;
+      kind, form, size: INTEGER;
+      i, p, d, cn, ut, ue: INTEGER;
+      fret: Ptype;
+      vret: LONGINT;
+      earg: ARRAY maxElms OF Ptype;
+      targ: ARRAY maxStrs OF LibFFI.type;
+      farg: ARRAY maxPars OF Ptype;
+      varg: ARRAY maxPars OF ADDRESS;
+      typ: Type;
+      cif: LibFFI.cif;
+
+    PROCEDURE SetType (IN typ: LibFFI.type);
+    BEGIN
+      farg[cn] := S.VAL(Ptype, S.ADR(typ));
+    END SetType;
+
+    PROCEDURE PushVal (size: INTEGER);
+    BEGIN
+      ASSERT(size IN {1, 2, 4, 8}, 20);
+      ASSERT(littleEndian); (* !!! swap 64bit value *)
+      varg[cn] := S.ADR(par[d]);
+      INC(cn); INC(d, MAX(1, size DIV 4))
+    END PushVal;
+
+    PROCEDURE Push (IN typ: LibFFI.type);
+    BEGIN
+      SetType(typ); PushVal(typ.size)
+    END Push;
+
+  BEGIN
+    p := 0; cn := 0; d := 0; ut := 0; ue := 0;
+    WHILE p < sig.num DO
+      typ := sig.par[p].struct;
+      kind := sig.par[p].id MOD 16;
+      IF S.VAL(ADDRESS, typ) DIV 256 = 0 THEN (* basic types *)
+        form := S.VAL(ADDRESS, typ) MOD 256;
+        IF kind = mValue THEN
+          CASE form OF
+          | mBool, mChar8: Push(LibFFI.type_uint8)
+          | mChar16: Push(LibFFI.type_uint16)
+          | mInt8: Push(LibFFI.type_sint8)
+          | mInt16: Push(LibFFI.type_sint16)
+          | mInt32: Push(LibFFI.type_sint32)
+          | mReal32: Push(LibFFI.type_float)
+          | mReal64: Push(LibFFI.type_double)
+          | mSet: Push(LibFFI.type_uint32)
+          | mInt64: Push(LibFFI.type_sint64)
+          | mAnyPtr, mSysPtr: Push(LibFFI.type_pointer)
+          ELSE HALT(100) (* unsupported type *)
+          END;
+        ELSIF kind IN {mInPar..mVarPar} THEN
+          CASE form OF
+          | mBool..mInt64, mAnyPtr, mSysPtr: Push(LibFFI.type_pointer)
+          | mAnyRec: Push(LibFFI.type_pointer); Push(LibFFI.type_pointer) (* address + tag *)
+          ELSE HALT(101) (* unsupported type *)
+          END
+        ELSE
+          HALT(102) (* unsupported parameter kind *)
+        END
+      ELSE
+        CASE typ.id MOD 4 OF
+        | mProctyp, mPointer:
+           Push(LibFFI.type_pointer)
+        | mRecord:
+           IF kind = mValue THEN
+             targ[ut].size := 0;
+             targ[ut].alignment := 0;
+             targ[ut].type := LibFFI.TYPE_STRUCT;
+             targ[ut].elements := S.VAL(PPtype, S.ADR(earg[ue]));
+             SetType(targ[ut]); INC(ut);
+             size := MIN(1, typ.size);
+             (* !!! better to pass original layout *)
+             WHILE size >= 8 DO
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint64));
+               INC(ue); DEC(size, 8)
+             END;
+             IF size >= 4 THEN
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint32));
+               INC(ue); DEC(size, 4)
+             END;
+             IF size >= 2 THEN
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint16));
+               INC(ue); DEC(size, 2)
+             END;
+             IF size >= 1 THEN
+               earg[ue] := S.VAL(Ptype, S.ADR(LibFFI.type_uint32));
+               INC(ue); DEC(size)
+             END;
+             earg[ue] := NIL;
+             INC(ue);
+             PushVal(LibFFI.type_pointer.size);
+             INC(d) (* skip tag *)
+           ELSIF kind IN {mInPar..mVarPar} THEN
+             Push(LibFFI.type_pointer); (* address *)
+             Push(LibFFI.type_pointer); (* tag *)
+           ELSE HALT(103) (* unsupported parameter kind *)
+           END
+        | mArray:
+           Push(LibFFI.type_pointer);
+           ASSERT(kind IN {mValue..mVarPar}, 104); (* unsupported parameter kind *)
+           (* array copying generated by CPfront, so we can just pass address *)
+           IF typ.size = 0 THEN (* open array *)
+             FOR i := 0 TO typ.id DIV 16 - 1 DO
+               Push(LibFFI.type_sint32) (* dim size *)
+             END
+           END
+        END
+      END;
+      INC(p)
+    END;
+    ASSERT(d = n, 105);
+    typ := sig.retStruct;
+    IF typ = NIL THEN fret := S.VAL(Ptype, S.ADR(LibFFI.type_void))
+    ELSIF S.VAL(ADDRESS, typ) DIV 256 = 0 THEN
+      form := S.VAL(ADDRESS, typ) MOD 256;
+      CASE form OF
+      | mBool, mChar8: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint8))
+      | mChar16: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint16))
+      | mInt8: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint8))
+      | mInt16: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint16))
+      | mInt32: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint32))
+      | mReal32: fret := S.VAL(Ptype, S.ADR(LibFFI.type_float))
+      | mReal64: fret := S.VAL(Ptype, S.ADR(LibFFI.type_double))
+      | mSet: fret := S.VAL(Ptype, S.ADR(LibFFI.type_uint32))
+      | mInt64: fret := S.VAL(Ptype, S.ADR(LibFFI.type_sint64))
+      | mAnyPtr, mSysPtr: fret := S.VAL(Ptype, S.ADR(LibFFI.type_pointer))
+      ELSE HALT(106) (* unsupported type *)
+      END
+    ELSE
+      CASE typ.id MOD 4 OF
+      | mProctyp, mPointer: fret := S.VAL(Ptype, S.ADR(LibFFI.type_pointer))
+      ELSE HALT(107) (* unsupported type *)
+      END
+    END;
+    status := LibFFI.prep_cif(cif, LibFFI.DEFAULT_ABI, cn, fret, farg);
+    ASSERT(status = LibFFI.OK, 108);
+    vret := 0;
+    IF littleEndian THEN LibFFI.call(cif, adr, S.ADR(vret), S.ADR(varg))
+    ELSE LibFFI.call(cif, adr, S.ADR(vret) + (8 - fret.size), S.ADR(varg))
+    END;
+    RETURN vret
   END Call;
 
   (* -------------------- reference information (portable) --------------------- *)