diff --git a/src/cpfront/posix/generic/System/Mod/Kernel.cp b/src/cpfront/posix/generic/System/Mod/Kernel.cp
index 82cac15b66e2ef650ba300c6444e9f28ce25bf19..bf9e33d9a4f94021cbdae310e7884ba6d5e9a673 100644 (file)
IMPORT S := SYSTEM, stdlib := PosixCstdlib, stdio := PosixCstdio,
time := PosixCtime, wctype := PosixCwctype, sysmman := PosixCsys_mman,
dlfcn := PosixCdlfcn, fcntl := PosixCfcntl, types := PosixCtypes,
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 *)
(* add BeepHook for Beep *)
(* init fpu? *)
(* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *)
(* add BeepHook for Beep *)
- (* implement Call using libffi *)
CONST
nameLen* = 256;
CONST
nameLen* = 256;
wouldFinalize: BOOLEAN;
wouldFinalize: BOOLEAN;
- watcher*: PROCEDURE (event: INTEGER); (* for debugging *)
+ watcher*: PROCEDURE (event: INTEGER); (* for debugging *)
+
+ intTrap*: BOOLEAN;
PROCEDURE Erase (adr, words: INTEGER);
BEGIN
PROCEDURE Erase (adr, words: INTEGER);
BEGIN
PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
CONST N = 65536; (* cluster size for dll *)
PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
CONST N = 65536; (* cluster size for dll *)
- VAR adr, allocated: INTEGER;
+ VAR adr, allocated, newsize: INTEGER;
BEGIN
INC(size, 16);
ASSERT(size > 0, 100); adr := 0;
BEGIN
INC(size, 16);
ASSERT(size > 0, 100); adr := 0;
- IF size < N THEN adr := stdlib.malloc(N) END;
- IF adr = 0 THEN adr := stdlib.malloc(size); allocated := size ELSE allocated := N END;
+ IF size < N THEN
+ adr := AllocMem(N, newsize);
+ allocated := newsize
+ END;
+ IF adr = 0 THEN
+ adr := AllocMem(size, newsize);
+ allocated := newsize
+ END;
IF adr = 0 THEN c := NIL
ELSE
c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr;
IF adr = 0 THEN c := NIL
ELSE
c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr;
PROCEDURE FreeHeapMem (c: Cluster);
BEGIN
DEC(used, c.size); DEC(total, c.size);
PROCEDURE FreeHeapMem (c: Cluster);
BEGIN
DEC(used, c.size); DEC(total, c.size);
- stdlib.free(S.VAL(ADDRESS, c.max))
+ FreeMem(S.VAL(ADDRESS, c.max), c.size)
END FreeHeapMem;
PROCEDURE HeapFull (size: INTEGER): BOOLEAN;
END FreeHeapMem;
PROCEDURE HeapFull (size: INTEGER): BOOLEAN;
(* -------------------- dynamic procedure call --------------------- *)
(* -------------------- 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 PushAdr (size: INTEGER);
+ BEGIN
+ ASSERT(size IN {1, 2, 4, 8}, 20);
+ ASSERT(littleEndian OR (size <= 4), 100); (* !!! swap 64bit value *)
+ varg[cn] := S.ADR(par[d]);
+ INC(cn); INC(d, MAX(1, size DIV 4))
+ END PushAdr;
+
+ PROCEDURE PushVal (size: INTEGER);
+ BEGIN
+ ASSERT(size IN {1, 2, 4, 8}, 20);
+ ASSERT(littleEndian OR (size <= 4), 100); (* !!! swap 64bit value *)
+ varg[cn] := par[d];
+ INC(cn); INC(d, MAX(1, size DIV 4))
+ END PushVal;
+
+ PROCEDURE Push (IN typ: LibFFI.type);
+ BEGIN
+ SetType(typ); PushAdr(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 := MAX(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
+ ELSE (* fix array *)
+ INC(d) (* skip size *)
+ 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) --------------------- *)
END Call;
(* -------------------- reference information (portable) --------------------- *)
SetDLink(tryDLink);
setjmp._longjmp(tryEnv, 1)
END;
SetDLink(tryDLink);
setjmp._longjmp(tryEnv, 1)
END;
- IF err = 128 THEN (* do nothing *)
+ IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
trapped := TRUE; trapViewer()
ELSE DefaultTrapViewer
ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
trapped := TRUE; trapViewer()
ELSE DefaultTrapViewer
SetDLink(tryDLink);
setjmp._longjmp(tryEnv, 1)
END;
SetDLink(tryDLink);
setjmp._longjmp(tryEnv, 1)
END;
- IF err = 128 THEN (* do nothing *)
+ IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *)
ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
trapped := TRUE; trapViewer()
ELSE DefaultTrapViewer
ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN
trapped := TRUE; trapViewer()
ELSE DefaultTrapViewer
PROCEDURE Init;
VAR i: INTEGER;
BEGIN
PROCEDURE Init;
VAR i: INTEGER;
BEGIN
+ intTrap := TRUE;
baseStack := S.ADR(i); (* XXX *)
pagesize := unistd.sysconf(unistd._SC_PAGESIZE);
baseStack := S.ADR(i); (* XXX *)
pagesize := unistd.sysconf(unistd._SC_PAGESIZE);