№4#Syntax10.Scn.FntSyntax10i.Scn.FntшћџџаћаћInfoElemsAllocTSyntax10.Scn.FntЄїџџџанРдStampElemsAlloc4 Nov 4Ф"Title": Kernel "Author": RC 23.7.92 / MH 3.2.1994 / 5.5.94 / MAD 1.6.1994 / RLI "Abstract": Basic OS functions "Keywords": "Version": 1.2 "From": 1992 "Until":  "Changes": Finalization due to J. Templ Notifier queues added by RLI ExceptionInfo added by RLI for enhanced Trap-Viewers 1 Jul 97 RLI Interface adaptions for HeapInspector 21 Aug 97 RLI Exception info moved to Module Unix 21 Aug 97 RLI Stacks inserted (needed for Debugger) 22 Aug 97 RLI GC - Algorithm changed for multiple Stacks (taken from Windows) 22 Aug 97 RLI Mark algorithm checks for LONGINT - values only if they point inside heap 09 Nov 98 RLI Adaption for glibc 17 Dec 98 RLI suspendThreads and resumeThreads inserted for thread safety support 26 Jan 99 RLI Removed Stack handling (done by pthread - library). Added multithread support for GC and memory allocation "Hints": WARNING: do not use NEW nor SYSTEM.NEW in this module !! use NewRec, NewArr or NewSys insteadvџџџpА­VersionElemsAllocBeg#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5$Syntax10i.Scn.FntLibc5pА­VersionElemsAllocEndSyntax10b.Scn.FntLqџџџpА­#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5#Syntax10.Scn.Fnt "libc.so.5" pА­,+            -АбBA         ОЅўџџpА­#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5XSyntax10b.Scn.Fnt Syntax10.Scn.Fnt/% 1Ђsigjmpsave*: PROCEDURE (env: Jmpbuf; savemask: LONGINT); setjmp*: PROCEDURE (env: Jmpbuf): LONGINT; siglongjmp*: PROCEDURE (env: Jmpbuf; val: LONGINT): LONGINT;#1 2#pА­ /%$    4m   = R< š  1! u" & 6A!   0g   8џџџџ€8РдFoldElemsNew9џџџџ€8Рдџџџџ€8Рд]џџџџ€8Рдџџџџ€8Рдˆџџџџ€8Рдџџџџ€8Рд‹џџџџ€8Рдџџџџ€8Рд€џџџџ€8Рдџџџџ€8Рд'џџџџ€8Рд)џџџџ€8РдКџџџџ€8Рдџџџџ€8Рдџџџџ€8Рд џџџџ€8Рдjџџџџ€8Рд$џџџџ€8РдRџџџџ€8Рд  џџџџ€8Рд/Vџџџџ€8Рд џџџџ€8Рд\џџџџ€8Рд #7џџџџ€8Рд<џџџџ€8Рдџџџџ€8Рд#N+џџџџ€8Рд &џџџџ€8Рд,Оџџџџ€8Рд џџџџ€8Рдtџџџџ€8Рд  џџџџ€8Рдcџџџџ€8Рд џџџџ€8Рдџџџџ€8РдI#џџџџ€8РдG RŒ / жџџџџ€8Рд ќџџџРдА­MarkElemsAlloc\>џџџџ€8Рд =h/TЕ6"~3a3%6=[t! MМqАHJd3/+Z 4$OB J"**О60‚џџџџ€8Рд ќџџџРдА­uЇџџџџ€8РдБQJџџџџ€8Рд ќџџџРдА­YTџџџџ€8РдлХ Дњџџџџ€8Рд џџџџ€8РдQ9!Ё(џџџџ€8Рд$џџџџ€8Рд—%„џџџџ€8РдќџџџРдА­`>4џџџџ€8Рд_90%$M“)=єCџџџџ€8Рд ќџџџРдА­a>:џџџџ€8РдNZNB+.ƒџџџџ€8Рд ќџџџРдА­GЕџџџџ€8Рдњџџџџ€8Рд Gџџџџ€8Рд2џџџџ€8Рд0џџџџ€8РдCџџџџ€8Рд џџџџ€8Рд>Ъџџџ€8Рд#Syntax10.Scn.Fnttraverse all modulesHЪџџџ€8Рд#Syntax10.Scn.Fntmark global pointers80џџџџ€8Рд8Ъџџџ€8Рд#Syntax10.Scn.Fntmark typedescriptorsUџџџџ€8Рдџџџџ€8Рд[Љџџџџ€8РдFџџџџ€8Рдtџџџџ€8Рд џџџџ€8Рд/Ќџџџџ€8РдJ-0/џџџџ€8РдbpЅƒкџџџџ€8Рд џџџџ€8Рд /3/џџџџ€8Рд "џџџџ€8Рд(­џџџџ€8Рд 9џџџџ€8Рд1j‚!!N(Ќџџџџ€8РдK  џџџџ€8Рдяџџџџ€8Рд  џџџџ€8РдXџџџџ€8Рд /џџџџ€8Рд1џџџџ€8Рд  џџџџ€8Рд%џџџџ€8Рд =џџџџ€8Рд5џџџџ€8Рдџџџџ€8РдC€+Ђuџџџџ€8Рдџџџџ€8Рд@џџџџ€8Рдџџџџ€8Рддџџџџ€8Рдџџџџ€8Рд!73$џџџџ€8Рдџџџџ€8РдQh+r98џџџpА­#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5#Syntax10.Scn.Fntnndlsym(libc, "sigjmpsave", S.VAL(LONGINT, sigjmpsave)); dlsym(libc, "siglongjmp", S.VAL(LONGINT, siglongjmp));fpА­Лт2Ўџџџџ€8Рд НˆMODULE Kernel;  (* Libc6 *) IMPORT S := SYSTEM; CONST MarkBit* = 0; SignalStackSize = 64000; SIGBLOCK = 1; SIGSETMASK = 3; libCName = "libc.so.6"; wrapperLibName = "libobwrapper.so"; TYPE Name* = ARRAY 32 OF CHAR; Tag* = POINTER TO TypeDesc; ADDRESS = LONGINT; Cmd* = RECORD name*: Name; adr*: ADDRESS END; TerminationHandler* = PROCEDURE; Module* = POINTER TO ModuleDesc; ModuleDesc* = RECORD next*: Module; name*: Name; init*: BOOLEAN; key*, refcnt*, sb*: LONGINT; varEntries*: POINTER TO ARRAY OF ADDRESS; entries*: POINTER TO ARRAY OF ADDRESS; cmds*: POINTER TO ARRAY OF Cmd; ptrTab*: POINTER TO ARRAY OF ADDRESS; tdescs*: POINTER TO ARRAY OF (* Tag *) ADDRESS; imports*: POINTER TO ARRAY OF (* Module*) ADDRESS; data*, code*: POINTER TO ARRAY OF CHAR; refs*: POINTER TO ARRAY OF CHAR; term*: TerminationHandler END; Jmpbuf* = ARRAY 39 OF LONGINT; (* bx, si, di, bp, sp, pc. masksaved, mask *) Timeval = RECORD sec, usec: LONGINT END ; Timezone = RECORD minuteswest, dsttime: LONGINT END ; Time = POINTER TO RECORD sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: LONGINT END ; Sigaltstack = RECORD sp, size: LONGINT; flags: SET END ; SignalHandler* = PROCEDURE (sig: LONGINT); Sigmask = SET; Sigaction = RECORD handler: SignalHandler; mask: Sigmask; flags: SET; restorer: LONGINT END ; FdSet = ARRAY 8 OF SET; KeyCmd* = PROCEDURE; ThreadQueueDesc = RECORD headPtr, tailPtr: LONGINT END; MutexDesc = RECORD spinlock: LONGINT; count: LONGINT; ownerPtr: LONGINT; kind: LONGINT; threadQueue: ThreadQueueDesc END; VAR (* the first variable is initialized by the boot loader in Linux *) getadr-: PROCEDURE (handle: LONGINT; symbol: LONGINT; VAR adr: LONGINT); modules*: Module; heapAdr-, heapSize-: LONGINT; GCenabled*: BOOLEAN; stackBottom*: LONGINT; EventLoop*: PROCEDURE ; nofiles*: LONGINT; loadLibrary: PROCEDURE (lib: ARRAY OF CHAR; mode: LONGINT): LONGINT; freeLibrary: PROCEDURE (lib: LONGINT); GetLocalTime: PROCEDURE (systime: LONGINT); SetLocalTime: PROCEDURE (systime: LONGINT); pthreadMutexInit: PROCEDURE (mutexPtr, mutexAttrPtr: LONGINT): INTEGER; pthreadMutexLock: PROCEDURE (mutexPtr: LONGINT): INTEGER; pthreadMutexUnlock: PROCEDURE (mutexPtr: LONGINT): INTEGER; mod: LONGINT; initialised: BOOLEAN; (* trap handling *) setjmp*: PROCEDURE (env: Jmpbuf): LONGINT; longjmp*: PROCEDURE (env: Jmpbuf; val: LONGINT): LONGINT; siglongjmp*: PROCEDURE (env: Jmpbuf; val: LONGINT): LONGINT; (* maintain interface compatible *)  trapEnv*: Jmpbuf; (* saved stack environment for trap handling *) (* unix heap management *) malloc*: PROCEDURE (size: LONGINT): LONGINT; free*: PROCEDURE (adr: LONGINT); (* handle of libc.so and libPthread*) libc*: LONGINT; libPthread*: LONGINT; (* input event handling *) readSet*, readySet*: FdSet; FKey*: ARRAY 16 OF KeyCmd; select: PROCEDURE (n, rsadr, wsadr, xsadr, tvadr: LONGINT): LONGINT; exit: PROCEDURE (status: LONGINT); write: PROCEDURE (fd, adr, n: LONGINT); gettimeofday: PROCEDURE (tv: Timeval; tz: Timezone); localtime: PROCEDURE (VAR clock: LONGINT): Time; (* sigaltstack: PROCEDURE (ss, oss: Sigaltstack); *) sigaction: PROCEDURE (sig: LONGINT; VAR ss, oss: Sigaction); sigprocmask: PROCEDURE (how: LONGINT; VAR mask, oldmask: Sigmask); signal: PROCEDURE (sig: LONGINT; handler: LONGINT); Write: PROCEDURE ( fd, adr, n : LONGINT ) : LONGINT; TYPE TypeDesc = RECORD size: LONGINT; ptroff: LONGINT END; FreeBlockPtr = POINTER TO FreeBlock; FreeBlock = RECORD (* off-4 *) tag: Tag; (* off0 *) size: LONGINT; (* field size aligned to 8-byte boundary, size MOD B = B-4 *) (* off4 *) next: ADDRESS END; Block* = POINTER TO BlockDesc; BlockDesc = RECORD lastElemToMark, currElem, firstElem: Block END ; Blockm4Ptr = POINTER TO Blockm4; Blockm4 = RECORD tag: Tag; lastElemToMark, currElem, firstElem: LONGINT END; InitPtr = POINTER TO RECORD tag: Tag; z0, z1, z2, z3, z4, z5, z6, z7: LONGINT END; PtrElemDesc = RECORD a: S.PTR END; (* has same type descriptor as element of ARRAY OF POINTER *) Finalizer* = PROCEDURE (obj: S.PTR); FinObj = POINTER TO FinObjNode; FinObjNode = RECORD next: FinObj; obj: LONGINT; marked: BOOLEAN; fin: Finalizer END; Notifier* = PROCEDURE; Queue* = RECORD notify: ARRAY 8 OF Notifier END ; (* Stack = POINTER TO StackDesc; StackDesc = RECORD beg, end: LONGINT; next: Stack END ; *) CONST B = 32; (* must be a mutiple of 32 *) N = 9; nil = 0; SubObjBit = 3; mark = {MarkBit}; array = {1}; subobj = {SubObjBit}; ReserveSize = 65536-8; VAR TrapHandlingLevel*: LONGINT; firstBlock, endBlock: (* FreeBlockPtr*) ADDRESS; (* free blocks must be collected !! *) A: ARRAY N + 1 OF (* FreeBlockPtr *) ADDRESS; reserve: Block; ptrElemTag: LONGINT; firstTry: BOOLEAN; candidates: ARRAY 1024 OF LONGINT; nofcand: INTEGER; finObjs: FinObj; prepQ*, quitQ*, gcQ*, afterQ*: Queue; (* prep queue called before GC, gc queue during GC *) (* the following procedure variables must be set by Threads.Mod *) suspendThreads*, resumeThreads*: PROCEDURE; (* must be set by Threads.Mod *) enumThreads*: PROCEDURE (proc: PROCEDURE (thread: LONGINT)); enumThreadStack*: PROCEDURE (thread: LONGINT; proc: PROCEDURE (p: LONGINT)); critRegion: MutexDesc; dummy: LONGINT; mainStackEnd*: LONGINT; PROCEDURE ^ NewRec* (tag: Tag; VAR p: ADDRESS); PROCEDURE New (VAR o: S.PTR);  BEGIN NewRec(S.VAL(Tag, o), S.VAL(LONGINT, o)) END New;  PROCEDURE (VAR q: Queue) Init*;  VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(q.notify) - 1 DO q.notify[i] := NIL END END Init;  PROCEDURE (VAR q: Queue) Add* (notify: Notifier);  VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(q.notify) - 1 DO IF q.notify[i] = NIL THEN q.notify[i] := notify; RETURN END END END Add;  PROCEDURE (VAR q: Queue) Remove* (notify: Notifier);  VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(q.notify) - 1 DO IF q.notify[i] = notify THEN q.notify[i] := NIL; RETURN END END END Remove;  PROCEDURE (VAR q: Queue) Handle*;  VAR i: INTEGER; BEGIN FOR i := LEN(q.notify) - 1 TO 0 BY - 1 DO IF q.notify[i] # NIL THEN q.notify[i] END END END Handle;  PROCEDURE Ch (ch: CHAR);  BEGIN write(2, S.ADR(ch), 1) END Ch;  PROCEDURE String (str: ARRAY OF CHAR);  VAR s, res: LONGINT; len: INTEGER; c: CHAR; BEGIN s := S.ADR(str); len := 0; S.GET(s + len, c); WHILE c # 0X DO INC(len); S.GET(s + len, c) END; write(2, s, len) END String;  PROCEDURE Ln;  BEGIN Ch(0AX) END Ln;  PROCEDURE Int (i: LONGINT);  VAR s: ARRAY 20 OF CHAR; i1, k: LONGINT; BEGIN IF i = MIN(LONGINT) THEN s := "2147483648"; k := 10 ELSE i1 := ABS(i); s[0] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; k := 1; WHILE i1 > 0 DO s[k] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; INC(k) END END ; IF i < 0 THEN s[k] := "-"; INC(k) END ; WHILE k > 0 DO DEC(k); Ch(s[k]) END END Int;  PROCEDURE err (s: ARRAY OF CHAR);  BEGIN write(2, S.ADR(s), LEN(s)); s[0] := 0AX; write(2, S.ADR(s), 1) END err;  PROCEDURE MarkState*;  (*called at the very beginning of Oberon.Loop*) VAR SP: LONGINT; BEGIN S.GETREG(4, SP); mainStackEnd := SP + 4 * 3 END MarkState;  PROCEDURE Select* (delay: LONGINT);  VAR rs, ws, xs: FdSet; n: LONGINT; tv: Timeval; BEGIN rs := readSet; FOR n := 0 TO 7 DO ws[n] := {}; xs[n] := {}; readySet[n] := {} END; IF delay < 0 THEN delay := 0 END ; tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000; n := select(256, S.ADR(rs), S.ADR(ws), S.ADR(xs), S.ADR(tv)); IF n >= 0 THEN readySet := rs END END Select;  PROCEDURE InstallSignal* (sig: INTEGER; P: SignalHandler); (** low level facility - use Unix.InstallTrapHandler *)  BEGIN signal(sig, S.VAL(LONGINT, P)); END InstallSignal;  PROCEDURE SetSignalStack;  VAR ss, oss: Sigaltstack; BEGIN (* ss.sp := malloc(SignalStackSize); ss.size := SignalStackSize; ss.flags := {}; IF ss.sp # 0 THEN sigaltstack(ss, oss) END *) END SetSignalStack;  PROCEDURE ^ NewRec* (tag: Tag; VAR p: ADDRESS); PROCEDURE RegisterObject* (obj: S.PTR; fin: Finalizer);  VAR n: FinObj; PROCEDURE new (VAR o: S.PTR); BEGIN NewRec(S.VAL(Tag, o), S.VAL(LONGINT, o)) END new; BEGIN new(n); n.next := finObjs; n.obj := S.VAL(LONGINT, obj); n.marked := FALSE; n.fin := fin; finObjs := n END RegisterObject;  PROCEDURE InstallTermHandler* (h: TerminationHandler);  VAR codebase, handlerAdr: LONGINT; m: Module; found: BOOLEAN; BEGIN m := modules; handlerAdr := S.VAL(LONGINT, h); found := FALSE; WHILE (m # NIL) & ~found DO codebase := S.ADR(m.code[0]); IF (codebase <= handlerAdr) & (handlerAdr <= codebase + LEN(m.code^)) THEN found := TRUE ELSE m := m.next END END; IF found THEN m.term := h END END InstallTermHandler;  PROCEDURE Available* (): LONGINT;  VAR i, avail: LONGINT; ptr: FreeBlockPtr; BEGIN avail := 0; i := 0; dummy := pthreadMutexLock(S.ADR(critRegion)); WHILE i <= N DO ptr := S.VAL(FreeBlockPtr, A[i]); WHILE ptr # NIL DO INC(avail, ptr^.size); ptr := S.VAL(FreeBlockPtr, ptr^.next) END; INC(i) END; dummy := pthreadMutexUnlock(S.ADR(critRegion)); RETURN avail END Available;  PROCEDURE LargestAvailable* (): LONGINT;  VAR i, max: LONGINT; ptr: FreeBlockPtr; BEGIN i := N; max := 0; dummy := pthreadMutexLock(S.ADR(critRegion)); WHILE (i >= 0) & (max = 0) DO ptr := S.VAL(FreeBlockPtr, A[i]); WHILE ptr # NIL DO IF ptr^.size > max THEN max := ptr^.size END; ptr := S.VAL(FreeBlockPtr, ptr^.next) END; DEC(i) END; dummy := pthreadMutexUnlock(S.ADR(critRegion)); RETURN max END LargestAvailable;  (* ------------------------- garbage collector ----------------------- *) (* PROCEDURE Mark* (block: Block);  TYPE Tag = POINTER TO RECORD (*size,*) ptroff: LONGINT END; (* size skipped, because accessed via tag = actual tag + 4 *) VAR father, field, currElem: Block; offset: LONGINT; tag, downtag, marked: Tag; arraybit: SET; BEGIN S.GET(S.VAL(ADDRESS, block) - 4, tag); IF ~(SubObjBit IN S.VAL(SET, block)) THEN (* not a subobject *) marked := S.VAL(Tag, S.VAL(SET, tag) + mark); IF tag # marked THEN S.PUT(S.VAL(ADDRESS, block) - 4, marked); S.GET(S.VAL(ADDRESS, S.VAL(SET, tag) - array) - 4, marked); (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); arraybit := S.VAL(SET, tag) * array; IF arraybit # {} THEN currElem := block^.firstElem; tag := S.VAL(Tag, S.VAL(SET, tag) - arraybit) ELSE currElem := block END; father := NIL; LOOP INC(S.VAL(ADDRESS, tag), 4); offset := tag^.ptroff; IF offset < 0 THEN INC(S.VAL(ADDRESS, tag), offset); IF (arraybit # {}) & (currElem # block^.lastElemToMark) THEN INC(S.VAL(ADDRESS, currElem), tag^.ptroff) ELSE (* up *) S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); IF father = NIL THEN EXIT END; S.GET(S.VAL(ADDRESS, father) - 4, tag); arraybit := S.VAL(SET, tag) * array; tag := S.VAL(Tag, S.VAL(SET, tag) - (array + mark)); IF arraybit # {} THEN currElem := father^.currElem ELSE currElem := father END; offset (*field address*) := S.VAL(ADDRESS, currElem) + tag^.ptroff; S.GET(offset, field); S.PUT(offset, block); block := father; father := field END ELSE offset (*field address*) := S.VAL(ADDRESS, currElem) + offset; S.GET(offset, field); IF (S.VAL(LONGINT, field) >= heapAdr) & (S.VAL(LONGINT, field) <= heapAdr + heapSize) THEN (* ^^^ instead of "field # NIL, RLI taken from Windows 22 Aug 1997 *) S.GET(S.VAL(ADDRESS, field) - 4, downtag); IF subobj * S.VAL(SET, field) = {} THEN (* not a subobject *) marked := S.VAL(Tag, S.VAL(SET, downtag) + mark); IF downtag # marked THEN (* down *) S.PUT(S.VAL(ADDRESS, field) - 4, marked); S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); IF arraybit # {} THEN block^.currElem := currElem END; S.GET(S.VAL(ADDRESS, S.VAL(SET, downtag) - array) - 4, marked); (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); arraybit := S.VAL(SET, downtag) * array; IF arraybit # {} THEN currElem := field^.firstElem ELSE currElem := field END; S.PUT(offset, father); father := block; block := field; tag := S.VAL(Tag, S.VAL(SET, downtag) - arraybit) END ELSE (* do not mark subobject here Windows is different ??? *) S.GET(S.VAL(ADDRESS, S.VAL(SET, downtag) - array) - 4, marked); EXCL(S.VAL(SET, marked), MarkBit); S.GET(S.VAL(ADDRESS, marked) - 4, downtag); INCL(S.VAL(SET, downtag), MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, downtag) END END END END END ELSE (* do not mark subobject, subobjects are not traced here Windows is different ??? *) S.GET(S.VAL(ADDRESS, S.VAL(SET, tag) - array) - 4, tag); EXCL(S.VAL(SET, tag), MarkBit); S.GET(S.VAL(ADDRESS, tag) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, tag) - 4, arraybit) END END Mark;  -- former version *) PROCEDURE Mark* (block: Block);  TYPE Tag = POINTER TO RECORD (*size,*) ptroff: LONGINT END ; (* size skipped, because accessed via tag = actual tag + 4 *) VAR father, field, currElem: Block; offset: LONGINT; tag, downtag, marked: Tag; arraybit: SET; BEGIN (* CheckPtr("Mark ", S.VAL(LONGINT, block)); *) S.GET(S.VAL(ADDRESS, block) - 4, tag); IF ~(SubObjBit IN S.VAL(SET, block)) THEN (* not a subobject *) marked := S.VAL(Tag, S.VAL(SET, tag) + mark); IF tag # marked THEN S.PUT(S.VAL(ADDRESS, block) - 4, marked); S.GET(S.VAL(ADDRESS, S.VAL(SET, tag) - array) - 4, marked); (* marked = super tag *) (* CheckPtr("super tag: ", S.VAL(LONGINT, marked)); *) (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); (* mark type desc for tdescs of unloaded modules *) arraybit := S.VAL(SET, tag) * array; IF arraybit # {} THEN currElem := block^.firstElem; (* block is ArrayBlk *) tag := S.VAL(Tag, S.VAL(SET, tag) - arraybit) (* clear arraybit *) ELSE currElem := block END ; (* currElem is legal Block, tag = tdesc of currElem *) father := NIL; LOOP INC(S.VAL(ADDRESS, tag), 4); (* skip rec size *) offset := tag^.ptroff; IF offset < 0 THEN INC(S.VAL(ADDRESS, tag), offset); (* tag restored *) IF (arraybit # {}) & (currElem # block^.lastElemToMark) THEN INC(S.VAL(ADDRESS, currElem), tag^.ptroff) (* currElem := next array elem *) ELSE (* up *) S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); (* save restored tag *) IF father = NIL THEN EXIT END ; S.GET(S.VAL(ADDRESS, father) - 4, tag); arraybit := S.VAL(SET, tag) * array; tag := S.VAL(Tag, S.VAL(SET, tag) - (array + mark)); (* tag pointing in ptroffs *) IF arraybit # {} THEN currElem := father^.currElem ELSE currElem := father END ; offset (* field address *) := S.VAL(ADDRESS, currElem) + tag^.ptroff; S.GET(offset, field); S.PUT(offset, block); block := father; father := field END ELSE offset (* field address *) := S.VAL(ADDRESS, currElem) + offset; S.GET(offset, field); (* IF field # NIL THEN CheckPtr("field: ", S.VAL(LONGINT, field)) END ; *) IF (S.VAL(LONGINT, field) >= heapAdr) & (S.VAL(LONGINT, field) <= heapAdr + heapSize) THEN (* field # NIL *) S.GET(S.VAL(ADDRESS, field) - 4, downtag); (* tag of pointer in field *) IF subobj * S.VAL(SET, field) = {} THEN (* not a subobject, i.e. record or array *) marked := S.VAL(Tag, S.VAL(SET, downtag) + mark); IF downtag # marked THEN (* down *) S.PUT(S.VAL(ADDRESS, field) - 4, marked); (* mark block referenced by field *) S.PUT(S.VAL(ADDRESS, block) - 4, S.VAL(SET, tag) + arraybit + mark); (* save pointer to ptroffs *) IF arraybit # {} THEN block^.currElem := currElem END ; (* save current array element *) S.GET(S.VAL(ADDRESS, S.VAL(SET, downtag) - array) - 4, marked); (* suptertag of field^ *) (* unnecessary to mask mark bit *) S.GET(S.VAL(ADDRESS, marked) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, marked) - 4, arraybit); (* mark tdesc of field^ *) arraybit := S.VAL(SET, downtag) * array; IF arraybit # {} THEN currElem := field^.firstElem ELSE currElem := field END ; S.PUT(offset, father); father := block; block := field; tag := S.VAL(Tag, S.VAL(SET, downtag) - arraybit) END ELSE (* i.e. sysblock; do not mark subobject *) S.GET(S.VAL(ADDRESS, downtag) - 4, marked); INCL(S.VAL(SET, marked), MarkBit); S.PUT(S.VAL(ADDRESS, downtag) - 4, marked) END END END END END ELSE (* do not mark subobject, subobjects are not traced *) (* CheckPtr("subobj: ", S.VAL(LONGINT, tag)); *) S.GET(S.VAL(ADDRESS, tag) - 4, arraybit); INCL(arraybit, MarkBit); S.PUT(S.VAL(ADDRESS, tag) - 4, arraybit) END END Mark;  PROCEDURE CheckFinObjs;  VAR n: FinObj; tag: LONGINT; BEGIN n := finObjs; WHILE n # NIL DO S.GET(n.obj - 4, tag); IF MarkBit IN S.VAL(SET, tag) THEN n.marked := TRUE ELSE n.marked := FALSE; (* mark all objects accessible from n.obj to prevent them from being collected *) Mark(S.VAL(Block, n.obj)) END; n := n.next END END CheckFinObjs;  PROCEDURE Sweep;  VAR p, end: Blockm4Ptr; lastp: FreeBlockPtr; tag, notmarked, tdesc: Tag; size, lastsize, i: LONGINT; lastA: ARRAY N + 1 OF ADDRESS; BEGIN i := 0; WHILE i <= N DO A[i] := nil; lastA[i] := S.ADR(A[i]); INC(i) END; p := S.VAL(Blockm4Ptr, firstBlock); end := S.VAL(Blockm4Ptr, endBlock); lastsize := 0; WHILE p # end DO tag := p^.tag; notmarked := S.VAL(Tag, S.VAL(SET, tag) - mark); tdesc := S.VAL(Tag, S.VAL(SET, notmarked) - array); IF notmarked # tdesc THEN (* array block *) size := p^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, p) ELSE size := tdesc^.size + 4 END; size := S.VAL(LONGINT, S.VAL(SET, size + B - 1) - S.VAL(SET, B - 1)); IF tag = notmarked THEN (* collect *) IF lastsize = 0 THEN lastp := S.VAL(FreeBlockPtr, p) END; INC(lastsize, size) ELSE p^.tag := notmarked; IF lastsize > 0 THEN lastp^.size := lastsize - 4; lastp^.tag := S.VAL(Tag, S.ADR(lastp^.size)); i := lastsize DIV B; IF i > N THEN i := N END; lastp^.next := nil; S.PUT(lastA[i], lastp); lastA[i] := S.ADR(lastp^.next); lastsize := 0 END END; INC(S.VAL(ADDRESS, p), size) END; (* last collected block: *) IF lastsize > 0 THEN lastp^.size := lastsize - 4; lastp^.tag := S.VAL(Tag, S.ADR(lastp^.size)); i := lastsize DIV B; IF i > N THEN i := N END; lastp^.next := nil; S.PUT(lastA[i], lastp); lastA[i] := S.ADR(lastp^.next) END END Sweep;  (* PROCEDURE CheckCandidates;  (* nofcand > 0 *) VAR i, j, h, p: LONGINT; block: Blockm4Ptr; tag, notmarked, tdesc: Tag; BEGIN (* first sort them in increasing order using 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 phase *) block := S.VAL(Blockm4Ptr, firstBlock); i := 0; p := candidates[i]; LOOP IF p <= S.VAL(ADDRESS, block) + 4 THEN IF p = S.VAL(ADDRESS, block) + 4 THEN Mark(S.VAL(Block, p)) END; INC(i); IF i = nofcand THEN EXIT END; p := candidates[i] ELSE tag := block^.tag; notmarked := S.VAL(Tag, S.VAL(SET, tag) - mark); tdesc := S.VAL(Tag, S.VAL(SET, notmarked) - array); IF notmarked # tdesc THEN (* array block *) h := block^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, block) ELSE h := tdesc^.size + 4 END; INC(S.VAL(ADDRESS, block), S.VAL(LONGINT, S.VAL(SET, h + B - 1) - S.VAL(SET, B - 1))); IF block = S.VAL(Blockm4Ptr, endBlock) THEN EXIT END END END; nofcand := 0 END CheckCandidates;  PROCEDURE Candidate (p: LONGINT);  VAR tag: LONGINT; BEGIN IF ((p MOD B = 0) OR (p MOD 16 = 8)) & (p > firstBlock) & (p < endBlock) THEN S.GET(p - 4, tag); IF tag MOD 8 IN {0, 2} (* array or record, not yet marked *) THEN candidates[nofcand] := p; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates END END END END Candidate;  *) PROCEDURE CheckCandidates (VAR candidates: ARRAY OF LONGINT);  (* nofcand > 0 *) VAR i, j, h, cand: LONGINT; block, prevBlock: Blockm4Ptr; tag, notmarked, tdesc: Tag; BEGIN (* first sort them in increasing order using shellsort *) h := 1; REPEAT h := h * 3 + 1 UNTIL h > nofcand; REPEAT h := h DIV 3; i := h; WHILE i < nofcand DO cand := candidates[i]; j := i; WHILE (j >= h) & (candidates[j - h] > cand) DO candidates[j] := candidates[j - h]; j := j - h; END ; candidates[j] := cand; INC(i); END; UNTIL h = 1; (* sweep phase *) block := S.VAL(Blockm4Ptr, firstBlock); i := 0; cand := candidates[i]; prevBlock := block; LOOP IF cand <= S.VAL(ADDRESS, block) + 4 THEN IF cand = S.VAL(ADDRESS, block) + 4 THEN S.GET(S.VAL(ADDRESS, block), h); IF h # cand THEN Mark(S.VAL(Block, cand)) ELSE (* FreeBlk, SysBlk, or TDesc *) (* CS, 21.08.96 *) S.GET(S.VAL(ADDRESS, block) + 8, h); IF h = - 4 THEN Mark(S.VAL(Block, cand)) END (* ELSE FreeBlk *) END ELSE (* cand < S.VAL(ADDRESS, block) + 4 => ptr into a block (e.g. VAR-Par p.x) *) S.GET(S.VAL(ADDRESS, prevBlock), h); IF h # S.VAL(ADDRESS, prevBlock) + 4 THEN Mark(S.VAL(Block, S.VAL(ADDRESS, prevBlock) + 4)) ELSE (* FreeBlk, SysBlk, or TDesc *) S.GET(S.VAL(ADDRESS, prevBlock) + 8, h); IF h = - 4 THEN Mark(S.VAL(Block, S.VAL(ADDRESS, prevBlock) + 4)) END (* ELSE FreeBlk *) END END ; INC(i); IF i = nofcand THEN EXIT END ; cand := candidates[i] ELSE tag := block^.tag; notmarked := S.VAL(Tag, S.VAL(SET, tag) - mark); tdesc := S.VAL(Tag, S.VAL(SET, notmarked) - array); IF notmarked # tdesc THEN (* array block *) h := block^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, block) ELSE h := tdesc^.size + 4 END ; prevBlock := block; INC(S.VAL(ADDRESS, block), S.VAL(LONGINT, S.VAL(SET, h + B - 1) - S.VAL(SET, B - 1))); IF block = S.VAL(Blockm4Ptr, endBlock) THEN EXIT END END END ; nofcand := 0; END CheckCandidates;  PROCEDURE Candidate (VAR candidates: ARRAY OF LONGINT; p: LONGINT);  VAR tag: LONGINT; BEGIN (* IF ((p MOD B = 0) OR (p MOD 16 = 8)) & (p > firstBlock) & (p < endBlock) THEN S.GET(p - 4, tag); IF tag MOD 8 IN {0, 2} (* tag = 000 or tag = 010, array or record, not yet marked *) THEN IF p MOD 16 = 8 THEN (* potentially a SysBlk or a TDesc *) (* CS, 21.08.96 *) candidates[nofcand] := p ELSE candidates[nofcand] := p END ; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates(candidates) END END END *) IF (p > firstBlock) & (p < endBlock) THEN (* allow pointers into block as candidates *) candidates[nofcand] := p; INC(nofcand); IF nofcand = LEN(candidates) THEN CheckCandidates(candidates) END END END Candidate;  PROCEDURE FinalizeObjs;  VAR n, prev: FinObj; BEGIN n := finObjs; WHILE n # NIL DO IF ~n.marked THEN IF n = finObjs THEN finObjs := finObjs.next ELSE prev.next := n.next END; n.fin(S.VAL(S.PTR, n.obj)) ELSE prev := n END; n := n.next END END FinalizeObjs;  PROCEDURE ^ NewSys* (size: LONGINT; VAR p: ADDRESS); PROCEDURE CandWrapper (p: LONGINT);  BEGIN Candidate(candidates, p) END CandWrapper;  PROCEDURE CheckThreadStack (thread: LONGINT);  BEGIN enumThreadStack(thread, CandWrapper) END CheckThreadStack;  PROCEDURE GC*;  VAR m: Module; i, p, sp, ptradr: LONGINT; ptr: Block; (* candidates: ARRAY 1024 OF LONGINT; *) BEGIN IF GCenabled THEN IF suspendThreads # NIL THEN suspendThreads ELSE err('Warning! No suspendThreads installed') END; prepQ.Handle; m := modules; (* ModuleDesc and ModuleBlock are marked via Kernel.modules *) WHILE m # NIL DO i := LEN(m.ptrTab^); ptradr := S.ADR(m.ptrTab^); WHILE i > 0 DO S.GET(ptradr, p); S.GET(p, ptr); (* IF ptr # NIL THEN Mark(ptr) END; -- former *) IF (S.VAL(LONGINT, ptr) >= heapAdr) & (S.VAL(LONGINT, ptr) <= heapAdr + heapSize) THEN Mark(ptr) END ; DEC(i); INC(ptradr, 4) END;  i := LEN(m.tdescs^); ptradr := S.ADR(m.tdescs^); WHILE i > 0 DO S.GET(ptradr, ptr); Mark(ptr); DEC(i); INC(ptradr, 4) END;  m := m^.next END;  (* check other stacks *) nofcand := 0; (* check main stack *) (* -- disabled: main stack is handled same way as all other stacks S.GETREG(4, sp); i := sp; WHILE i < mainStackBeg DO S.GET(i, p); Candidate(candidates, p); INC(i, 4) END ; (* IF nofcand > 0 THEN CheckCandidates(candidates) END; *) *) IF enumThreads # NIL THEN enumThreads(CheckThreadStack) ELSE err("Warning! No enumThreads installed") END; IF nofcand > 0 THEN CheckCandidates(candidates) END; CheckFinObjs; gcQ.Handle; Sweep; IF (reserve = NIL) & firstTry THEN IF LargestAvailable() >= ReserveSize THEN NewSys(ReserveSize, p); reserve := S.VAL(Block, p) END END; FinalizeObjs; afterQ.Handle; IF resumeThreads # NIL THEN resumeThreads ELSE err('Warning! No resumeThreads installed') END; END END GC;  (* ---------------------------------------------------------------- *) PROCEDURE FinalizeAll;  VAR n: FinObj; BEGIN n := finObjs; WHILE n # NIL DO n.fin(S.VAL(S.PTR, n.obj)); n := n.next END END FinalizeAll;  PROCEDURE Exit* (err: LONGINT);  VAR m: Module; h: TerminationHandler; BEGIN quitQ.Handle; IF err = 0 THEN FinalizeAll; m := modules; WHILE m # NIL DO IF m.term # NIL THEN h := m.term; m.term := NIL; h END; m := m.next END END; exit(err) END Exit;  (* -------------------------- memory allocation ----------------------- *) PROCEDURE - HALT1 0B8H, 01H, 0H, 0H, 0H, (* mov eax,1 *) 08DH, 0C9H; (* lea ecx, ecx; generate illegal instruction *) PROCEDURE NewBlock (size: LONGINT): InitPtr;  (* size MOD B = 0 *) VAR i, rest: LONGINT; adr, AN: ADDRESS; ptr: InitPtr; restptr: FreeBlockPtr; BEGIN IF size < 0 (* NEW(p, MAX(LONGINT)) *) THEN HALT1 END; i := size DIV B; IF i > N THEN i := N END; adr := S.ADR(A[0]) + 4 * i; AN := S.ADR(A[N]); (* constant register *) LOOP S.GET(adr, ptr); IF adr = AN THEN LOOP IF ptr = NIL THEN IF (TrapHandlingLevel = 0) & firstTry THEN dummy := pthreadMutexUnlock(S.ADR(critRegion)); GC; dummy := pthreadMutexLock(S.ADR(critRegion)); firstTry := FALSE; ptr := NewBlock(size); firstTry := TRUE; RETURN ptr ELSE reserve := NIL; dummy := pthreadMutexUnlock(S.ADR(critRegion)); GC; dummy := pthreadMutexLock(S.ADR(critRegion)); firstTry := TRUE; HALT1 END END; IF ptr^.z0 + 4 >= size THEN EXIT END; adr := S.ADR(ptr^.z1); S.GET(adr, ptr) END; EXIT END; IF ptr # NIL THEN EXIT END; INC(adr, 4) END; (* ptr # NIL *) S.PUT(adr, ptr^.z1); rest := ptr^.z0 + 4 - size; restptr := S.VAL(FreeBlockPtr, S.VAL(ADDRESS, ptr) + size); IF rest > 0 THEN (* >= B >= 16 *) i := rest DIV B; IF i > N THEN i := N END; restptr^.tag := S.VAL(Tag, S.ADR(restptr^.size)); restptr^.size := rest - 4; restptr^.next := A[i]; A[i] := S.VAL(ADDRESS, restptr) END; RETURN ptr END NewBlock;  PROCEDURE NewRec* (tag: Tag; VAR p: ADDRESS);  (* implementation of NEW(ptr) *) VAR size: LONGINT; ptr, init: InitPtr; BEGIN (* tag^.size = rectyp^.size *) size := S.VAL(LONGINT, S.VAL(SET, tag^.size + (4 (*tag*) + B - 1)) - S.VAL(SET, B - 1)); dummy := pthreadMutexLock(S.ADR(critRegion)); ptr := NewBlock(size); init := S.VAL(InitPtr, S.VAL(ADDRESS, ptr) + size - 32); init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; WHILE init # ptr DO DEC(S.VAL(ADDRESS, init), 32); init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; init^.z7 := 0 END; ptr^.tag := tag; dummy := pthreadMutexUnlock(S.ADR(critRegion)); p := S.VAL(ADDRESS, ptr) + 4 END NewRec;  PROCEDURE NewSys* (size: LONGINT; VAR p: ADDRESS);  (* implementation of S.NEW(ptr, size) *) VAR ptr, init: InitPtr; BEGIN dummy := pthreadMutexLock(S.ADR(critRegion)); size := S.VAL(LONGINT, S.VAL(SET, size + (28 + B - 1)) - S.VAL(SET, B - 1)); ptr := NewBlock(size); init := S.VAL(InitPtr, S.VAL(ADDRESS, ptr) + size - 32); WHILE init # ptr DO init^.tag := NIL; init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; DEC(S.VAL(ADDRESS, init), 32) END; ptr^.tag := S.VAL(Tag, S.ADR(ptr^.z0)); ptr^.z0 := size - 4; ptr^.z1 := - 4; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; ptr^.z5 := S.ADR(ptr^.z0); init^.z6 := 0; dummy := pthreadMutexUnlock(S.ADR(critRegion)); p := S.VAL(ADDRESS, ptr) + 28 END NewSys;  PROCEDURE NewArr* (nofdim, nofelem: LONGINT; eltag: Tag; VAR p: ADDRESS);  (* implementation of NEW(ptr, dim0, dim1, ...) *) VAR size, firstElem, elSize, arrSize, vectSize: LONGINT; ptr, init: InitPtr; BEGIN IF eltag = NIL THEN (* ARRAY OF POINTER *) eltag := S.VAL(Tag, ptrElemTag) END; elSize := eltag^.size; arrSize := nofelem * elSize; vectSize := 8 * (nofdim DIV 2) + 4; (* -> ADR(firstElem) MOD 8 = 0 *) IF eltag^.ptroff = - 4 THEN (* no pointers in element type *) NewSys(arrSize + vectSize + 12, p); RETURN END; size := S.VAL(LONGINT, S.VAL(SET, arrSize + vectSize + (16 + B - 1)) - S.VAL(SET, B - 1)); dummy := pthreadMutexLock(S.ADR(critRegion)); ptr := NewBlock(size); init := S.VAL(InitPtr, S.VAL(ADDRESS, ptr) + size - 32); WHILE init # ptr DO init^.tag := NIL; init^.z0 := 0; init^.z1 := 0; init^.z2 := 0; init^.z3 := 0; init^.z4 := 0; init^.z5 := 0; init^.z6 := 0; DEC(S.VAL(ADDRESS, init), 32) END; ptr^.tag := S.VAL(Tag, S.VAL(SET, eltag) + array); firstElem := S.ADR(ptr^.z3) + vectSize; ptr^.z0 := firstElem + arrSize - elSize; (* ptr^.z1 is reserved for mark phase *) ptr^.z2 := firstElem; ptr^.z3 := 0; ptr^.z4 := 0; ptr^.z5 := 0; ptr^.z6 := 0; dummy := pthreadMutexUnlock(S.ADR(critRegion)); p := S.VAL(ADDRESS, ptr) + 4 END NewArr;  (* --------------------------------------------------------------------- *) PROCEDURE GetClock* (VAR t, d: LONGINT);  VAR tv: Timeval; tz: Timezone; time: Time; BEGIN gettimeofday(tv, tz); time := localtime(tv.sec); t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12); d := time.mday + ASH(time.mon + 1, 5) + ASH(time.year MOD 100, 9) END GetClock;  PROCEDURE SetClock* (t, d: LONGINT);  VAR err: ARRAY 25 OF CHAR; BEGIN err := "not yet implemented"; HALT(99) END SetClock;  PROCEDURE dlopen* (lib: ARRAY OF CHAR; mode: LONGINT): LONGINT;  BEGIN RETURN loadLibrary(lib, mode) END dlopen;  PROCEDURE dlclose* (lib: LONGINT);  BEGIN freeLibrary(lib) END dlclose;  PROCEDURE dlsym* (handle: LONGINT; symbol: ARRAY OF CHAR; VAR adr: LONGINT);  BEGIN getadr(handle, S.ADR(symbol), adr) END dlsym;  PROCEDURE InitKernel;  (* heapAdr, heapSize, firstBlock and modules already initialized *) VAR size, i: LONGINT; p: Blockm4Ptr; rest: FreeBlockPtr; tag, tdesc: Tag; m: Module; td: POINTER TO RECORD filler: ARRAY 4 OF LONGINT; name: Name END; BEGIN finObjs := NIL; quitQ.Init; gcQ.Init; prepQ.Init; afterQ.Init; size := heapAdr + heapSize - firstBlock; DEC(size, size MOD B); endBlock := firstBlock + size; m := modules; WHILE m.name # "Kernel" DO m := m.next END; (* initialise ptrElemTag *) i := LEN(m.tdescs^); REPEAT DEC(i); ptrElemTag := m.tdescs[i]; S.GET(ptrElemTag - 4, td) UNTIL td.name = "PtrElemDesc"; p := S.VAL(Blockm4Ptr, firstBlock); WHILE p^.tag # NIL DO tag := p^.tag; tdesc := S.VAL(Tag, S.VAL(SET, tag) - array - mark); IF array * S.VAL(SET, tag) # {} THEN (* array block *) size := p^.lastElemToMark + tdesc^.size - S.VAL(ADDRESS, p) ELSE size := tdesc^.size + 4 END; size := S.VAL(LONGINT, S.VAL(SET, size + B - 1) - S.VAL(SET, B - 1)); INC(S.VAL(ADDRESS, p), size) END; rest := S.VAL(FreeBlockPtr, p); rest^.tag := S.VAL(Tag, S.ADR(rest^.size)); rest^.size := S.VAL(LONGINT, endBlock) - S.VAL(LONGINT, rest) - 4; rest^.next := 0; i := 0; reserve := NIL; firstTry := TRUE; (* stackBottom := 0; *) i := 0; WHILE i < N DO A[i] := nil; INC(i) END; A[N] := S.VAL(LONGINT, rest); GCenabled := TRUE END InitKernel;  (* PROCEDURE Ch (ch: CHAR);  VAR res: LONGINT; BEGIN res := Write(2, S.ADR(ch), 1) END Ch;  PROCEDURE Hex (i: INTEGER);  VAR a, b: INTEGER; BEGIN a := i DIV 16; b := i MOD 16; IF a <= 9 THEN Ch(CHR(ORD('0') + a)) ELSE Ch(CHR(ORD('A') + a - 10)) END; IF b <= 9 THEN Ch(CHR(ORD('0') + b)) ELSE Ch(CHR(ORD('A') + b - 10)) END END Hex;  *) PROCEDURE CallBodies;  (* modules already initialized *) TYPE Body = PROCEDURE; VAR m, last: Module; body: Body; i: INTEGER; s: INTEGER; BEGIN last := modules; WHILE last.next # NIL DO last := last.next END; m := modules; LOOP IF m.name = "Kernel" THEN InitKernel ELSE body := S.VAL(Body, S.ADR(m.code[0])); body END; IF m = last THEN EXIT END; (* initialize modules belonging to bootfile only *) m := m.next END END CallBodies;  BEGIN (* rely on initialisation of initialised and EventLoop to FALSE and NIL, resp. *) IF initialised THEN IF EventLoop # NIL THEN EventLoop ELSE Exit(1) END END; initialised := TRUE; (* getadr initialized by the boot loader *) dlsym(0, "dlopen", S.VAL(LONGINT, loadLibrary)); dlsym(0, "dlclose", S.VAL(LONGINT, freeLibrary)); dlsym(0, "heapAdr", S.VAL(LONGINT, heapAdr)); dlsym(0, "heapSize", S.VAL(LONGINT, heapSize)); dlsym(0, "exit", S.VAL(LONGINT, exit)); libc := dlopen(libCName, 999); dlsym(libc, "select", S.VAL(LONGINT, select)); dlsym(libc, "write", S.VAL( LONGINT, Write ) ); (* dlsym(libc, "sigaltstack", S.VAL(LONGINT, sigaltstack)); *) dlsym(libc, "sigaction", S.VAL(LONGINT, sigaction)); dlsym(libc, "signal", S.VAL(LONGINT, signal)); dlsym(libc, "localtime", S.VAL(LONGINT, localtime)); dlsym(libc, "write", S.VAL(LONGINT, write)); dlsym(libc, "gettimeofday", S.VAL(LONGINT, gettimeofday)); dlsym(libc, "setjmp", S.VAL(LONGINT, setjmp)); dlsym(libc, "longjmp", S.VAL(LONGINT, longjmp)); dlsym(libc, "longjmp", S.VAL(LONGINT, siglongjmp));  dlsym(libc, "sigprocmask", S.VAL(LONGINT, sigprocmask)); dlsym(libc, "malloc", S.VAL(LONGINT, malloc)); dlsym(libc, "free", S.VAL(LONGINT, free)); libPthread := dlopen(wrapperLibName, 999); dlsym(libPthread, "th_mutex_init", S.VAL(LONGINT, pthreadMutexInit)); dlsym(libPthread, "th_mutex_lock", S.VAL(LONGINT, pthreadMutexLock)); dlsym(libPthread, "th_mutex_unlock", S.VAL(LONGINT, pthreadMutexUnlock)); dummy := pthreadMutexInit(S.ADR(critRegion), 0); SetSignalStack; TrapHandlingLevel := 0; firstBlock := heapAdr + ((- heapAdr - 4) MOD B); S.GETREG(4, stackBottom); modules := S.VAL(Module, firstBlock + 4); CallBodies END Kernel.