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, macro := PosixCmacro, LibFFI; (* init fpu? *) (* add signal blocking to avoid race conditions in Try/Trap/TrapHandler *) (* add BeepHook for Beep *) CONST nameLen* = 256; littleEndian* = FALSE; timeResolution* = 1000; (* ticks per second *) processor* = 1; (* generic c *) objType* = "ocf"; (* file types *) symType* = "osf"; docType* = "odc"; (* loader constants *) done* = 0; fileNotFound* = 1; syntaxError* = 2; objNotFound* = 3; illegalFPrint* = 4; cyclicImport* = 5; noMem* = 6; commNotFound* = 7; commSyntaxError* = 8; moduleNotFound* = 9; any = 1000000; strictStackSweep = FALSE; N = 128 DIV 16; (* free lists *) (* kernel flags in module desc *) init = 16; dyn = 17; dll = 24; iptrs = 30; (* meta interface consts *) mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5; TYPE Name* = ARRAY nameLen OF CHAR; Utf8Name* = ARRAY nameLen OF SHORTCHAR; Command* = PROCEDURE; Module* = POINTER TO RECORD [untagged] next-: Module; opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *) refcnt-: INTEGER; (* <0: module invalidated *) compTime-, loadTime-: ARRAY 6 OF SHORTINT; ext-: INTEGER; (* currently not used *) term-: Command; (* terminator *) nofimps-, nofptrs-: INTEGER; csize-, dsize-, rsize-: INTEGER; code-, data-, refs-: INTEGER; procBase-, varBase-: INTEGER; (* meta base addresses *) names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *) ptrs-: POINTER TO ARRAY [untagged] OF INTEGER; imports-: POINTER TO ARRAY [untagged] OF Module; export-: Directory; (* exported objects (name sorted) *) name-: Utf8Name END; Type* = POINTER TO RECORD [untagged] (* record: ptr to method n at offset - 4 * (n+1) *) size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *) mod-: Module; id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *) base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *) fields-: Directory; (* new fields (declaration order) *) ptroffs-: ARRAY any OF INTEGER (* array of any length *) END; Object* = POINTER TO ObjDesc; ObjDesc* = RECORD [untagged] fprint-: INTEGER; offs-: INTEGER; (* pvfprint for record types *) id-: INTEGER; (* name idx * 256 + vis * 16 + mode *) struct-: Type (* id of basic type or pointer to typedesc/signature *) END; Directory* = POINTER TO RECORD [untagged] num-: INTEGER; (* number of entries *) obj-: ARRAY any OF ObjDesc (* array of any length *) END; Signature* = POINTER TO RECORD [untagged] retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *) num-: INTEGER; (* number of parameters *) par-: ARRAY any OF RECORD [untagged] (* parameters *) id-: INTEGER; (* name idx * 256 + kind *) struct-: Type (* id of basic type or pointer to typedesc *) END END; Handler* = PROCEDURE; Reducer* = POINTER TO ABSTRACT RECORD next: Reducer END; Identifier* = ABSTRACT RECORD typ*: INTEGER; obj-: ANYPTR END; TrapCleaner* = POINTER TO ABSTRACT RECORD next: TrapCleaner END; TryHandler* = PROCEDURE (a, b, c: INTEGER); (* meta extension suport *) ItemExt* = POINTER TO ABSTRACT RECORD END; ItemAttr* = RECORD obj*, vis*, typ*, adr*: INTEGER; mod*: Module; desc*: Type; ptr*: S.PTR; ext*: ItemExt END; Hook* = POINTER TO ABSTRACT RECORD END; LoaderHook* = POINTER TO ABSTRACT RECORD (Hook) res*: INTEGER; importing*, imported*, object*: ARRAY 256 OF CHAR END; Block = POINTER TO RECORD [untagged] tag: Type; last: INTEGER; (* arrays: last element *) actual: INTEGER; (* arrays: used during mark phase *) first: INTEGER (* arrays: first element *) END; FreeBlock = POINTER TO FreeDesc; FreeDesc = RECORD [untagged] tag: Type; (* f.tag = ADR(f.size) *) size: INTEGER; next: FreeBlock END; Cluster = POINTER TO RECORD [untagged] size: INTEGER; (* total size *) next: Cluster; max: INTEGER (* exe: reserved size, dll: original address *) (* start of first block *) END; FList = POINTER TO RECORD next: FList; blk: Block; iptr, aiptr: BOOLEAN END; CList = POINTER TO RECORD next: CList; do: Command; trapped: BOOLEAN END; PtrType = RECORD v: S.PTR END; (* used for array of pointer *) Char8Type = RECORD v: SHORTCHAR END; Char16Type = RECORD v: CHAR END; Int8Type = RECORD v: BYTE END; Int16Type = RECORD v: SHORTINT END; Int32Type = RECORD v: INTEGER END; Int64Type = RECORD v: LONGINT END; BoolType = RECORD v: BOOLEAN END; SetType = RECORD v: SET END; Real32Type = RECORD v: SHORTREAL END; Real64Type = RECORD v: REAL END; ProcType = RECORD v: PROCEDURE END; UPtrType = RECORD v: INTEGER END; StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR; (* SYSTEM.h -> SYSTEM_DLINK *) DLink = POINTER TO RECORD [untagged] next: DLink; name: StrPtr END; ArrStrPtr = POINTER TO ARRAY [untagged] OF StrPtr; ADDRESS* = types.Pvoid; VAR baseStack: INTEGER; root: Cluster; modList-: Module; trapCount-: INTEGER; err-, pc-, sp-, fp-, stack-, val-: INTEGER; isTry, checkReadable: BOOLEAN; startEnv, checkReadableEnv: setjmp.sigjmp_buf; tryEnv: setjmp.jmp_buf; startDLink, tryDLink: DLink; argc-: INTEGER; argv-: ArrStrPtr; pagesize: unistd.long; free: ARRAY N OF FreeBlock; (* free list *) sentinelBlock: FreeDesc; sentinel: FreeBlock; candidates: ARRAY 1024 OF INTEGER; nofcand: INTEGER; allocated: INTEGER; (* bytes allocated on BlackBox heap *) total: INTEGER; (* current total size of BlackBox heap *) used: INTEGER; (* bytes allocated on system heap *) finalizers: FList; hotFinalizers: FList; cleaners: CList; reducers: Reducer; trapStack: TrapCleaner; actual: Module; (* valid during module initialization *) trapViewer, trapChecker: Handler; trapped, guarded, secondTrap: BOOLEAN; interrupted: BOOLEAN; static, inDll, terminating: BOOLEAN; restart: Command; loader: LoaderHook; loadres: INTEGER; wouldFinalize: BOOLEAN; watcher*: PROCEDURE (event: INTEGER); (* for debugging *) intTrap*: BOOLEAN; PROCEDURE Erase (adr, words: INTEGER); BEGIN ASSERT(words >= 0, 20); WHILE words > 0 DO S.PUT(adr, 0); INC(adr, 4); DEC(words) END END Erase; PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT; PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT; PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY; (* meta extension suport *) PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT; PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT; PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT; PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT; PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT; PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT; PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT; PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT; PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT; PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT; PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT; PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT; PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT; PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT; PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT; PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT; (* -------------------- miscellaneous tools -------------------- *) PROCEDURE IsUpper* (ch: CHAR): BOOLEAN; BEGIN RETURN wctype.iswupper(ORD(ch)) # 0 END IsUpper; PROCEDURE Upper* (ch: CHAR): CHAR; BEGIN RETURN CHR(wctype.towupper(ORD(ch))) END Upper; PROCEDURE IsLower* (ch: CHAR): BOOLEAN; BEGIN RETURN wctype.iswlower(ORD(ch)) # 0 END IsLower; PROCEDURE Lower* (ch: CHAR): CHAR; BEGIN RETURN CHR(wctype.towlower(ORD(ch))) END Lower; PROCEDURE IsAlpha* (ch: CHAR): BOOLEAN; BEGIN RETURN wctype.iswalpha(ORD(ch)) # 0 END IsAlpha; PROCEDURE Utf8ToString* (IN in: ARRAY OF SHORTCHAR; OUT out: ARRAY OF CHAR; OUT res: INTEGER); VAR i, j, val, max: INTEGER; ch: SHORTCHAR; PROCEDURE FormatError(); BEGIN out := in$; res := 2 (*format error*) END FormatError; BEGIN ch := in[0]; i := 1; j := 0; max := LEN(out) - 1; WHILE (ch # 0X) & (j < max) DO IF ch < 80X THEN out[j] := ch; INC(j) ELSIF ch < 0E0X THEN val := ORD(ch) - 192; IF val < 0 THEN FormatError; RETURN END ; ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; out[j] := CHR(val); INC(j) ELSIF ch < 0F0X THEN val := ORD(ch) - 224; ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; ch := in[i]; INC(i); val := val * 64 + ORD(ch) - 128; IF (ch < 80X) OR (ch >= 0E0X) THEN FormatError; RETURN END ; out[j] := CHR(val); INC(j) ELSE FormatError; RETURN END ; ch := in[i]; INC(i) END; out[j] := 0X; IF ch = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END END Utf8ToString; PROCEDURE StringToUtf8* (IN in: ARRAY OF CHAR; OUT out: ARRAY OF SHORTCHAR; OUT res: INTEGER); VAR i, j, val, max: INTEGER; BEGIN i := 0; j := 0; max := LEN(out) - 3; WHILE (in[i] # 0X) & (j < max) DO val := ORD(in[i]); INC(i); IF val < 128 THEN out[j] := SHORT(CHR(val)); INC(j) ELSIF val < 2048 THEN out[j] := SHORT(CHR(val DIV 64 + 192)); INC(j); out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) ELSE out[j] := SHORT(CHR(val DIV 4096 + 224)); INC(j); out[j] := SHORT(CHR(val DIV 64 MOD 64 + 128)); INC(j); out[j] := SHORT(CHR(val MOD 64 + 128)); INC(j) END; END; out[j] := 0X; IF in[i] = 0X THEN res := 0 (*ok*) ELSE res := 1 (*truncated*) END END StringToUtf8; PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR); (* portable *) VAR i, j: INTEGER; ch, lch: CHAR; BEGIN i := 0; ch := name[0]; IF ch # 0X THEN REPEAT head[i] := ch; lch := ch; INC(i); ch := name[i] UNTIL (ch = 0X) OR (ch = ".") OR IsUpper(ch) & ~IsUpper(lch); IF ch = "." THEN i := 0; ch := name[0] END; head[i] := 0X; j := 0; WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END; tail[j] := 0X; IF tail = "" THEN tail := head$; head := "" END ELSE head := ""; tail := "" END END SplitName; PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR); VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR; BEGIN i := 0; WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END; IF name[i] = "." THEN IF name[i + 1] = 0X THEN name[i] := 0X END ELSE IF type = "" THEN ext := docType ELSE ext := type$ END; IF i < LEN(name) - LEN(ext$) - 1 THEN name[i] := "."; INC(i); j := 0; ch := ext[0]; WHILE ch # 0X DO name[i] := Lower(ch); INC(i); INC(j); ch := ext[j] END; name[i] := 0X END END END MakeFileName; (* PROCEDURE Time* (): LONGINT; VAR res: time.int; tp: time.struct_timespec; BEGIN ASSERT(timeResolution >= 1); ASSERT(timeResolution <= 1000000000); res := time.clock_gettime(time.CLOCK_MONOTONIC, tp); ASSERT(res = 0, 100); RETURN tp.tv_sec * LONG(timeResolution) + tp.tv_nsec DIV LONG(1000000000 DIV timeResolution) END Time; *) PROCEDURE Time* (): LONGINT; BEGIN RETURN 0 (* !!! *) END Time; PROCEDURE Beep*; (* !!! *) END Beep; PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER); BEGIN adr := var; m := NIL; IF var # 0 THEN m := modList; WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END; IF m # NIL THEN DEC(adr, m.code) END END END SearchProcVar; (* -------------------- system memory management --------------------- *) PROCEDURE [code] MAP_ANON (): INTEGER "MAP_ANON"; PROCEDURE AllocMem (size: sysmman.size_t; VAR max: sysmman.size_t): ADDRESS; CONST msgstr = "mmap failed errno "; idx = LEN(msgstr); VAR res: fcntl.int; ptr: ADDRESS; msg: ARRAY idx + 5 OF SHORTCHAR; BEGIN max := (size + pagesize - 1) DIV pagesize * pagesize; ptr := sysmman.mmap(0, max, sysmman.PROT_READ + sysmman.PROT_WRITE, sysmman.MAP_PRIVATE + MAP_ANON(), -1, 0); IF ptr = sysmman.MAP_FAILED THEN res := macro.errno(); msg := msgstr; msg[idx + 0] := SHORT(CHR(ORD("0") + res DIV 100 MOD 10)); msg[idx + 1] := SHORT(CHR(ORD("0") + res DIV 10 MOD 10)); msg[idx + 2] := SHORT(CHR(ORD("0") + res MOD 10)); msg[idx + 3] := 0AX; msg[idx + 4] := 0X; res := unistd.write(2, S.ADR(msg), LEN(msg$)); ptr := 0 END; RETURN ptr END AllocMem; PROCEDURE FreeMem (adr: ADDRESS; size: sysmman.size_t); VAR res: sysmman.int; BEGIN size := (size + pagesize - 1) DIV pagesize * pagesize; res := sysmman.munmap(adr, size); ASSERT(res = 0, 100) END FreeMem; PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster); CONST N = 65536; (* cluster size for dll *) VAR adr, allocated, newsize: INTEGER; BEGIN INC(size, 16); ASSERT(size > 0, 100); adr := 0; 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; c.size := allocated - (S.VAL(INTEGER, c) - adr); INC(used, c.size); INC(total, c.size) END; ASSERT((adr = 0) OR (adr MOD 16 = 0) & (c.size >= size), 101); (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *) END AllocHeapMem; PROCEDURE FreeHeapMem (c: Cluster); BEGIN DEC(used, c.size); DEC(total, c.size); FreeMem(S.VAL(ADDRESS, c.max), c.size) END FreeHeapMem; PROCEDURE HeapFull (size: INTEGER): BOOLEAN; BEGIN RETURN TRUE END HeapFull; PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER); BEGIN descAdr := 0; modAdr := 0; descAdr := AllocMem(descSize, descSize); IF descAdr # 0 THEN modAdr := AllocMem(modSize, modSize); IF modAdr = 0 THEN FreeMem(descAdr, descSize) ELSE INC(used, descSize + modSize) END END END AllocModMem; PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER); BEGIN FreeMem(descAdr, descSize); FreeMem(modAdr, modSize); DEC(used, descSize + modSize) END DeallocModMem; PROCEDURE InvalModMem (modSize, modAdr: INTEGER); BEGIN FreeMem(modAdr, modSize) END InvalModMem; PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN; VAR r: BOOLEAN; jmp: setjmp.sigjmp_buf; res: setjmp.int; i: INTEGER; x: BYTE; BEGIN r := checkReadable; jmp := checkReadableEnv; checkReadable := TRUE; res := setjmp.sigsetjmp(checkReadableEnv, 1); IF res = 0 THEN IF from <= to THEN FOR i := from TO to DO S.GET(i, x) END ELSE FOR i := to TO from BY -1 DO S.GET(i, x) END END END; checkReadableEnv := jmp; checkReadable := r; RETURN res = 0 END IsReadable; (* --------------------- NEW implementation (portable) -------------------- *) PROCEDURE^ NewBlock (size: INTEGER): Block; PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *) VAR size, adr: INTEGER; b: Block; tag: Type; l: FList; BEGIN IF ~ODD(typ) THEN tag := S.VAL(Type, typ); b := NewBlock(tag.size); IF b # NIL THEN b.tag := tag; S.GET(typ - 4, size); IF size # 0 THEN (* record uses a finalizer *) l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *) l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *) l.blk := b; l.next := finalizers; finalizers := l END; adr := S.ADR(b.last) ELSE adr := 0 END ELSE HALT(100) (* COM interface pointers not supported *) END; RETURN adr END NewRec; PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *) VAR b: Block; size, headSize: INTEGER; t: Type; BEGIN CASE eltyp OF | -1: HALT(100) (* COM interface pointers not supported *) | 0: eltyp := S.ADR(PtrType) | 1: eltyp := S.ADR(Char8Type) | 2: eltyp := S.ADR(Int16Type) | 3: eltyp := S.ADR(Int8Type) | 4: eltyp := S.ADR(Int32Type) | 5: eltyp := S.ADR(BoolType) | 6: eltyp := S.ADR(SetType) | 7: eltyp := S.ADR(Real32Type) | 8: eltyp := S.ADR(Real64Type) | 9: eltyp := S.ADR(Char16Type) | 10: eltyp := S.ADR(Int64Type) | 11: eltyp := S.ADR(ProcType) | 12: eltyp := S.ADR(UPtrType) ELSE ASSERT(~ODD(eltyp), 101) (* COM interface pointers not supported *) END; t := S.VAL(Type, eltyp); headSize := 4 * nofdim + 12; size := headSize + nofelem * t.size; b := NewBlock(size); IF b # NIL THEN b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *) b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *) b.first := S.ADR(b.last) + headSize; (* pointer to first elem *) RETURN S.ADR(b.last) ELSE RETURN 0 END; END NewArr; (* -------------------- handler installation (portable) --------------------- *) PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR; VAR l: FList; BEGIN ASSERT(id.typ # 0, 100); l := finalizers; WHILE l # NIL DO IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last)); IF id.Identified() THEN RETURN id.obj END END; l := l.next END; RETURN NIL END ThisFinObj; PROCEDURE InstallReducer* (r: Reducer); BEGIN r.next := reducers; reducers := r END InstallReducer; PROCEDURE InstallTrapViewer* (h: Handler); BEGIN trapViewer := h END InstallTrapViewer; PROCEDURE InstallTrapChecker* (h: Handler); BEGIN trapChecker := h END InstallTrapChecker; PROCEDURE PushTrapCleaner* (c: TrapCleaner); VAR t: TrapCleaner; BEGIN t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END; ASSERT(t = NIL, 20); c.next := trapStack; trapStack := c END PushTrapCleaner; PROCEDURE PopTrapCleaner* (c: TrapCleaner); VAR t: TrapCleaner; BEGIN t := NIL; WHILE (trapStack # NIL) & (t # c) DO t := trapStack; trapStack := trapStack.next END END PopTrapCleaner; PROCEDURE InstallCleaner* (p: Command); VAR c: CList; BEGIN c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *) c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c END InstallCleaner; PROCEDURE RemoveCleaner* (p: Command); VAR c0, c: CList; BEGIN c := cleaners; c0 := NIL; WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END; IF c # NIL THEN IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END END END RemoveCleaner; PROCEDURE Cleanup*; VAR c, c0: CList; BEGIN c := cleaners; c0 := NIL; WHILE c # NIL DO IF ~c.trapped THEN c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c ELSE IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END END; c := c.next END END Cleanup; (* -------------------- meta information (portable) --------------------- *) PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF CHAR): Module, NEW, ABSTRACT; PROCEDURE SetLoaderHook*(h: LoaderHook); BEGIN loader := h END SetLoaderHook; PROCEDURE InitModule (mod: Module); (* initialize linked modules *) VAR body: Command; BEGIN IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END; IF ~(init IN mod.opts) THEN body := S.VAL(Command, mod.code); INCL(mod.opts, init); actual := mod; body(); actual := NIL END END InitModule; PROCEDURE ThisLoadedMod* (IN name: ARRAY OF CHAR): Module; (* loaded modules only *) VAR m: Module; res: INTEGER; n: Utf8Name; BEGIN StringToUtf8(name, n, res); ASSERT(res = 0); loadres := done; m := modList; WHILE (m # NIL) & ((m.name # n) OR (m.refcnt < 0)) DO m := m.next END; IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END; IF m = NIL THEN loadres := moduleNotFound END; RETURN m END ThisLoadedMod; PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module; BEGIN IF loader # NIL THEN loader.res := done; RETURN loader.ThisMod(name) ELSE RETURN ThisLoadedMod(name) END END ThisMod; PROCEDURE LoadMod* (IN name: ARRAY OF CHAR); VAR m: Module; BEGIN m := ThisMod(name) END LoadMod; PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR); BEGIN IF loader # NIL THEN res := loader.res; importing := loader.importing$; imported := loader.imported$; object := loader.object$ ELSE res := loadres; importing := ""; imported := ""; object := "" END END GetLoaderResult; PROCEDURE ThisObject* (mod: Module; IN name: ARRAY OF CHAR): Object; VAR l, r, m, res: INTEGER; p: StrPtr; n: Utf8Name; BEGIN StringToUtf8(name, n, res); ASSERT(res = 0); l := 0; r := mod.export.num; WHILE l < r DO (* binary search *) m := (l + r) DIV 2; p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256])); IF p^ = n THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END; IF p^ < n THEN l := m + 1 ELSE r := m END END; RETURN NIL END ThisObject; PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object; VAR i, n: INTEGER; BEGIN i := 0; n := mod.export.num; WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END; INC(i) END; RETURN NIL END ThisDesc; PROCEDURE ThisField* (rec: Type; IN name: ARRAY OF CHAR): Object; VAR n, res: INTEGER; p: StrPtr; obj: Object; m: Module; nn: Utf8Name; BEGIN StringToUtf8(name, nn, res); ASSERT(res = 0); m := rec.mod; obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num; WHILE n > 0 DO p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256])); IF p^ = nn THEN RETURN obj END; DEC(n); INC(S.VAL(INTEGER, obj), 16) END; RETURN NIL END ThisField; PROCEDURE ThisCommand* (mod: Module; IN name: ARRAY OF CHAR): Command; VAR x: Object; sig: Signature; BEGIN x := ThisObject(mod, name); IF (x # NIL) & (x.id MOD 16 = mProc) THEN sig := S.VAL(Signature, x.struct); IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END END; RETURN NIL END ThisCommand; PROCEDURE ThisType* (mod: Module; IN name: ARRAY OF CHAR): Type; VAR x: Object; BEGIN x := ThisObject(mod, name); IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN RETURN x.struct ELSE RETURN NIL END END ThisType; PROCEDURE TypeOf* (IN rec: ANYREC): Type; BEGIN RETURN S.VAL(Type, S.TYP(rec)) END TypeOf; PROCEDURE LevelOf* (t: Type): SHORTINT; BEGIN RETURN SHORT(t.id DIV 16 MOD 16) END LevelOf; PROCEDURE NewObj* (VAR o: S.PTR; t: Type); VAR i: INTEGER; BEGIN IF t.size = -1 THEN o := NIL ELSE i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END; IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *) o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *) END END NewObj; PROCEDURE GetModName* (mod: Module; OUT name: Name); VAR res: INTEGER; BEGIN Utf8ToString(mod.name, name, res); ASSERT(res = 0) END GetModName; PROCEDURE GetObjName* (mod: Module; obj: Object; OUT name: Name); VAR p: StrPtr; res: INTEGER; BEGIN p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256])); Utf8ToString(p^$, name, res); ASSERT(res = 0) END GetObjName; PROCEDURE GetTypeName* (t: Type; OUT name: Name); VAR p: StrPtr; res: INTEGER; BEGIN p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256])); Utf8ToString(p^$, name, res); ASSERT(res = 0) END GetTypeName; PROCEDURE RegisterMod* (mod: Module); VAR i: INTEGER; epoch: time.time_t; tm: time.struct_tm; ptm: time.Pstruct_tm; BEGIN mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0; WHILE i < mod.nofimps DO IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END; INC(i) END; epoch := time.time(NIL); ptm := time.localtime_r(epoch, tm); IF ptm # NIL THEN mod.loadTime[0] := SHORT(tm.tm_year + 1900); mod.loadTime[1] := SHORT(tm.tm_mon + 1); mod.loadTime[2] := SHORT(tm.tm_mday); mod.loadTime[3] := SHORT(tm.tm_hour); mod.loadTime[4] := SHORT(tm.tm_min); mod.loadTime[5] := SHORT(tm.tm_sec) ELSE mod.loadTime[0] := 0; mod.loadTime[1] := 0; mod.loadTime[2] := 0; mod.loadTime[3] := 0; mod.loadTime[4] := 0; mod.loadTime[5] := 0 END; IF ~(init IN mod.opts) THEN InitModule(mod) END END RegisterMod; PROCEDURE^ Collect*; PROCEDURE UnloadMod* (mod: Module); VAR i: INTEGER; t: Command; BEGIN IF mod.refcnt = 0 THEN t := mod.term; mod.term := NIL; IF t # NIL THEN t() END; (* terminate module *) i := 0; WHILE i < mod.nofptrs DO (* release global pointers *) S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i) END; Collect; (* call finalizers *) i := 0; WHILE i < mod.nofimps DO (* release imported modules *) IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END; INC(i) END; mod.refcnt := -1; IF dyn IN mod.opts THEN (* release memory *) InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs) END END END UnloadMod; (* -------------------- dynamic procedure call --------------------- *) (* 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) --------------------- *) PROCEDURE RefCh (VAR ref: INTEGER; OUT ch: SHORTCHAR); BEGIN S.GET(ref, ch); INC(ref) END RefCh; PROCEDURE RefNum (VAR ref: INTEGER; OUT x: INTEGER); VAR s, n: INTEGER; ch: SHORTCHAR; BEGIN s := 0; n := 0; RefCh(ref, ch); WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END; x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) END RefNum; PROCEDURE RefName (VAR ref: INTEGER; OUT n: Utf8Name); VAR i: INTEGER; ch: SHORTCHAR; BEGIN i := 0; RefCh(ref, ch); WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END; n[i] := 0X END RefName; PROCEDURE GetRefProc* (VAR ref: INTEGER; OUT adr: INTEGER; OUT name: Utf8Name); VAR ch: SHORTCHAR; BEGIN S.GET(ref, ch); WHILE ch >= 0FDX DO (* skip variables *) INC(ref); RefCh(ref, ch); IF ch = 10X THEN INC(ref, 4) END; RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch) END; WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *) INC(ref); RefNum(ref, adr); S.GET(ref, ch) END; IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name) ELSE adr := 0 END END GetRefProc; PROCEDURE GetRefVar* (VAR ref: INTEGER; OUT mode, form: SHORTCHAR; OUT desc: Type; OUT adr: INTEGER; OUT name: Utf8Name); BEGIN S.GET(ref, mode); desc := NIL; IF mode >= 0FDX THEN mode := SHORT(CHR(ORD(mode) - 0FCH)); INC(ref); RefCh(ref, form); IF form = 10X THEN S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4)) END; RefNum(ref, adr); RefName(ref, name) ELSE mode := 0X; form := 0X; adr := 0 END END GetRefVar; PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER; VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Utf8Name; BEGIN IF mod # NIL THEN (* mf, 12.02.04 *) ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch); WHILE ch # 0X DO WHILE (ch > 0X) & (ch < 0FCX) DO (* srcref: {dAdr,dPos} *) INC(ad, ORD(ch)); INC(ref); RefNum(ref, d); IF ad > codePos THEN RETURN pos END; INC(pos, d); S.GET(ref, ch) END; IF ch = 0FCX THEN (* proc: 0FCX,Adr,Name *) INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch); IF (d > codePos) & (pos > 0) THEN RETURN pos END END; WHILE ch >= 0FDX DO (* skip variables: Mode, Form, adr, Name *) INC(ref); RefCh(ref, ch); IF ch = 10X THEN INC(ref, 4) END; RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) END END; END; RETURN -1 END SourcePos; PROCEDURE LoadDll* (IN name: ARRAY OF CHAR; VAR ok: BOOLEAN); VAR h: ADDRESS; file: Utf8Name; res: INTEGER; BEGIN StringToUtf8(name, file, res); IF res = 0 THEN h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); ok := h # 0 ELSE ok := FALSE END END LoadDll; PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF CHAR): INTEGER; VAR h, p: ADDRESS; file, sym: Utf8Name; res: INTEGER; err: dlfcn.int; BEGIN StringToUtf8(dll, file, res); IF res = 0 THEN h := dlfcn.dlopen(file, dlfcn.RTLD_LAZY + dlfcn.RTLD_GLOBAL); IF h # 0 THEN StringToUtf8(name, sym, res); IF res = 0 THEN p := dlfcn.dlsym(h, sym) ELSE p := 0 END; err := dlfcn.dlclose(h); ASSERT(err = 0, 100) ELSE p := 0 END ELSE p := 0 END; RETURN p END ThisDllObj; (* -------------------- garbage collector (portable) --------------------- *) PROCEDURE Mark (this: Block); VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER; BEGIN IF ~ODD(S.VAL(INTEGER, this.tag)) THEN father := NIL; LOOP INC(S.VAL(INTEGER, this.tag)); flag := S.VAL(INTEGER, this.tag) MOD 4; tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); IF flag >= 2 THEN actual := this.first; this.actual := actual ELSE actual := S.ADR(this.last) END; LOOP offset := tag.ptroffs[0]; IF offset < 0 THEN INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *) IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *) INC(actual, tag.size); this.actual := actual ELSE (* up *) this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); IF father = NIL THEN RETURN END; son := this; this := father; flag := S.VAL(INTEGER, this.tag) MOD 4; tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag); offset := tag.ptroffs[0]; IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END; S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last)); INC(S.VAL(INTEGER, tag), 4) END ELSE S.GET(actual + offset, son); IF son # NIL THEN DEC(S.VAL(INTEGER, son), 4); IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *) this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag); S.PUT(actual + offset, father); father := this; this := son; EXIT END END; INC(S.VAL(INTEGER, tag), 4) END END END END END Mark; PROCEDURE MarkGlobals; VAR m: Module; i, p: INTEGER; BEGIN m := modList; WHILE m # NIL DO IF m.refcnt >= 0 THEN i := 0; WHILE i < m.nofptrs DO S.GET(m.varBase + m.ptrs[i], p); INC(i); IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END END END; m := m.next END END MarkGlobals; PROCEDURE Next (b: Block): Block; (* next block in same cluster *) VAR size: INTEGER; BEGIN S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size); IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END; RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16) END Next; PROCEDURE CheckCandidates; (* pre: nofcand > 0 *) VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block; BEGIN (* sort candidates (shellsort) *) h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand; REPEAT h := h DIV 3; i := h; WHILE i < nofcand DO p := candidates[i]; j := i; WHILE (j >= h) & (candidates[j-h] > p) DO candidates[j] := candidates[j-h]; j := j-h END; candidates[j] := p; INC(i) END UNTIL h = 1; (* sweep *) c := root; i := 0; WHILE c # NIL DO blk := S.VAL(Block, S.VAL(INTEGER, c) + 12); end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16; WHILE candidates[i] < S.VAL(INTEGER, blk) DO INC(i); IF i = nofcand THEN RETURN END END; WHILE S.VAL(INTEGER, blk) < end DO next := Next(blk); IF candidates[i] < S.VAL(INTEGER, next) THEN IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *) & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN Mark(blk) END; REPEAT INC(i); IF i = nofcand THEN RETURN END UNTIL candidates[i] >= S.VAL(INTEGER, next) END; IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *) Mark(blk) END; blk := next END; c := c.next END END CheckCandidates; PROCEDURE MarkLocals; VAR sp, p, min, max: INTEGER; c: Cluster; BEGIN sp := S.ADR(sp); nofcand := 0; c := root; WHILE c.next # NIL DO c := c.next END; min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size; WHILE sp < baseStack DO S.GET(sp, p); IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN candidates[nofcand] := p; INC(nofcand); IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END END; INC(sp, 4) END; candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*) IF nofcand > 0 THEN CheckCandidates END END MarkLocals; PROCEDURE MarkFinObj; VAR f: FList; BEGIN wouldFinalize := FALSE; f := finalizers; WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; Mark(f.blk); f := f.next END; f := hotFinalizers; WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END; Mark(f.blk); f := f.next END END MarkFinObj; PROCEDURE CheckFinalizers; VAR f, g, h, k: FList; BEGIN f := finalizers; g := NIL; IF hotFinalizers = NIL THEN k := NIL ELSE k := hotFinalizers; WHILE k.next # NIL DO k := k.next END END; WHILE f # NIL DO h := f; f := f.next; IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN IF g = NIL THEN finalizers := f ELSE g.next := f END; IF k = NIL THEN hotFinalizers := h ELSE k.next := h END; k := h; h.next := NIL ELSE g := h END END; h := hotFinalizers; WHILE h # NIL DO Mark(h.blk); h := h.next END END CheckFinalizers; PROCEDURE ExecFinalizer (a, b, c: INTEGER); VAR f: FList; fin: PROCEDURE(this: ANYPTR); BEGIN f := S.VAL(FList, a); S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *) IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END; END ExecFinalizer; PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *) PROCEDURE CallFinalizers; VAR f: FList; BEGIN WHILE hotFinalizers # NIL DO f := hotFinalizers; hotFinalizers := hotFinalizers.next; Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0) END; wouldFinalize := FALSE END CallFinalizers; PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *) VAR i: INTEGER; BEGIN blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size)); i := MIN(N - 1, (blk.size DIV 16)); blk.next := free[i]; free[i] := blk END Insert; PROCEDURE Sweep (dealloc: BOOLEAN); VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER; BEGIN cluster := root; last := NIL; allocated := 0; i := N; REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; WHILE cluster # NIL DO blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12); end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16; fblk := NIL; WHILE S.VAL(INTEGER, blk) < end DO next := Next(blk); IF ODD(S.VAL(INTEGER, blk.tag)) THEN IF fblk # NIL THEN Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk)); fblk := NIL END; DEC(S.VAL(INTEGER, blk.tag)); (* unmark *) INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk)) ELSIF fblk = NIL THEN fblk := S.VAL(FreeBlock, blk) END; blk := next END; IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *) c := cluster; cluster := cluster.next; IF last = NIL THEN root := cluster ELSE last.next := cluster END; FreeHeapMem(c) ELSE IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END; last := cluster; cluster := cluster.next END END; (* reverse free list *) i := N; REPEAT DEC(i); b := free[i]; fblk := sentinel; WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END; free[i] := fblk UNTIL i = 0 END Sweep; PROCEDURE Collect*; BEGIN IF root # NIL THEN CallFinalizers; (* trap cleanup *) MarkGlobals; MarkLocals; CheckFinalizers; Sweep(TRUE); CallFinalizers END END Collect; PROCEDURE FastCollect*; BEGIN IF root # NIL THEN MarkGlobals; MarkLocals; MarkFinObj; Sweep(FALSE) END END FastCollect; PROCEDURE WouldFinalize* (): BOOLEAN; BEGIN RETURN wouldFinalize END WouldFinalize; (* --------------------- memory allocation (portable) -------------------- *) PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *) VAR b, l: FreeBlock; s, i: INTEGER; BEGIN s := size - 4; i := MIN(N - 1, s DIV 16); WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END; b := free[i]; l := NIL; WHILE b.size < s DO l := b; b := b.next END; IF b # sentinel THEN IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END ELSE b := NIL END; RETURN b END OldBlock; PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *) VAR b, l: FreeBlock; s, i: INTEGER; BEGIN s := limit - 4; i := 0; REPEAT b := free[i]; l := NIL; WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END; IF b # sentinel THEN IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END ELSE b := NIL END; INC(i) UNTIL (b # NIL) OR (i = N); RETURN b END LastBlock; PROCEDURE NewBlock (size: INTEGER): Block; VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer; BEGIN ASSERT(size >= 0, 20); IF size > MAX(INTEGER) - 19 THEN RETURN NIL END; tsize := (size + 19) DIV 16 * 16; b := OldBlock(tsize); (* 1) search for free block *) IF b = NIL THEN FastCollect; b := OldBlock(tsize); (* 2) collect *) IF b = NIL THEN Collect; b := OldBlock(tsize); (* 2a) fully collect *) END; IF b = NIL THEN AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *) IF new # NIL THEN IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN new.next := root; root := new ELSE c := root; WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END; new.next := c.next; c.next := new END; b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12); b.size := (new.size - 12) DIV 16 * 16 - 4 ELSE RETURN NIL (* 4) give up *) END END END; (* b # NIL *) a := b.size + 4 - tsize; IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END; IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END; INC(allocated, tsize); RETURN S.VAL(Block, b) END NewBlock; PROCEDURE Allocated* (): INTEGER; BEGIN RETURN allocated END Allocated; PROCEDURE Used* (): INTEGER; BEGIN RETURN used END Used; PROCEDURE Root* (): INTEGER; BEGIN RETURN S.VAL(INTEGER, root) END Root; (* -------------------- Trap Handling --------------------- *) PROCEDURE [code] GetDLink (): DLink "(Kernel_DLink)SYSTEM_dlink"; PROCEDURE [code] SetDLink (dl: DLink) "SYSTEM_dlink = (SYSTEM_DLINK*)dl"; PROCEDURE Start* (code: Command); VAR res: setjmp.int; dl: DLink; BEGIN restart := code; baseStack := S.ADR(code); (* XXX: expected that target uses one stack *) startDLink := GetDLink(); res := setjmp.sigsetjmp(startEnv, 1); restart END Start; PROCEDURE Quit* (exitCode: INTEGER); VAR m: Module; term: Command; t: BOOLEAN; BEGIN trapViewer := NIL; trapChecker := NIL; restart := NIL; t := terminating; terminating := TRUE; m := modList; WHILE m # NIL DO (* call terminators *) IF ~static OR ~t THEN term := m.term; m.term := NIL; IF term # NIL THEN term() END END; m := m.next END; CallFinalizers; hotFinalizers := finalizers; finalizers := NIL; CallFinalizers; stdlib.exit(exitCode) END Quit; PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR); VAR res: stdio.int; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR; BEGIN title := "Error xy"; title[6] := CHR(id DIV 10 + ORD("0")); title[7] := CHR(id MOD 10 + ORD("0")); res := unistd.write(2, S.ADR(title), 8); stdlib.abort END FatalError; PROCEDURE DefaultTrapViewer; VAR out: ARRAY 256 OF SHORTCHAR; c, len: INTEGER; res: unistd.int; dl: DLink; PROCEDURE WriteString (IN s: ARRAY OF SHORTCHAR); VAR i: INTEGER; BEGIN i := 0; WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END END WriteString; PROCEDURE WriteHex (x, n: INTEGER); VAR i, y: INTEGER; BEGIN IF len + n < LEN(out) THEN i := len + n - 1; WHILE i >= len DO y := x MOD 16; x := x DIV 16; IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END; out[i] := SHORT(CHR(y + ORD("0"))); DEC(i) END; INC(len, n) END END WriteHex; PROCEDURE WriteLn; BEGIN IF len < LEN(out) - 1 THEN out[len] := 0AX; INC(len) END END WriteLn; BEGIN len := 0; WriteString("====== "); IF err = 129 THEN WriteString("invalid with") ELSIF err = 130 THEN WriteString("invalid case") ELSIF err = 131 THEN WriteString("function without return") ELSIF err = 132 THEN WriteString("type guard") ELSIF err = 133 THEN WriteString("implied type guard") ELSIF err = 134 THEN WriteString("value out of range") ELSIF err = 135 THEN WriteString("index out of range") ELSIF err = 136 THEN WriteString("string too long") ELSIF err = 137 THEN WriteString("stack overflow") ELSIF err = 138 THEN WriteString("integer overflow") ELSIF err = 139 THEN WriteString("division by zero") ELSIF err = 140 THEN WriteString("infinite real result") ELSIF err = 141 THEN WriteString("real underflow") ELSIF err = 142 THEN WriteString("real overflow") ELSIF err = 143 THEN WriteString("undefined real result") ELSIF err = 144 THEN WriteString("not a number") ELSIF err = 200 THEN WriteString("keyboard interrupt") ELSIF err = 201 THEN WriteString("NIL dereference") ELSIF err = 202 THEN WriteString("illegal instruction: "); WriteHex(val, 4) ELSIF err = 203 THEN WriteString("illegal memory read [ad = "); WriteHex(val, 8); WriteString("]") ELSIF err = 204 THEN WriteString("illegal memory write [ad = "); WriteHex(val, 8); WriteString("]") ELSIF err = 205 THEN WriteString("illegal execution [ad = "); WriteHex(val, 8); WriteString("]") ELSIF err = 257 THEN WriteString("out of memory") ELSIF err = 10001H THEN WriteString("bus error") ELSIF err = 10002H THEN WriteString("address error") ELSIF err = 10007H THEN WriteString("fpu error") ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2) ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10; WriteString("trap #"); WriteHex(err, 3) END; WriteString(" ======"); WriteLn; dl := GetDLink(); (* skip Kernel.DefaultTrapViewer & Kernel.Trap/Kernel.TrapHandler *) c := 2; WHILE (c > 0) & (dl # NIL) DO dl := dl.next; DEC(c) END; (* stack trace *) c := 16; WHILE (c > 0) & (dl # NIL) DO WriteString("- "); WriteString(dl.name$); WriteLn; dl := dl.next; DEC(c) END; out[len] := 0X; res := unistd.write(2, S.ADR(out), len) END DefaultTrapViewer; PROCEDURE TrapCleanup; VAR t: TrapCleaner; BEGIN WHILE trapStack # NIL DO t := trapStack; trapStack := trapStack.next; t.Cleanup END; IF (trapChecker # NIL) & (err # 128) THEN trapChecker END END TrapCleanup; PROCEDURE SetTrapGuard* (on: BOOLEAN); BEGIN guarded := on END SetTrapGuard; PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER); VAR oldIsTry: BOOLEAN; oldTryEnv: setjmp.jmp_buf; oldTryDLink: DLink; res: setjmp.int; BEGIN oldIsTry := isTry; oldTryEnv := tryEnv; oldTryDLink := tryDLink; isTry := TRUE; tryDLink := GetDLink(); res := setjmp._setjmp(tryEnv); IF res = 0 THEN h(a, b, c) END; isTry := oldIsTry; tryEnv := oldTryEnv; tryDLink := oldTryDLink END Try; PROCEDURE Trap* (n: INTEGER); BEGIN IF trapped THEN DefaultTrapViewer; IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END END; IF n >= 0 THEN err := n ELSE err := -n + 128 END; pc := 0; sp := 0; fp := 0; stack := 0; val := 0; INC(trapCount); (* !!! InitFPU *) TrapCleanup; IF isTry THEN SetDLink(tryDLink); setjmp._longjmp(tryEnv, 1) END; IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *) ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN trapped := TRUE; trapViewer() ELSE DefaultTrapViewer END; trapped := FALSE; secondTrap := FALSE; IF restart # NIL THEN SetDLink(startDLink); setjmp.siglongjmp(startEnv, 1) END; stdlib.abort END Trap; PROCEDURE [ccall] TrapHandler (signo: signal.int; IN info: signal.siginfo_t; context: ADDRESS); VAR res: signal.int; BEGIN IF checkReadable THEN setjmp.siglongjmp(checkReadableEnv, 1) END; IF trapped THEN DefaultTrapViewer; IF ~secondTrap THEN trapped := FALSE; secondTrap := TRUE END END; err := -signo; pc := 0; sp := 0; fp := 0; stack := baseStack; val := 0; CASE signo OF | signal.SIGFPE: val := info.si_code; pc := info.info.sigfpe.si_addr; CASE info.si_code OF | signal.FPE_INTDIV: err := 139 (* division by zero *) | signal.FPE_INTOVF: err := 138 (* integer overflow *) | signal.FPE_FLTDIV: err := 140 (* fpu: division by zero *) | signal.FPE_FLTOVF: err := 142 (* fpu: overflow *) | signal.FPE_FLTUND: err := 141 (* fpu: underflow *) (* !!! | signal.FPE_FLTRES: err := ??? (* fpu: *) *) | signal.FPE_FLTINV: err := 143 (* val := opcode *) (* fpu: invalid op *) (* !!! | signal.FPE_FLTSUB: err := ??? (* fpu: *) *) ELSE (* unknown *) END | signal.SIGINT: val := info.si_code; err := 200 (* keyboard interrupt *) | signal.SIGSEGV: val := info.info.sigsegv.si_addr; err := 203 (* illigal read *) | signal.SIGBUS: val := info.info.sigbus.si_addr; err := 10001H (* bus error *) | signal.SIGILL: pc := info.info.sigill.si_addr; err := 202; (* illigal instruction *) IF IsReadable(pc, pc + 4) THEN S.GET(pc, val) END; ELSE (* unknown *) END; INC(trapCount); (* !!! InitFPU *) TrapCleanup; IF isTry THEN setjmp._longjmp(tryEnv, 1) END; IF (err = 128) OR (err = 200) & ~intTrap THEN (* do nothing *) ELSIF (trapViewer # NIL) & (restart # NIL) & ~trapped & ~guarded THEN trapped := TRUE; trapViewer() ELSE DefaultTrapViewer END; trapped := FALSE; secondTrap := FALSE; IF restart # NIL THEN setjmp.siglongjmp(startEnv, 1) END; stdlib.abort END TrapHandler; (* -------------------- Initialization --------------------- *) PROCEDURE InstallTrap (signo: signal.int); VAR act: signal._struct_sigaction; (* !!! CPfront hack *) res: signal.int; BEGIN act.sa_handler := NIL; res := signal.sigemptyset(act.sa_mask); act.sa_flags := signal.SA_NODEFER + signal.SA_SIGINFO; act.sa_sigaction := TrapHandler; res := signal.sigaction(signo, S.VAL(signal.struct_sigaction, act), NIL); END InstallTrap; PROCEDURE InstallTrapVectors; BEGIN InstallTrap(signal.SIGFPE); InstallTrap(signal.SIGINT); InstallTrap(signal.SIGSEGV); InstallTrap(signal.SIGBUS); InstallTrap(signal.SIGILL) END InstallTrapVectors; PROCEDURE RemoveTrapVectors; END RemoveTrapVectors; PROCEDURE Init; VAR i: INTEGER; BEGIN intTrap := TRUE; baseStack := S.ADR(i); (* XXX *) pagesize := unistd.sysconf(unistd._SC_PAGESIZE); (* init heap *) allocated := 0; total := 0; used := 0; sentinelBlock.size := MAX(INTEGER); sentinel := S.ADR(sentinelBlock); i := N; REPEAT DEC(i); free[i] := sentinel UNTIL i = 0; IF ~inDll THEN InstallTrapVectors END; (* !!! InitFPU *) IF ~static THEN InitModule(modList); IF ~inDll THEN Quit(1) END END END Init; PROCEDURE [code] SYSTEM_argCount (): INTEGER "SYSTEM_argCount"; PROCEDURE [code] SYSTEM_argVector (): ArrStrPtr "(Kernel_ArrStrPtr)SYSTEM_argVector"; PROCEDURE [code] SYSTEM_modlist (): Module "(Kernel_Module)SYSTEM_modlist"; BEGIN IF modList = NIL THEN (* only once *) argc := SYSTEM_argCount(); argv := SYSTEM_argVector(); modList := SYSTEM_modlist(); static := init IN modList.opts; inDll := dll IN modList.opts; Init END CLOSE IF ~terminating THEN terminating := TRUE; Quit(0) END END Kernel.