|Syntax10.Scn.FntSyntax10i.Scn.FntInfoElemsAllocUSyntax10.Scn.FntStampElemsAlloc2 Sep 99"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 insteadvpVersionElemsAllocBeg#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5$Syntax10i.Scn.FntLibc5pVersionElemsAllocEndSyntax10b.Scn.FntLqp#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5#Syntax10.Scn.Fnt "libc.so.5" p%LinkElemsAllocThreads.ModFu+            -BA         p#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5XSyntax10b.Scn.Fnt Syntax10.Scn.Fnt/% 1sigjmpsave*: PROCEDURE (env: Jmpbuf; savemask: LONGINT); setjmp*: PROCEDURE (env: Jmpbuf): LONGINT; siglongjmp*: PROCEDURE (env: Jmpbuf; val: LONGINT): LONGINT;#1 2#p /%$    48   = R<   1! u" & 6A!   0g   ;8FoldElemsNew#Syntax10.Scn.Fnt99 BEGIN NewRec(S.VAL(Tag, o), S.VAL(LONGINT, o)) END New; 88#Syntax10.Scn.Fnt]] VAR i: INTEGER; BEGIN FOR i := 0 TO LEN(q.notify) - 1 DO q.notify[i] := NIL END END Init; 8V8#Syntax10.Scn.Fnt 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; 8S8#Syntax10.Scn.Fnt 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; 8^8#Syntax10.Scn.Fnt 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; 88#Syntax10.Scn.Fnt'' BEGIN write(2, S.ADR(ch), 1) END Ch; 8)$8#Syntax10.Scn.Fnt 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; 88#Syntax10.Scn.Fnt BEGIN Ch(0AX) END Ln; 8 t8#Syntax10.Scn.Fntjj 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; 8$8#Syntax10.Scn.FntRR BEGIN write(2, S.ADR(s), LEN(s)); s[0] := 0AX; write(2, S.ADR(s), 1) END err; 8  8/V8 8#Syntax10.Scn.Fnt\\ 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; 8 #78D=88mSyntax10.Scn.Fnt#Syntax10i.Scn.FntN+ 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; 8 &88 j8#Syntax10.Scn.Fnttt 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; 8  {8#Syntax10.Scn.Fntcc 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; 8 Q8#Syntax10.Scn.Fnt 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; 8I#N8NSyntax10i.Scn.FntG R / e 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; 8 MarkElemsAlloc\>;8Syntax10.Scn.FntSyntax10i.Scn.Fnt =h/T6"~3a3%6=[t! MqHJd3/+Z 4$OB J"**60 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; 8 ur8CSyntax10.Scn.FntSyntax10i.Scn.FntQJL 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; 8 YT8_Syntax10.Scn.FntSyntax10i.Scn.Fnt  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; 8 8mSyntax10.Scn.FntSyntax10i.Scn.FntQ9!( (* 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; 8$~8CSyntax10.Scn.FntSyntax10i.Scn.Fnt%@ 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; 8`>48_90%$M)=B8 a>:8NZNB+.8 G8#Syntax10.Scn.Fnt 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; 8 G82808C8 8>8?Syntax10.Scn.FntH8FoldElemsNewCSyntax10.Scn.Fnt8Syntax10i.Scn.Fnt0WHILE 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; 888#Syntax10.Scn.FntUUWHILE i > 0 DO S.GET(ptradr, ptr); Mark(ptr); DEC(i); INC(ptradr, 4) END; 8WHILE m # NIL DO i := LEN(m.ptrTab^); ptradr := S.ADR(m.ptrTab^); mark global pointers i := LEN(m.tdescs^); ptradr := S.ADR(m.tdescs^); mark typedescriptors m := m^.next END; 8[8Fj8#Syntax10.Scn.Fnttt VAR n: FinObj; BEGIN n := finObjs; WHILE n # NIL DO n.fin(S.VAL(S.PTR, n.obj)); n := n.next END END FinalizeAll; 8 81Syntax10.Scn.Fnt/ 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; 8J-0/M8{Syntax10.Scn.FntSyntax10i.Scn.Fntbp9 (* 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; 8 8_Syntax10.Scn.FntSyntax10i.Scn.Fnt /3/ (* 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; 8 "8CSyntax10.Scn.FntSyntax10i.Scn.Fnt( (* 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; 8 981j!!N(8K  8#Syntax10.Scn.Fnt 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; 8  8#Syntax10.Scn.FntXX VAR err: ARRAY 25 OF CHAR; BEGIN err := "not yet implemented"; HALT(99) END SetClock; 8 /8#Syntax10.Scn.Fnt11 BEGIN RETURN loadLibrary(lib, mode) END dlopen; 8  8#Syntax10.Scn.Fnt%% BEGIN freeLibrary(lib) END dlclose; 8 =8#Syntax10.Scn.Fnt55 BEGIN getadr(handle, S.ADR(symbol), adr) END dlsym; 8K8mSyntax10.Scn.FntSyntax10i.Scn.FntC+uI (* 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; 88$Syntax10i.Scn.Fnt@@ VAR res: LONGINT; BEGIN res := Write(2, S.ADR(ch), 1) END Ch; 8 8$Syntax10i.Scn.Fnt 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; 88QSyntax10.Scn.FntSyntax10i.Scn.Fnt!73$ (* 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; 88Syntax10.Scn.FntSyntax10i.Scn.FntQh+r9pVersionElemsAllocBeg#Syntax10.Scn.FntLinuxLibc6 LinuxLibc5LinuxLibc6LinuxLibc6 LinuxLibc5#Syntax10.Scn.Fntnndlsym(libc, "sigjmpsave", S.VAL(LONGINT, sigjmpsave)); dlsym(libc, "siglongjmp", S.VAL(LONGINT, siglongjmp));fpVersionElemsAllocEnd6 (* 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, "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(libPthreadName, 999); dlsym(libPthread, "pthread_mutex_init", S.VAL(LONGINT, pthreadMutexInit)); dlsym(libPthread, "pthread_mutex_lock", S.VAL(LONGINT, pthreadMutexLock)); dlsym(libPthread, "pthread_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); CallBodies8 5MODULE Kernel;  (* Libc6 *) IMPORT S := SYSTEM; CONST MarkBit* = 0; SignalStackSize = 64000; SIGBLOCK = 1; SIGSETMASK = 3; libCName = "libc.so.6"; libPthreadName = "libpthread.so"; (* see Threads.Mod  *) 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); 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);  PROCEDURE (VAR q: Queue) Init*;  PROCEDURE (VAR q: Queue) Add* (notify: Notifier);  PROCEDURE (VAR q: Queue) Remove* (notify: Notifier);  PROCEDURE (VAR q: Queue) Handle*;  PROCEDURE Ch (ch: CHAR);  PROCEDURE String (str: ARRAY OF CHAR);  PROCEDURE Ln;  PROCEDURE Int (i: LONGINT);  PROCEDURE err (s: ARRAY OF CHAR);  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);  PROCEDURE InstallSignal* (sig: INTEGER; P: SignalHandler); (** low level facility - use Unix.InstallTrapHandler *)  VAR ss, oss: Sigaction; BEGIN ss.handler := P; ss.flags := {27}; (* SA_ONSTACK *) ss.mask := {}; sigaction(sig, ss, oss) END InstallSignal;  PROCEDURE 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);  PROCEDURE Available* (): LONGINT;  PROCEDURE LargestAvailable* (): LONGINT;  (* ------------------------- garbage collector ----------------------- *) (* PROCEDURE Mark* (block: Block);  -- former version *) PROCEDURE Mark* (block: Block);  PROCEDURE CheckFinObjs;  PROCEDURE Sweep;  (* PROCEDURE CheckCandidates;  PROCEDURE Candidate (p: LONGINT);  *) 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;  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 *) traverse all modules (* 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;  PROCEDURE Exit* (err: LONGINT);  (* -------------------------- 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;  PROCEDURE NewRec* (tag: Tag; VAR p: ADDRESS);  PROCEDURE NewSys* (size: LONGINT; VAR p: ADDRESS);  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);  PROCEDURE SetClock* (t, d: LONGINT);  PROCEDURE dlopen* (lib: ARRAY OF CHAR; mode: LONGINT): LONGINT;  PROCEDURE dlclose* (lib: LONGINT);  PROCEDURE dlsym* (handle: LONGINT; symbol: ARRAY OF CHAR; VAR adr: LONGINT);  PROCEDURE InitKernel;  (* PROCEDURE Ch (ch: CHAR);  PROCEDURE Hex (i: INTEGER);  *) PROCEDURE CallBodies;  BEGIN END Kernel.