1 MODULE Kernel;
3 (* THIS IS TEXT COPY OF Kernel.odc *)
4 (* DO NOT EDIT *)
6 (* A. V. Shiryaev, 2012.11
7 Linux Kernel
8 Based on 1.6-rc6 Windows Kernel
9 + 20120822 Marc changes
10 Some parts taken from OpenBUGS linKernel
12 Most Windows-specific code removed
13 Some Windows-specific code commented and marked red
14 Windows COM-specific code re-marked from green to gray
15 Linux(/OpenBSD)-specific code marked green
17 TODO:
18 handle stack overflow exceptions
19 Quit from TrapHandler
20 *)
22 IMPORT S := SYSTEM, Libc := LinLibc, Dl := LinDl;
24 CONST
25 strictStackSweep = TRUE;
27 nameLen* = 256;
29 littleEndian* = TRUE;
30 timeResolution* = 1000; (* ticks per second *)
32 processor* = 10; (* i386 *)
34 objType* = "ocf"; (* file types *)
35 symType* = "osf";
36 docType* = "odc";
38 (* loader constants *)
39 done* = 0;
40 fileNotFound* = 1;
41 syntaxError* = 2;
42 objNotFound* = 3;
43 illegalFPrint* = 4;
44 cyclicImport* = 5;
45 noMem* = 6;
46 commNotFound* = 7;
47 commSyntaxError* = 8;
48 moduleNotFound* = 9;
50 any = 1000000;
52 CX = 1;
53 SP = 4; (* register number of stack pointer *)
54 FP = 5; (* register number of frame pointer *)
55 ML = 3; (* register which holds the module list at program start *)
57 N = 128 DIV 16; (* free lists *)
59 (* kernel flags in module desc *)
60 init = 16; dyn = 17; dll = 24; iptrs = 30;
62 (* meta interface consts *)
63 mConst = 1; mTyp = 2; mVar = 3; mProc = 4; mField = 5;
65 debug = FALSE;
68 (*
69 sigStackSize = MAX(Libc.SIGSTKSZ, 65536);
70 *)
72 trapReturn = 1; (* Return value for sigsetjmp given from siglongjmp *)
74 (* constants for the message boxes *)
75 mbClose* = -1; mbOk* = 0; mbCancel* =1; mbRetry* = 2; mbIgnore* = 3; mbYes* = 4; mbNo* = 5;
77 TYPE
78 Name* = ARRAY nameLen OF SHORTCHAR;
79 Command* = PROCEDURE;
81 Module* = POINTER TO RECORD [untagged]
82 next-: Module;
83 opts-: SET; (* 0..15: compiler opts, 16..31: kernel flags *)
84 refcnt-: INTEGER; (* <0: module invalidated *)
85 compTime-, loadTime-: ARRAY 6 OF SHORTINT;
86 ext-: INTEGER; (* currently not used *)
87 term-: Command; (* terminator *)
88 nofimps-, nofptrs-: INTEGER;
89 csize-, dsize-, rsize-: INTEGER;
90 code-, data-, refs-: INTEGER;
91 procBase-, varBase-: INTEGER; (* meta base addresses *)
92 names-: POINTER TO ARRAY [untagged] OF SHORTCHAR; (* names[0] = 0X *)
93 ptrs-: POINTER TO ARRAY [untagged] OF INTEGER;
94 imports-: POINTER TO ARRAY [untagged] OF Module;
95 export-: Directory; (* exported objects (name sorted) *)
96 name-: Name
97 END;
99 Type* = POINTER TO RECORD [untagged]
100 (* record: ptr to method n at offset - 4 * (n+1) *)
101 size-: INTEGER; (* record: size, array: #elem, dyn array: 0, proc: sigfp *)
102 mod-: Module;
103 id-: INTEGER; (* name idx * 256 + lev * 16 + attr * 4 + form *)
104 base-: ARRAY 16 OF Type; (* signature if form = ProcTyp *)
105 fields-: Directory; (* new fields (declaration order) *)
106 ptroffs-: ARRAY any OF INTEGER (* array of any length *)
107 END;
109 Object* = POINTER TO ObjDesc;
111 ObjDesc* = RECORD [untagged]
112 fprint-: INTEGER;
113 offs-: INTEGER; (* pvfprint for record types *)
114 id-: INTEGER; (* name idx * 256 + vis * 16 + mode *)
115 struct-: Type (* id of basic type or pointer to typedesc/signature *)
116 END;
118 Directory* = POINTER TO RECORD [untagged]
119 num-: INTEGER; (* number of entries *)
120 obj-: ARRAY any OF ObjDesc (* array of any length *)
121 END;
123 Signature* = POINTER TO RECORD [untagged]
124 retStruct-: Type; (* id of basic type or pointer to typedesc or 0 *)
125 num-: INTEGER; (* number of parameters *)
126 par-: ARRAY any OF RECORD [untagged] (* parameters *)
127 id-: INTEGER; (* name idx * 256 + kind *)
128 struct-: Type (* id of basic type or pointer to typedesc *)
129 END
130 END;
132 Handler* = PROCEDURE;
134 Reducer* = POINTER TO ABSTRACT RECORD
135 next: Reducer
136 END;
138 Identifier* = ABSTRACT RECORD
139 typ*: INTEGER;
140 obj-: ANYPTR
141 END;
143 TrapCleaner* = POINTER TO ABSTRACT RECORD
144 next: TrapCleaner
145 END;
147 TryHandler* = PROCEDURE (a, b, c: INTEGER);
150 (* meta extension suport *)
152 ItemExt* = POINTER TO ABSTRACT RECORD END;
154 ItemAttr* = RECORD
155 obj*, vis*, typ*, adr*: INTEGER;
156 mod*: Module;
157 desc*: Type;
158 ptr*: S.PTR;
159 ext*: ItemExt
160 END;
162 Hook* = POINTER TO ABSTRACT RECORD END;
164 LoaderHook* = POINTER TO ABSTRACT RECORD (Hook)
165 res*: INTEGER;
166 importing*, imported*, object*: ARRAY 256 OF CHAR
167 END;
169 GuiHook* = POINTER TO ABSTRACT RECORD (Hook) END; (* Implemented by HostGnome *)
171 Block = POINTER TO RECORD [untagged]
172 tag: Type;
173 last: INTEGER; (* arrays: last element *)
174 actual: INTEGER; (* arrays: used during mark phase *)
175 first: INTEGER (* arrays: first element *)
176 END;
178 FreeBlock = POINTER TO FreeDesc;
180 FreeDesc = RECORD [untagged]
181 tag: Type; (* f.tag = ADR(f.size) *)
182 size: INTEGER;
183 next: FreeBlock
184 END;
186 Cluster = POINTER TO RECORD [untagged]
187 size: INTEGER; (* total size *)
188 next: Cluster;
189 max: INTEGER
190 (* start of first block *)
191 END;
193 FList = POINTER TO RECORD
194 next: FList;
195 blk: Block;
196 iptr, aiptr: BOOLEAN
197 END;
199 CList = POINTER TO RECORD
200 next: CList;
201 do: Command;
202 trapped: BOOLEAN
203 END;
206 PtrType = RECORD v: S.PTR END; (* used for array of pointer *)
207 Char8Type = RECORD v: SHORTCHAR END;
208 Char16Type = RECORD v: CHAR END;
209 Int8Type = RECORD v: BYTE END;
210 Int16Type = RECORD v: SHORTINT END;
211 Int32Type = RECORD v: INTEGER END;
212 Int64Type = RECORD v: LONGINT END;
213 BoolType = RECORD v: BOOLEAN END;
214 SetType = RECORD v: SET END;
215 Real32Type = RECORD v: SHORTREAL END;
216 Real64Type = RECORD v: REAL END;
217 ProcType = RECORD v: PROCEDURE END;
218 UPtrType = RECORD v: INTEGER END;
219 StrPtr = POINTER TO ARRAY [untagged] OF SHORTCHAR;
221 (* Linux specific boot loader info. Record must be identical to struct in the loader. *)
222 BootInfo* = POINTER TO RECORD [untagged]
223 modList: Module;
224 argc-: INTEGER;
225 argv-: Libc.StrArray
226 END;
228 VAR
229 baseStack: INTEGER; (* modList, root, and baseStack must be together for remote debugging *)
230 root: Cluster; (* cluster list *)
231 modList-: Module; (* root of module list *)
232 trapCount-: INTEGER;
233 err-, pc-, sp-, fp-, stack-, val-: INTEGER;
235 free: ARRAY N OF FreeBlock; (* free list *)
236 sentinelBlock: FreeDesc;
237 sentinel: FreeBlock;
238 candidates: ARRAY 1024 OF INTEGER;
239 nofcand: INTEGER;
240 allocated: INTEGER; (* bytes allocated on BlackBox heap *)
241 total: INTEGER; (* current total size of BlackBox heap *)
242 used: INTEGER; (* bytes allocated on system heap *)
243 finalizers: FList;
244 hotFinalizers: FList;
245 cleaners: CList;
246 reducers: Reducer;
247 trapStack: TrapCleaner;
248 actual: Module; (* valid during module initialization *)
250 res: INTEGER; (* auxiliary global variables used for trap handling *)
251 old: INTEGER;
253 trapViewer, trapChecker: Handler;
254 trapped, guarded, secondTrap: BOOLEAN;
255 interrupted: BOOLEAN;
256 static, inDll, terminating: BOOLEAN;
257 restart: Command;
259 told, shift: INTEGER; (* used in Time() *)
261 loader: LoaderHook;
262 loadres: INTEGER;
264 wouldFinalize: BOOLEAN;
266 watcher*: PROCEDURE (event: INTEGER); (* for debugging *)
269 (*
270 sigStack: Libc.PtrVoid;
271 *)
273 zerofd: INTEGER;
274 pageSize: INTEGER;
276 loopContext: Libc.sigjmp_buf; (* trap return context, if no Kernel.Try has been used. *)
277 currentTryContext: POINTER TO Libc.sigjmp_buf; (* trap return context, if Kernel.Try has been used. *)
278 isReadableContext: Libc.sigjmp_buf; (* for IsReadable *)
279 isReadableCheck: BOOLEAN;
281 guiHook: GuiHook;
283 (* !!! This variable has to be the last variable in the list. !!! *)
284 bootInfo-: BootInfo;
286 (* code procedures for fpu *)
288 PROCEDURE [1] FINIT 0DBH, 0E3H;
289 PROCEDURE [1] FLDCW 0D9H, 06DH, 0FCH; (* -4, FP *)
290 PROCEDURE [1] FSTCW 0D9H, 07DH, 0FCH; (* -4, FP *)
292 (* code procedure for memory erase *)
294 PROCEDURE [code] Erase (adr, words: INTEGER)
295 089H, 0C7H, (* MOV EDI, EAX *)
296 031H, 0C0H, (* XOR EAX, EAX *)
297 059H, (* POP ECX *)
298 0F2H, 0ABH; (* REP STOS *)
300 (* code procedure for stack allocate *)
302 PROCEDURE [code] ALLOC (* argument in CX *)
303 (*
304 PUSH EAX
305 ADD ECX,-5
306 JNS L0
307 XOR ECX,ECX
308 L0: AND ECX,-4 (n-8+3)/4*4
309 MOV EAX,ECX
310 AND EAX,4095
311 SUB ESP,EAX
312 MOV EAX,ECX
313 SHR EAX,12
314 JEQ L2
315 L1: PUSH 0
316 SUB ESP,4092
317 DEC EAX
318 JNE L1
319 L2: ADD ECX,8
320 MOV EAX,[ESP,ECX,-4]
321 PUSH EAX
322 MOV EAX,[ESP,ECX,-4]
323 SHR ECX,2
324 RET
325 *);
327 PROCEDURE (VAR id: Identifier) Identified* (): BOOLEAN, NEW, ABSTRACT;
328 PROCEDURE (r: Reducer) Reduce* (full: BOOLEAN), NEW, ABSTRACT;
329 PROCEDURE (c: TrapCleaner) Cleanup*, NEW, EMPTY;
332 (* meta extension suport *)
334 PROCEDURE (e: ItemExt) Lookup* (name: ARRAY OF CHAR; VAR i: ANYREC), NEW, ABSTRACT;
335 PROCEDURE (e: ItemExt) Index* (index: INTEGER; VAR elem: ANYREC), NEW, ABSTRACT;
336 PROCEDURE (e: ItemExt) Deref* (VAR ref: ANYREC), NEW, ABSTRACT;
338 PROCEDURE (e: ItemExt) Valid* (): BOOLEAN, NEW, ABSTRACT;
339 PROCEDURE (e: ItemExt) Size* (): INTEGER, NEW, ABSTRACT;
340 PROCEDURE (e: ItemExt) BaseTyp* (): INTEGER, NEW, ABSTRACT;
341 PROCEDURE (e: ItemExt) Len* (): INTEGER, NEW, ABSTRACT;
343 PROCEDURE (e: ItemExt) Call* (OUT ok: BOOLEAN), NEW, ABSTRACT;
344 PROCEDURE (e: ItemExt) BoolVal* (): BOOLEAN, NEW, ABSTRACT;
345 PROCEDURE (e: ItemExt) PutBoolVal* (x: BOOLEAN), NEW, ABSTRACT;
346 PROCEDURE (e: ItemExt) CharVal* (): CHAR, NEW, ABSTRACT;
347 PROCEDURE (e: ItemExt) PutCharVal* (x: CHAR), NEW, ABSTRACT;
348 PROCEDURE (e: ItemExt) IntVal* (): INTEGER, NEW, ABSTRACT;
349 PROCEDURE (e: ItemExt) PutIntVal* (x: INTEGER), NEW, ABSTRACT;
350 PROCEDURE (e: ItemExt) LongVal* (): LONGINT, NEW, ABSTRACT;
351 PROCEDURE (e: ItemExt) PutLongVal* (x: LONGINT), NEW, ABSTRACT;
352 PROCEDURE (e: ItemExt) RealVal* (): REAL, NEW, ABSTRACT;
353 PROCEDURE (e: ItemExt) PutRealVal* (x: REAL), NEW, ABSTRACT;
354 PROCEDURE (e: ItemExt) SetVal* (): SET, NEW, ABSTRACT;
355 PROCEDURE (e: ItemExt) PutSetVal* (x: SET), NEW, ABSTRACT;
356 PROCEDURE (e: ItemExt) PtrVal* (): ANYPTR, NEW, ABSTRACT;
357 PROCEDURE (e: ItemExt) PutPtrVal* (x: ANYPTR), NEW, ABSTRACT;
358 PROCEDURE (e: ItemExt) GetSStringVal* (OUT x: ARRAY OF SHORTCHAR;
359 OUT ok: BOOLEAN), NEW, ABSTRACT;
360 PROCEDURE (e: ItemExt) PutSStringVal* (IN x: ARRAY OF SHORTCHAR;
361 OUT ok: BOOLEAN), NEW, ABSTRACT;
362 PROCEDURE (e: ItemExt) GetStringVal* (OUT x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
363 PROCEDURE (e: ItemExt) PutStringVal* (IN x: ARRAY OF CHAR; OUT ok: BOOLEAN), NEW, ABSTRACT;
366 (* -------------------- miscellaneous tools -------------------- *)
368 PROCEDURE Msg (IN str: ARRAY OF CHAR);
369 VAR ss: ARRAY 1024 OF SHORTCHAR; res, l: INTEGER;
370 BEGIN
371 ss := SHORT(str);
372 l := LEN(ss$);
373 ss[l] := 0AX; ss[l + 1] := 0X;
374 res := Libc.printf(ss)
375 END Msg;
377 PROCEDURE Int (x: LONGINT);
378 VAR j, k: INTEGER; ch: CHAR; a, s: ARRAY 32 OF CHAR;
379 BEGIN
380 IF x # MIN(LONGINT) THEN
381 IF x < 0 THEN s[0] := "-"; k := 1; x := -x ELSE k := 0 END;
382 j := 0; REPEAT a[j] := CHR(x MOD 10 + ORD("0")); x := x DIV 10; INC(j) UNTIL x = 0
383 ELSE
384 a := "8085774586302733229"; s[0] := "-"; k := 1;
385 j := 0; WHILE a[j] # 0X DO INC(j) END
386 END;
387 ASSERT(k + j < LEN(s), 20);
388 REPEAT DEC(j); ch := a[j]; s[k] := ch; INC(k) UNTIL j = 0;
389 s[k] := 0X;
390 Msg(s);
391 END Int;
393 PROCEDURE (h: GuiHook) MessageBox* (
394 title, msg: ARRAY OF CHAR; buttons: SET): INTEGER, NEW, ABSTRACT;
395 PROCEDURE (h: GuiHook) Beep*, NEW, ABSTRACT;
397 (* Is extended by HostGnome to show dialogs. If no dialog is present or
398 if the dialog is not closed by using one button, then "mbClose" is returned *)
399 PROCEDURE MessageBox* (title, msg: ARRAY OF CHAR; buttons: SET): INTEGER;
400 VAR res: INTEGER;
401 BEGIN
402 IF guiHook # NIL THEN
403 res := guiHook.MessageBox(title, msg, buttons)
404 ELSE
405 Msg(" ");
406 Msg("****");
407 Msg("* " + title);
408 Msg("* " + msg);
409 Msg("****");
410 res := mbClose;
411 END;
412 RETURN res
413 END MessageBox;
415 PROCEDURE SetGuiHook* (hook: GuiHook);
416 BEGIN
417 guiHook := hook
418 END SetGuiHook;
420 PROCEDURE SplitName* (name: ARRAY OF CHAR; VAR head, tail: ARRAY OF CHAR);
421 (* portable *)
422 VAR i, j: INTEGER; ch, lch: CHAR;
423 BEGIN
424 i := 0; ch := name[0];
425 IF ch # 0X THEN
426 REPEAT
427 head[i] := ch; lch := ch; INC(i); ch := name[i]
428 UNTIL (ch = 0X)
429 OR ((ch >= "A") & (ch <= "Z") OR (ch >= "À") & (ch # "×") & (ch <= "Þ"))
430 & ((lch < "A") OR (lch > "Z") & (lch < "À") OR (lch = "×") OR (lch > "Þ"));
431 head[i] := 0X; j := 0;
432 WHILE ch # 0X DO tail[j] := ch; INC(i); INC(j); ch := name[i] END;
433 tail[j] := 0X;
434 IF tail = "" THEN tail := head$; head := "" END
435 ELSE head := ""; tail := ""
436 END
437 END SplitName;
439 PROCEDURE MakeFileName* (VAR name: ARRAY OF CHAR; type: ARRAY OF CHAR);
440 VAR i, j: INTEGER; ext: ARRAY 8 OF CHAR; ch: CHAR;
441 BEGIN
442 i := 0;
443 WHILE (name[i] # 0X) & (name[i] # ".") DO INC(i) END;
444 IF name[i] = "." THEN
445 IF name[i + 1] = 0X THEN name[i] := 0X END
446 ELSIF i < LEN(name) - 4 THEN
447 IF type = "" THEN ext := docType ELSE ext := type$ END;
448 name[i] := "."; INC(i); j := 0; ch := ext[0];
449 WHILE ch # 0X DO
450 IF (ch >= "A") & (ch <= "Z") THEN
451 ch := CHR(ORD(ch) + ORD("a") - ORD("A"))
452 END;
453 name[i] := ch; INC(i); INC(j); ch := ext[j]
454 END;
455 name[i] := 0X
456 END
457 END MakeFileName;
459 PROCEDURE Time* (): LONGINT;
460 VAR t: INTEGER;
461 BEGIN
462 (* t := WinApi.GetTickCount(); *)
464 (* Linux *)
465 t := Libc.clock() DIV (Libc.CLOCKS_PER_SECOND DIV 1000); (* processor time to milliseconds *)
467 IF t < told THEN INC(shift) END;
468 told := t;
469 RETURN shift * 100000000L + t
470 END Time;
472 PROCEDURE Beep* ();
473 VAR ss: ARRAY 2 OF SHORTCHAR;
474 BEGIN
475 IF guiHook # NIL THEN
476 guiHook.Beep
477 ELSE
478 ss[0] := 007X; ss[1] := 0X;
479 res := Libc.printf(ss); res := Libc.fflush(Libc.NULL)
480 END
481 END Beep;
483 PROCEDURE SearchProcVar* (var: INTEGER; VAR m: Module; VAR adr: INTEGER);
484 BEGIN
485 adr := var; m := NIL;
486 IF var # 0 THEN
487 m := modList;
488 WHILE (m # NIL) & ((var < m.code) OR (var >= m.code + m.csize)) DO m := m.next END;
489 IF m # NIL THEN DEC(adr, m.code) END
490 END
491 END SearchProcVar;
494 (* -------------------- system memory management --------------------- *)
496 (* A. V. Shiryaev, 2012.10: NOTE: it seems that GC works correctly with positive addesses only *)
498 (*
499 PROCEDURE HeapAlloc (adr: INTEGER; size: INTEGER; prot: SET): Libc.PtrVoid;
500 VAR
501 x: Libc.PtrVoid;
502 res: INTEGER;
503 BEGIN
504 x := Libc.calloc(1, size); (* calloc initialize allocated space to zero *)
505 IF x # Libc.NULL THEN
506 res := Libc.mprotect(x, size, prot);
507 IF res # 0 THEN
508 Libc.free(x);
509 x := Libc.NULL;
510 Msg("Kernel.HeapAlloc: mprotect failed!");
511 HALT(100)
512 END
513 END;
514 RETURN x
515 END HeapAlloc;
516 *)
517 PROCEDURE HeapAlloc (adr: Libc.PtrVoid; size: INTEGER; prot: SET): Libc.PtrVoid;
518 VAR x: Libc.PtrVoid;
519 BEGIN
520 x := Libc.mmap(adr, size, prot, Libc.MAP_PRIVATE + Libc.MAP_ANON, zerofd, 0);
521 IF x = Libc.MAP_FAILED THEN
522 x := Libc.NULL
523 ELSE
524 ASSERT(size MOD 4 = 0, 100);
525 Erase(x, size DIV 4)
526 END;
527 RETURN x
528 END HeapAlloc;
530 (*
531 PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER);
532 VAR res: INTEGER;
533 BEGIN
534 (*
535 ASSERT(size MOD 4 = 0, 100);
536 Erase(adr, size DIV 4);
537 res := Libc.mprotect(adr, size, Libc.PROT_NONE);
538 ASSERT(res = 0, 101);
539 *)
540 Libc.free(adr)
541 END HeapFree;
542 *)
543 PROCEDURE HeapFree (adr: Libc.PtrVoid; size: INTEGER);
544 VAR res: INTEGER;
545 BEGIN
546 (*
547 ASSERT(size MOD 4 = 0, 100);
548 Erase(adr, size DIV 4);
549 res := Libc.mprotect(adr, size, Libc.PROT_NONE);
550 ASSERT(res = 0, 101);
551 *)
552 res := Libc.munmap(adr, size);
553 ASSERT(res = 0, 102)
554 END HeapFree;
556 PROCEDURE AllocHeapMem (size: INTEGER; VAR c: Cluster);
557 (* allocate at least size bytes, typically at least 256 kbytes are allocated *)
558 CONST N = 65536; (* cluster size for dll *)
559 prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *);
560 VAR adr: INTEGER;
561 allocated: INTEGER;
562 BEGIN
563 INC(size, 16);
564 ASSERT(size > 0, 100); adr := 0;
565 IF size < N THEN adr := HeapAlloc(65536, N, prot) END;
566 IF adr = 0 THEN adr := HeapAlloc(65536, size, prot); allocated := size ELSE allocated := N END;
567 IF adr = 0 THEN c := NIL
568 ELSE
569 c := S.VAL(Cluster, (adr + 15) DIV 16 * 16); c.max := adr;
570 c.size := allocated - (S.VAL(INTEGER, c) - adr);
571 INC(used, c.size); INC(total, c.size)
572 END
573 (* post: (c = NIL) OR (c MOD 16 = 0) & (c.size >= size) *)
574 END AllocHeapMem;
576 PROCEDURE FreeHeapMem (c: Cluster);
577 BEGIN
578 DEC(used, c.size); DEC(total, c.size);
579 HeapFree(c.max, (S.VAL(INTEGER, c) - c.max) + c.size)
580 END FreeHeapMem;
582 PROCEDURE AllocModMem* (descSize, modSize: INTEGER; VAR descAdr, modAdr: INTEGER);
583 CONST
584 prot = Libc.PROT_READ + Libc.PROT_WRITE (* + Libc.PROT_EXEC *);
585 BEGIN
586 descAdr := HeapAlloc(0, descSize, prot);
587 IF descAdr # 0 THEN
588 modAdr := HeapAlloc(0, modSize, prot);
589 IF modAdr # 0 THEN INC(used, descSize + modSize)
590 ELSE HeapFree(descAdr, descSize); descAdr := 0
591 END
592 ELSE modAdr := 0
593 END
594 END AllocModMem;
596 PROCEDURE DeallocModMem* (descSize, modSize, descAdr, modAdr: INTEGER);
597 BEGIN
598 DEC(used, descSize + modSize);
599 HeapFree(descAdr, descSize);
600 HeapFree(modAdr, modSize)
601 END DeallocModMem;
603 PROCEDURE InvalModMem (modSize, modAdr: INTEGER);
604 BEGIN
605 DEC(used, modSize);
606 HeapFree(modAdr, modSize)
607 END InvalModMem;
609 (*
610 PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
611 (* check wether memory between from (incl.) and to (excl.) may be read *)
612 BEGIN
613 RETURN WinApi.IsBadReadPtr(from, to - from) = 0
614 END IsReadable;
615 *)
617 (* Alexander Shiryaev, 2012.10: Linux: can be implemented through mincore/madvise *)
618 (* This procedure can be called from TrapHandler also *)
619 PROCEDURE IsReadable* (from, to: INTEGER): BOOLEAN;
620 (* check wether memory between from (incl.) and to (excl.) may be read *)
621 VAR res: BOOLEAN; res1: INTEGER;
622 x: SHORTCHAR;
623 mask, omask: Libc.sigset_t;
624 BEGIN
625 (* save old sigmask and unblock SIGSEGV *)
626 res1 := Libc.sigemptyset(S.ADR(mask));
627 ASSERT(res1 = 0, 100);
628 res1 := Libc.sigaddset(S.ADR(mask), Libc.SIGSEGV);
629 ASSERT(res1 = 0, 101);
630 res1 := Libc.sigprocmask(Libc.SIG_UNBLOCK, S.ADR(mask), S.ADR(omask));
631 ASSERT(res1 = 0, 102);
633 res := FALSE;
634 res1 := Libc.sigsetjmp(isReadableContext, Libc.TRUE);
635 IF res1 = 0 THEN
636 isReadableCheck := TRUE;
637 (* read memory *)
638 REPEAT
639 S.GET(from, x);
640 INC(from)
641 UNTIL from = to;
642 res := TRUE
643 ELSE
644 ASSERT(res1 = 1, 103)
645 END;
646 isReadableCheck := FALSE;
648 (* restore saved sigmask *)
649 res1 := Libc.sigprocmask(Libc.SIG_SETMASK, S.ADR(omask), Libc.NULL);
650 ASSERT(res1 = 0, 104);
652 RETURN res
653 END IsReadable;
655 (* --------------------- NEW implementation (portable) -------------------- *)
657 PROCEDURE^ NewBlock (size: INTEGER): Block;
659 PROCEDURE NewRec* (typ: INTEGER): INTEGER; (* implementation of NEW(ptr) *)
660 VAR size: INTEGER; b: Block; tag: Type; l: FList;
661 BEGIN
662 IF ODD(typ) THEN (* record contains interface pointers *)
663 tag := S.VAL(Type, typ - 1);
664 b := NewBlock(tag.size);
665 IF b = NIL THEN RETURN 0 END;
666 b.tag := tag;
667 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
668 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
669 l.blk := b; l.iptr := TRUE; l.next := finalizers; finalizers := l;
670 RETURN S.ADR(b.last)
671 ELSE
672 tag := S.VAL(Type, typ);
673 b := NewBlock(tag.size);
674 IF b = NIL THEN RETURN 0 END;
675 b.tag := tag; S.GET(typ - 4, size);
676 IF size # 0 THEN (* record uses a finalizer *)
677 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
678 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
679 l.blk := b; l.next := finalizers; finalizers := l
680 END;
681 RETURN S.ADR(b.last)
682 END
683 END NewRec;
685 PROCEDURE NewArr* (eltyp, nofelem, nofdim: INTEGER): INTEGER; (* impl. of NEW(ptr, dim0, dim1, ...) *)
686 VAR b: Block; size, headSize: INTEGER; t: Type; fin: BOOLEAN; l: FList;
687 BEGIN
688 IF (nofdim < 0)OR(nofdim>1FFFFFFCH) THEN RETURN 0 END;(*20120822 Marc*)
689 headSize := 4 * nofdim + 12; fin := FALSE;
690 CASE eltyp OF
691 (*
692 | -1: eltyp := S.ADR(IntPtrType); fin := TRUE
693 *)
694 | -1: HALT(100)
695 | 0: eltyp := S.ADR(PtrType)
696 | 1: eltyp := S.ADR(Char8Type)
697 | 2: eltyp := S.ADR(Int16Type)
698 | 3: eltyp := S.ADR(Int8Type)
699 | 4: eltyp := S.ADR(Int32Type)
700 | 5: eltyp := S.ADR(BoolType)
701 | 6: eltyp := S.ADR(SetType)
702 | 7: eltyp := S.ADR(Real32Type)
703 | 8: eltyp := S.ADR(Real64Type)
704 | 9: eltyp := S.ADR(Char16Type)
705 | 10: eltyp := S.ADR(Int64Type)
706 | 11: eltyp := S.ADR(ProcType)
707 | 12: eltyp := S.ADR(UPtrType)
708 ELSE (* eltyp is desc *)
709 IF ODD(eltyp) THEN DEC(eltyp); fin := TRUE END
710 END;
711 t := S.VAL(Type, eltyp);
712 ASSERT(t .size> 0,100);
713 IF (nofelem < 0) OR( (7FFFFFFFH-headSize) DIV t.size < nofelem) THEN (* 20120822 Marc*)
714 RETURN 0
715 END;
716 size := headSize + nofelem * t.size;
717 b := NewBlock(size);
718 IF b = NIL THEN RETURN 0 END;
719 b.tag := S.VAL(Type, eltyp + 2); (* tag + array mark *)
720 b.last := S.ADR(b.last) + size - t.size; (* pointer to last elem *)
721 b.first := S.ADR(b.last) + headSize; (* pointer to first elem *)
722 IF fin THEN
723 l := S.VAL(FList, S.ADR(b.last)); (* anchor new object! *)
724 l := S.VAL(FList, NewRec(S.TYP(FList))); (* NEW(l) *)
725 l.blk := b; l.aiptr := TRUE; l.next := finalizers; finalizers := l
726 END;
727 RETURN S.ADR(b.last)
728 END NewArr;
731 (* -------------------- handler installation (portable) --------------------- *)
733 PROCEDURE ThisFinObj* (VAR id: Identifier): ANYPTR;
734 VAR l: FList;
735 BEGIN
736 ASSERT(id.typ # 0, 100);
737 l := finalizers;
738 WHILE l # NIL DO
739 IF S.VAL(INTEGER, l.blk.tag) = id.typ THEN
740 id.obj := S.VAL(ANYPTR, S.ADR(l.blk.last));
741 IF id.Identified() THEN RETURN id.obj END
742 END;
743 l := l.next
744 END;
745 RETURN NIL
746 END ThisFinObj;
748 PROCEDURE InstallReducer* (r: Reducer);
749 BEGIN
750 r.next := reducers; reducers := r
751 END InstallReducer;
753 PROCEDURE InstallTrapViewer* (h: Handler);
754 BEGIN
755 trapViewer := h
756 END InstallTrapViewer;
758 PROCEDURE InstallTrapChecker* (h: Handler);
759 BEGIN
760 trapChecker := h
761 END InstallTrapChecker;
763 PROCEDURE PushTrapCleaner* (c: TrapCleaner);
764 VAR t: TrapCleaner;
765 BEGIN
766 t := trapStack; WHILE (t # NIL) & (t # c) DO t := t.next END;
767 ASSERT(t = NIL, 20);
768 c.next := trapStack; trapStack := c
769 END PushTrapCleaner;
771 PROCEDURE PopTrapCleaner* (c: TrapCleaner);
772 VAR t: TrapCleaner;
773 BEGIN
774 t := NIL;
775 WHILE (trapStack # NIL) & (t # c) DO
776 t := trapStack; trapStack := trapStack.next
777 END
778 END PopTrapCleaner;
780 PROCEDURE InstallCleaner* (p: Command);
781 VAR c: CList;
782 BEGIN
783 c := S.VAL(CList, NewRec(S.TYP(CList))); (* NEW(c) *)
784 c.do := p; c.trapped := FALSE; c.next := cleaners; cleaners := c
785 END InstallCleaner;
787 PROCEDURE RemoveCleaner* (p: Command);
788 VAR c0, c: CList;
789 BEGIN
790 c := cleaners; c0 := NIL;
791 WHILE (c # NIL) & (c.do # p) DO c0 := c; c := c.next END;
792 IF c # NIL THEN
793 IF c0 = NIL THEN cleaners := cleaners.next ELSE c0.next := c.next END
794 END
795 END RemoveCleaner;
797 PROCEDURE Cleanup*;
798 VAR c, c0: CList;
799 BEGIN
800 c := cleaners; c0 := NIL;
801 WHILE c # NIL DO
802 IF ~c.trapped THEN
803 c.trapped := TRUE; c.do; c.trapped := FALSE; c0 := c
804 ELSE
805 IF c0 = NIL THEN cleaners := cleaners.next
806 ELSE c0.next := c.next
807 END
808 END;
809 c := c.next
810 END
811 END Cleanup;
813 (* -------------------- meta information (portable) --------------------- *)
815 PROCEDURE (h: LoaderHook) ThisMod* (IN name: ARRAY OF SHORTCHAR): Module, NEW, ABSTRACT;
817 PROCEDURE SetLoaderHook*(h: LoaderHook);
818 BEGIN
819 loader := h
820 END SetLoaderHook;
822 PROCEDURE InitModule (mod: Module); (* initialize linked modules *)
823 VAR body: Command;
824 res: INTEGER; errno: INTEGER;
825 BEGIN
826 IF ~(dyn IN mod.opts) & (mod.next # NIL) & ~(init IN mod.next.opts) THEN InitModule(mod.next) END;
827 IF ~(init IN mod.opts) THEN
828 body := S.VAL(Command, mod.code);
829 INCL(mod.opts, init);
830 actual := mod;
832 (* A. V. Shiryaev: Allow execution on code pages *)
833 (* Linux: must be page-aligned *)
834 res := Libc.mprotect(
835 (mod.code DIV pageSize) * pageSize,
836 ((mod.csize + mod.code MOD pageSize - 1) DIV pageSize) * pageSize + pageSize,
837 Libc.PROT_READ + Libc.PROT_WRITE + Libc.PROT_EXEC);
838 IF res = -1 THEN
839 S.GET( Libc.__errno_location(), errno );
840 Msg("ERROR: Kernel.InitModule: mprotect failed!");
841 Msg(mod.name$); Int(mod.code); Int(mod.csize); Int(errno);
842 HALT(100)
843 ELSE ASSERT(res = 0)
844 END;
846 body(); actual := NIL
847 END
848 END InitModule;
850 PROCEDURE ThisLoadedMod* (IN name: ARRAY OF SHORTCHAR): Module; (* loaded modules only *)
851 VAR m: Module;
852 BEGIN
853 loadres := done;
854 m := modList;
855 WHILE (m # NIL) & ((m.name # name) OR (m.refcnt < 0)) DO m := m.next END;
856 IF (m # NIL) & ~(init IN m.opts) THEN InitModule(m) END;
857 IF m = NIL THEN loadres := moduleNotFound END;
858 RETURN m
859 END ThisLoadedMod;
861 PROCEDURE ThisMod* (IN name: ARRAY OF CHAR): Module;
862 VAR n : Name;
863 BEGIN
864 n := SHORT(name$);
865 IF loader # NIL THEN
866 loader.res := done;
867 RETURN loader.ThisMod(n)
868 ELSE
869 RETURN ThisLoadedMod(n)
870 END
871 END ThisMod;
873 PROCEDURE LoadMod* (IN name: ARRAY OF CHAR);
874 VAR m: Module;
875 BEGIN
876 m := ThisMod(name)
877 END LoadMod;
879 PROCEDURE GetLoaderResult* (OUT res: INTEGER; OUT importing, imported, object: ARRAY OF CHAR);
880 BEGIN
881 IF loader # NIL THEN
882 res := loader.res;
883 importing := loader.importing$;
884 imported := loader.imported$;
885 object := loader.object$
886 ELSE
887 res := loadres;
888 importing := "";
889 imported := "";
890 object := ""
891 END
892 END GetLoaderResult;
894 PROCEDURE ThisObject* (mod: Module; name: ARRAY OF SHORTCHAR): Object;
895 VAR l, r, m: INTEGER; p: StrPtr;
896 BEGIN
897 l := 0; r := mod.export.num;
898 WHILE l < r DO (* binary search *)
899 m := (l + r) DIV 2;
900 p := S.VAL(StrPtr, S.ADR(mod.names[mod.export.obj[m].id DIV 256]));
901 IF p^ = name THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[m])) END;
902 IF p^ < name THEN l := m + 1 ELSE r := m END
903 END;
904 RETURN NIL
905 END ThisObject;
907 PROCEDURE ThisDesc* (mod: Module; fprint: INTEGER): Object;
908 VAR i, n: INTEGER;
909 BEGIN
910 i := 0; n := mod.export.num;
911 WHILE (i < n) & (mod.export.obj[i].id DIV 256 = 0) DO
912 IF mod.export.obj[i].offs = fprint THEN RETURN S.VAL(Object, S.ADR(mod.export.obj[i])) END;
913 INC(i)
914 END;
915 RETURN NIL
916 END ThisDesc;
918 PROCEDURE ThisField* (rec: Type; name: ARRAY OF SHORTCHAR): Object;
919 VAR n: INTEGER; p: StrPtr; obj: Object; m: Module;
920 BEGIN
921 m := rec.mod;
922 obj := S.VAL(Object, S.ADR(rec.fields.obj[0])); n := rec.fields.num;
923 WHILE n > 0 DO
924 p := S.VAL(StrPtr, S.ADR(m.names[obj.id DIV 256]));
925 IF p^ = name THEN RETURN obj END;
926 DEC(n); INC(S.VAL(INTEGER, obj), 16)
927 END;
928 RETURN NIL
929 END ThisField;
931 PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF SHORTCHAR): Command;
932 VAR x: Object; sig: Signature;
933 BEGIN
934 x := ThisObject(mod, name);
935 IF (x # NIL) & (x.id MOD 16 = mProc) THEN
936 sig := S.VAL(Signature, x.struct);
937 IF (sig.retStruct = NIL) & (sig.num = 0) THEN RETURN S.VAL(Command, mod.procBase + x.offs) END
938 END;
939 RETURN NIL
940 END ThisCommand;
942 PROCEDURE ThisType* (mod: Module; name: ARRAY OF SHORTCHAR): Type;
943 VAR x: Object;
944 BEGIN
945 x := ThisObject(mod, name);
946 IF (x # NIL) & (x.id MOD 16 = mTyp) & (S.VAL(INTEGER, x.struct) DIV 256 # 0) THEN
947 RETURN x.struct
948 ELSE
949 RETURN NIL
950 END
951 END ThisType;
953 PROCEDURE TypeOf* (IN rec: ANYREC): Type;
954 BEGIN
955 RETURN S.VAL(Type, S.TYP(rec))
956 END TypeOf;
958 PROCEDURE LevelOf* (t: Type): SHORTINT;
959 BEGIN
960 RETURN SHORT(t.id DIV 16 MOD 16)
961 END LevelOf;
963 PROCEDURE NewObj* (VAR o: S.PTR; t: Type);
964 VAR i: INTEGER;
965 BEGIN
966 IF t.size = -1 THEN o := NIL
967 ELSE
968 i := 0; WHILE t.ptroffs[i] >= 0 DO INC(i) END;
969 IF t.ptroffs[i+1] >= 0 THEN INC(S.VAL(INTEGER, t)) END; (* with interface pointers *)
970 o := S.VAL(S.PTR, NewRec(S.VAL(INTEGER, t))) (* generic NEW *)
971 END
972 END NewObj;
974 PROCEDURE GetObjName* (mod: Module; obj: Object; VAR name: Name);
975 VAR p: StrPtr;
976 BEGIN
977 p := S.VAL(StrPtr, S.ADR(mod.names[obj.id DIV 256]));
978 name := p^$
979 END GetObjName;
981 PROCEDURE GetTypeName* (t: Type; VAR name: Name);
982 VAR p: StrPtr;
983 BEGIN
984 p := S.VAL(StrPtr, S.ADR(t.mod.names[t.id DIV 256]));
985 name := p^$
986 END GetTypeName;
988 PROCEDURE RegisterMod* (mod: Module);
989 VAR i: INTEGER;
990 t: Libc.time_t; tm: Libc.tm;
991 BEGIN
992 mod.next := modList; modList := mod; mod.refcnt := 0; INCL(mod.opts, dyn); i := 0;
993 WHILE i < mod.nofimps DO
994 IF mod.imports[i] # NIL THEN INC(mod.imports[i].refcnt) END;
995 INC(i)
996 END;
998 t := Libc.time(NIL);
999 tm := Libc.localtime(t);
1000 mod.loadTime[0] := SHORT(tm.tm_year + 1900); (* Linux counts years from 1900 but BlackBox from 0000 *)
1001 mod.loadTime[1] := SHORT(tm.tm_mon + 1) (* Linux month range 0-11 but BB month range 1-12 *);
1002 mod.loadTime[2] := SHORT(tm.tm_mday);
1003 mod.loadTime[3] := SHORT(tm.tm_hour);
1004 mod.loadTime[4] := SHORT(tm.tm_min);
1005 mod.loadTime[5] := SHORT(tm.tm_sec);
1006 tm := NIL;
1008 IF ~(init IN mod.opts) THEN InitModule(mod) END
1009 END RegisterMod;
1011 PROCEDURE^ Collect*;
1013 PROCEDURE UnloadMod* (mod: Module);
1014 VAR i: INTEGER; t: Command;
1015 BEGIN
1016 IF mod.refcnt = 0 THEN
1017 t := mod.term; mod.term := NIL;
1018 IF t # NIL THEN t() END; (* terminate module *)
1019 i := 0;
1020 WHILE i < mod.nofptrs DO (* release global pointers *)
1021 S.PUT(mod.varBase + mod.ptrs[i], 0); INC(i)
1022 END;
1023 (*
1024 ReleaseIPtrs(mod); (* release global interface pointers *)
1025 *)
1026 Collect; (* call finalizers *)
1027 i := 0;
1028 WHILE i < mod.nofimps DO (* release imported modules *)
1029 IF mod.imports[i] # NIL THEN DEC(mod.imports[i].refcnt) END;
1030 INC(i)
1031 END;
1032 mod.refcnt := -1;
1033 IF dyn IN mod.opts THEN (* release memory *)
1034 InvalModMem(mod.data + mod.dsize - mod.refs, mod.refs)
1035 END
1036 END
1037 END UnloadMod;
1039 (* -------------------- dynamic procedure call --------------------- *) (* COMPILER DEPENDENT *)
1041 PROCEDURE [1] PUSH (p: INTEGER) 050H; (* push AX *)
1042 PROCEDURE [1] CALL (a: INTEGER) 0FFH, 0D0H; (* call AX *)
1043 PROCEDURE [1] RETI (): LONGINT;
1044 PROCEDURE [1] RETR (): REAL;
1046 (*
1047 type par
1048 32 bit scalar value
1049 64 bit scalar low hi
1050 var scalar address
1051 record address tag
1052 array address size
1053 open array address length .. length
1054 *)
1056 PROCEDURE Call* (adr: INTEGER; sig: Signature; IN par: ARRAY OF INTEGER; n: INTEGER): LONGINT;
1057 VAR p, kind, sp, size: INTEGER; typ: Type; r: REAL;
1058 BEGIN
1059 p := sig.num;
1060 WHILE p > 0 DO (* push parameters from right to left *)
1061 DEC(p);
1062 typ := sig.par[p].struct;
1063 kind := sig.par[p].id MOD 16;
1064 IF (S.VAL(INTEGER, typ) DIV 256 = 0) OR (typ.id MOD 4 IN {0, 3}) THEN (* scalar *)
1065 IF (kind = 10) & ((S.VAL(INTEGER, typ) = 8) OR (S.VAL(INTEGER, typ) = 10)) THEN (* 64 bit *)
1066 DEC(n); PUSH(par[n]) (* push hi word *)
1067 END;
1068 DEC(n); PUSH(par[n]) (* push value/address *)
1069 ELSIF typ.id MOD 4 = 1 THEN (* record *)
1070 IF kind # 10 THEN (* var par *)
1071 DEC(n); PUSH(par[n]); (* push tag *)
1072 DEC(n); PUSH(par[n]) (* push address *)
1073 ELSE
1074 DEC(n, 2); (* skip tag *)
1075 S.GETREG(SP, sp); sp := (sp - typ.size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *)
1076 S.MOVE(par[n], sp, typ.size) (* copy to stack *)
1077 END
1078 ELSIF typ.size = 0 THEN (* open array *)
1079 size := typ.id DIV 16 MOD 16; (* number of open dimensions *)
1080 WHILE size > 0 DO
1081 DEC(size); DEC(n); PUSH(par[n]) (* push length *)
1082 END;
1083 DEC(n); PUSH(par[n]) (* push address *)
1084 ELSE (* fix array *)
1085 IF kind # 10 THEN (* var par *)
1086 DEC(n, 2); PUSH(par[n]) (* push address *)
1087 ELSE
1088 DEC(n); size := par[n]; DEC(n);
1089 S.GETREG(SP, sp); sp := (sp - size) DIV 4 * 4; S.PUTREG(SP, sp); (* allocate space *)
1090 S.MOVE(par[n], sp, size) (* copy to stack *)
1091 END
1092 END
1093 END;
1094 ASSERT(n = 0);
1095 IF S.VAL(INTEGER, sig.retStruct) = 7 THEN (* shortreal *)
1096 CALL(adr);
1097 RETURN S.VAL(INTEGER, SHORT(RETR())) (* return value in fpu register *)
1098 ELSIF S.VAL(INTEGER, sig.retStruct) = 8 THEN (* real *)
1099 CALL(adr); r := RETR();
1100 RETURN S.VAL(LONGINT, r) (* return value in fpu register *)
1101 ELSE
1102 CALL(adr);
1103 RETURN RETI() (* return value in integer registers *)
1104 END
1105 END Call;
1107 (* -------------------- reference information (portable) --------------------- *)
1109 PROCEDURE RefCh (VAR ref: INTEGER; VAR ch: SHORTCHAR);
1110 BEGIN
1111 S.GET(ref, ch); INC(ref)
1112 END RefCh;
1114 PROCEDURE RefNum (VAR ref: INTEGER; VAR x: INTEGER);
1115 VAR s, n: INTEGER; ch: SHORTCHAR;
1116 BEGIN
1117 s := 0; n := 0; RefCh(ref, ch);
1118 WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); RefCh(ref, ch) END;
1119 x := n + ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s)
1120 END RefNum;
1122 PROCEDURE RefName (VAR ref: INTEGER; VAR n: Name);
1123 VAR i: INTEGER; ch: SHORTCHAR;
1124 BEGIN
1125 i := 0; RefCh(ref, ch);
1126 WHILE ch # 0X DO n[i] := ch; INC(i); RefCh(ref, ch) END;
1127 n[i] := 0X
1128 END RefName;
1130 PROCEDURE GetRefProc* (VAR ref: INTEGER; VAR adr: INTEGER; VAR name: Name);
1131 VAR ch: SHORTCHAR;
1132 BEGIN
1133 S.GET(ref, ch);
1134 WHILE ch >= 0FDX DO (* skip variables *)
1135 INC(ref); RefCh(ref, ch);
1136 IF ch = 10X THEN INC(ref, 4) END;
1137 RefNum(ref, adr); RefName(ref, name); S.GET(ref, ch)
1138 END;
1139 WHILE (ch > 0X) & (ch < 0FCX) DO (* skip source refs *)
1140 INC(ref); RefNum(ref, adr); S.GET(ref, ch)
1141 END;
1142 IF ch = 0FCX THEN INC(ref); RefNum(ref, adr); RefName(ref, name)
1143 ELSE adr := 0
1144 END
1145 END GetRefProc;
1147 (* A. V. Shiryaev, 2012.11 *)
1148 PROCEDURE CheckRefVarReadable (ref: INTEGER): BOOLEAN;
1149 VAR ok: BOOLEAN; ch: SHORTCHAR;
1150 p: INTEGER; (* address *)
1152 PROCEDURE Get;
1153 BEGIN
1154 IF ok THEN
1155 IF IsReadable(ref, ref+1) THEN (* S.GET(ref, ch); INC(ref) *) RefCh(ref, ch)
1156 ELSE ok := FALSE
1157 END
1158 END
1159 END Get;
1161 PROCEDURE Num;
1162 BEGIN
1163 Get; WHILE ok & (ORD(ch) >= 128) DO Get END
1164 END Num;
1166 PROCEDURE Name;
1167 BEGIN
1168 Get; WHILE ok & (ch # 0X) DO Get END
1169 END Name;
1171 BEGIN
1172 ok := TRUE;
1173 Get; (* mode *)
1174 IF ok & (ch >= 0FDX) THEN
1175 Get; (* form *)
1176 IF ok & (ch = 10X) THEN
1177 IF IsReadable(ref, ref + 4) THEN (* desc *)
1178 S.GET(ref, p); INC(ref, 4);
1179 ok := IsReadable(p + 2 * 4, p + 3 * 4) (* desc.id *)
1180 ELSE ok := FALSE
1181 END
1182 END;
1183 Num; Name
1184 END;
1185 RETURN ok
1186 END CheckRefVarReadable;
1188 PROCEDURE GetRefVar* (VAR ref: INTEGER; VAR mode, form: SHORTCHAR; VAR desc: Type;
1189 VAR adr: INTEGER; VAR name: Name);
1190 BEGIN
1191 IF CheckRefVarReadable(ref) THEN
1192 S.GET(ref, mode); desc := NIL;
1193 IF mode >= 0FDX THEN
1194 mode := SHORT(CHR(ORD(mode) - 0FCH));
1195 INC(ref); RefCh(ref, form);
1196 IF form = 10X THEN
1197 S.GET(ref, desc); INC(ref, 4); form := SHORT(CHR(16 + desc.id MOD 4))
1198 END;
1199 RefNum(ref, adr); RefName(ref, name)
1200 ELSE
1201 mode := 0X; form := 0X; adr := 0
1202 END
1203 ELSE
1204 Msg("Kernel.GetRefVar failed!"); Int(ref);
1205 mode := 0X; form := 0X; adr := 0
1206 END
1207 END GetRefVar;
1209 PROCEDURE SourcePos* (mod: Module; codePos: INTEGER): INTEGER;
1210 VAR ref, pos, ad, d: INTEGER; ch: SHORTCHAR; name: Name;
1211 BEGIN
1212 ref := mod.refs; pos := 0; ad := 0; S.GET(ref, ch);
1213 WHILE ch # 0X DO
1214 WHILE (ch > 0X) & (ch < 0FCX) DO
1215 INC(ad, ORD(ch)); INC(ref); RefNum(ref, d);
1216 IF ad > codePos THEN RETURN pos END;
1217 INC(pos, d); S.GET(ref, ch)
1218 END;
1219 IF ch = 0FCX THEN INC(ref); RefNum(ref, d); RefName(ref, name); S.GET(ref, ch) END;
1220 WHILE ch >= 0FDX DO (* skip variables *)
1221 INC(ref); RefCh(ref, ch);
1222 IF ch = 10X THEN INC(ref, 4) END;
1223 RefNum(ref, d); RefName(ref, name); S.GET(ref, ch)
1224 END
1225 END;
1226 RETURN -1
1227 END SourcePos;
1229 (* -------------------- dynamic link libraries --------------------- *)
1231 (*
1232 PROCEDURE DlOpen (name: ARRAY OF SHORTCHAR): Dl.HANDLE;
1233 CONST flags = Dl.RTLD_LAZY + Dl.RTLD_GLOBAL;
1234 VAR h: Dl.HANDLE;
1235 i: INTEGER;
1236 BEGIN
1237 h := Dl.NULL;
1238 i := 0; WHILE (i < LEN(name)) & (name[i] # 0X) DO INC(i) END;
1239 IF i < LEN(name) THEN
1240 h := Dl.dlopen(name, flags);
1241 WHILE (h = Dl.NULL) & (i > 0) DO
1242 DEC(i);
1243 WHILE (i > 0) & (name[i] # '.') DO DEC(i) END;
1244 IF i > 0 THEN
1245 name[i] := 0X;
1246 h := Dl.dlopen(name, flags);
1247 (* IF h # Dl.NULL THEN Msg(name$) END *)
1248 END
1249 END
1250 END;
1251 RETURN h
1252 END DlOpen;
1253 *)
1255 PROCEDURE LoadDll* (IN name: ARRAY OF SHORTCHAR; VAR ok: BOOLEAN);
1256 VAR h: Dl.HANDLE;
1257 BEGIN
1258 ok := FALSE;
1259 h := Dl.dlopen(name, Dl.RTLD_LAZY + Dl.RTLD_GLOBAL);
1260 IF h # Dl.NULL THEN ok := TRUE END
1261 END LoadDll;
1263 PROCEDURE ThisDllObj* (mode, fprint: INTEGER; IN dll, name: ARRAY OF SHORTCHAR): INTEGER;
1264 VAR ad: INTEGER; h: Dl.HANDLE;
1265 BEGIN
1266 ad := 0;
1267 IF mode IN {mVar, mProc} THEN
1268 h := Dl.dlopen(dll, Dl.RTLD_LAZY+ Dl.RTLD_GLOBAL);
1269 IF h # Dl.NULL THEN
1270 ad := Dl.dlsym(h, name);
1271 END
1272 END;
1273 RETURN ad
1274 END ThisDllObj;
1276 (* -------------------- garbage collector (portable) --------------------- *)
1278 PROCEDURE Mark (this: Block);
1279 VAR father, son: Block; tag: Type; flag, offset, actual: INTEGER;
1280 BEGIN
1281 IF ~ODD(S.VAL(INTEGER, this.tag)) THEN
1282 father := NIL;
1283 LOOP
1284 INC(S.VAL(INTEGER, this.tag));
1285 flag := S.VAL(INTEGER, this.tag) MOD 4;
1286 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1287 IF flag >= 2 THEN actual := this.first; this.actual := actual
1288 ELSE actual := S.ADR(this.last)
1289 END;
1290 LOOP
1291 offset := tag.ptroffs[0];
1292 IF offset < 0 THEN
1293 INC(S.VAL(INTEGER, tag), offset + 4); (* restore tag *)
1294 IF (flag >= 2) & (actual < this.last) & (offset < -4) THEN (* next array element *)
1295 INC(actual, tag.size); this.actual := actual
1296 ELSE (* up *)
1297 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1298 IF father = NIL THEN RETURN END;
1299 son := this; this := father;
1300 flag := S.VAL(INTEGER, this.tag) MOD 4;
1301 tag := S.VAL(Type, S.VAL(INTEGER, this.tag) - flag);
1302 offset := tag.ptroffs[0];
1303 IF flag >= 2 THEN actual := this.actual ELSE actual := S.ADR(this.last) END;
1304 S.GET(actual + offset, father); S.PUT(actual + offset, S.ADR(son.last));
1305 INC(S.VAL(INTEGER, tag), 4)
1306 END
1307 ELSE
1308 S.GET(actual + offset, son);
1309 IF son # NIL THEN
1310 DEC(S.VAL(INTEGER, son), 4);
1311 IF ~ODD(S.VAL(INTEGER, son.tag)) THEN (* down *)
1312 this.tag := S.VAL(Type, S.VAL(INTEGER, tag) + flag);
1313 S.PUT(actual + offset, father); father := this; this := son;
1314 EXIT
1315 END
1316 END;
1317 INC(S.VAL(INTEGER, tag), 4)
1318 END
1319 END
1320 END
1321 END
1322 END Mark;
1324 PROCEDURE MarkGlobals;
1325 VAR m: Module; i, p: INTEGER;
1326 BEGIN
1327 m := modList;
1328 WHILE m # NIL DO
1329 IF m.refcnt >= 0 THEN
1330 i := 0;
1331 WHILE i < m.nofptrs DO
1332 S.GET(m.varBase + m.ptrs[i], p); INC(i);
1333 IF p # 0 THEN Mark(S.VAL(Block, p - 4)) END
1334 END
1335 END;
1336 m := m.next
1337 END
1338 END MarkGlobals;
1340 (* This is the specification for the code procedure following below:
1342 PROCEDURE Next (b: Block): Block; (* next block in same cluster *)
1343 VAR size: INTEGER;
1344 BEGIN
1345 S.GET(S.VAL(INTEGER, b.tag) DIV 4 * 4, size);
1346 IF ODD(S.VAL(INTEGER, b.tag) DIV 2) THEN INC(size, b.last - S.ADR(b.last)) END;
1347 RETURN S.VAL(Block, S.VAL(INTEGER, b) + (size + 19) DIV 16 * 16)
1348 END Next;
1350 *)
1351 PROCEDURE [code] Next (b: Block): Block (* next block in same cluster *)
1352 (*
1353 MOV ECX,[EAX] b.tag
1354 AND CL,0FCH b.tag DIV * 4
1355 MOV ECX,[ECX] size
1356 TESTB [EAX],02H ODD(b.tag DIV 2)
1357 JE L1
1358 ADD ECX,[EAX,4] size + b.last
1359 SUB ECX,EAX
1360 SUB ECX,4 size + b.last - ADR(b.last)
1361 L1:
1362 ADD ECX,19 size + 19
1363 AND CL,0F0H (size + 19) DIV 16 * 16
1364 ADD EAX,ECX b + size
1365 *)
1366 08BH, 008H,
1367 080H, 0E1H, 0FCH,
1368 08BH, 009H,
1369 0F6H, 000H, 002H,
1370 074H, 008H,
1371 003H, 048H, 004H,
1372 029H, 0C1H,
1373 083H, 0E9H, 004H,
1374 083H, 0C1H, 013H,
1375 080H, 0E1H, 0F0H,
1376 001H, 0C8H;
1378 PROCEDURE CheckCandidates;
1379 (* pre: nofcand > 0 *)
1380 VAR i, j, h, p, end: INTEGER; c: Cluster; blk, next: Block;
1381 BEGIN
1382 (* sort candidates (shellsort) *)
1383 h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
1384 REPEAT h := h DIV 3; i := h;
1385 WHILE i < nofcand DO p := candidates[i]; j := i;
1386 WHILE (j >= h) & (candidates[j-h] > p) DO
1387 candidates[j] := candidates[j-h]; j := j-h
1388 END;
1389 candidates[j] := p; INC(i)
1390 END
1391 UNTIL h = 1;
1392 (* sweep *)
1393 c := root; i := 0;
1394 WHILE c # NIL DO
1395 blk := S.VAL(Block, S.VAL(INTEGER, c) + 12);
1396 end := S.VAL(INTEGER, blk) + (c.size - 12) DIV 16 * 16;
1397 WHILE candidates[i] < S.VAL(INTEGER, blk) DO
1398 INC(i);
1399 IF i = nofcand THEN RETURN END
1400 END;
1401 WHILE S.VAL(INTEGER, blk) < end DO
1402 next := Next(blk);
1403 IF candidates[i] < S.VAL(INTEGER, next) THEN
1404 IF (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last)) (* not a free block *)
1405 & (~strictStackSweep OR (candidates[i] = S.ADR(blk.last))) THEN
1406 Mark(blk)
1407 END;
1408 REPEAT
1409 INC(i);
1410 IF i = nofcand THEN RETURN END
1411 UNTIL candidates[i] >= S.VAL(INTEGER, next)
1412 END;
1413 IF (S.VAL(INTEGER, blk.tag) MOD 4 = 0) & (S.VAL(INTEGER, blk.tag) # S.ADR(blk.last))
1414 & (blk.tag.base[0] = NIL) & (blk.actual > 0) THEN (* referenced interface record *)
1415 Mark(blk)
1416 END;
1417 blk := next
1418 END;
1419 c := c.next
1420 END
1421 END CheckCandidates;
1423 PROCEDURE MarkLocals;
1424 VAR sp, p, min, max: INTEGER; c: Cluster;
1425 BEGIN
1426 S.GETREG(FP, sp); nofcand := 0; c := root;
1427 WHILE c.next # NIL DO c := c.next END;
1428 min := S.VAL(INTEGER, root); max := S.VAL(INTEGER, c) + c.size;
1429 WHILE sp < baseStack DO
1430 S.GET(sp, p);
1431 IF (p > min) & (p < max) & (~strictStackSweep OR (p MOD 16 = 0)) THEN
1432 candidates[nofcand] := p; INC(nofcand);
1433 IF nofcand = LEN(candidates) - 1 THEN CheckCandidates; nofcand := 0 END
1434 END;
1435 INC(sp, 4)
1436 END;
1437 candidates[nofcand] := max; INC(nofcand); (* ensure complete scan for interface mark*)
1438 IF nofcand > 0 THEN CheckCandidates END
1439 END MarkLocals;
1441 PROCEDURE MarkFinObj;
1442 VAR f: FList;
1443 BEGIN
1444 wouldFinalize := FALSE;
1445 f := finalizers;
1446 WHILE f # NIL DO
1447 IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1448 Mark(f.blk);
1449 f := f.next
1450 END;
1451 f := hotFinalizers;
1452 WHILE f # NIL DO IF ~ODD(S.VAL(INTEGER, f.blk.tag)) THEN wouldFinalize := TRUE END;
1453 Mark(f.blk);
1454 f := f.next
1455 END
1456 END MarkFinObj;
1458 PROCEDURE CheckFinalizers;
1459 VAR f, g, h, k: FList;
1460 BEGIN
1461 f := finalizers; g := NIL;
1462 IF hotFinalizers = NIL THEN k := NIL
1463 ELSE
1464 k := hotFinalizers;
1465 WHILE k.next # NIL DO k := k.next END
1466 END;
1467 WHILE f # NIL DO
1468 h := f; f := f.next;
1469 IF ~ODD(S.VAL(INTEGER, h.blk.tag)) THEN
1470 IF g = NIL THEN finalizers := f ELSE g.next := f END;
1471 IF k = NIL THEN hotFinalizers := h ELSE k.next := h END;
1472 k := h; h.next := NIL
1473 ELSE g := h
1474 END
1475 END;
1476 h := hotFinalizers;
1477 WHILE h # NIL DO Mark(h.blk); h := h.next END
1478 END CheckFinalizers;
1480 PROCEDURE ExecFinalizer (a, b, c: INTEGER);
1481 VAR f: FList; fin: PROCEDURE(this: ANYPTR);
1482 BEGIN
1483 f := S.VAL(FList, a);
1484 IF f.aiptr THEN (* ArrFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) *)
1485 ELSE
1486 S.GET(S.VAL(INTEGER, f.blk.tag) - 4, fin); (* method 0 *)
1487 IF (fin # NIL) & (f.blk.tag.mod.refcnt >= 0) THEN fin(S.VAL(ANYPTR, S.ADR(f.blk.last))) END;
1488 (*
1489 IF f.iptr THEN RecFinalizer(S.VAL(ANYPTR, S.ADR(f.blk.last))) END
1490 *)
1491 END
1492 END ExecFinalizer;
1494 PROCEDURE^ Try* (h: TryHandler; a, b, c: INTEGER); (* COMPILER DEPENDENT *)
1496 PROCEDURE CallFinalizers;
1497 VAR f: FList;
1498 BEGIN
1499 WHILE hotFinalizers # NIL DO
1500 f := hotFinalizers; hotFinalizers := hotFinalizers.next;
1501 Try(ExecFinalizer, S.VAL(INTEGER, f), 0, 0)
1502 END;
1503 wouldFinalize := FALSE
1504 END CallFinalizers;
1506 PROCEDURE Insert (blk: FreeBlock; size: INTEGER); (* insert block in free list *)
1507 VAR i: INTEGER;
1508 BEGIN
1509 blk.size := size - 4; blk.tag := S.VAL(Type, S.ADR(blk.size));
1510 i := MIN(N - 1, (blk.size DIV 16));
1511 blk.next := free[i]; free[i] := blk
1512 END Insert;
1514 PROCEDURE Sweep (dealloc: BOOLEAN);
1515 VAR cluster, last, c: Cluster; blk, next: Block; fblk, b, t: FreeBlock; end, i: INTEGER;
1516 BEGIN
1517 cluster := root; last := NIL; allocated := 0;
1518 i := N;
1519 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
1520 WHILE cluster # NIL DO
1521 blk := S.VAL(Block, S.VAL(INTEGER, cluster) + 12);
1522 end := S.VAL(INTEGER, blk) + (cluster.size - 12) DIV 16 * 16;
1523 fblk := NIL;
1524 WHILE S.VAL(INTEGER, blk) < end DO
1525 next := Next(blk);
1526 IF ODD(S.VAL(INTEGER, blk.tag)) THEN
1527 IF fblk # NIL THEN
1528 Insert(fblk, S.VAL(INTEGER, blk) - S.VAL(INTEGER, fblk));
1529 fblk := NIL
1530 END;
1531 DEC(S.VAL(INTEGER, blk.tag)); (* unmark *)
1532 INC(allocated, S.VAL(INTEGER, next) - S.VAL(INTEGER, blk))
1533 ELSIF fblk = NIL THEN
1534 fblk := S.VAL(FreeBlock, blk)
1535 END;
1536 blk := next
1537 END;
1538 IF dealloc & (S.VAL(INTEGER, fblk) = S.VAL(INTEGER, cluster) + 12) THEN (* deallocate cluster *)
1539 c := cluster; cluster := cluster.next;
1540 IF last = NIL THEN root := cluster ELSE last.next := cluster END;
1541 FreeHeapMem(c)
1542 ELSE
1543 IF fblk # NIL THEN Insert(fblk, end - S.VAL(INTEGER, fblk)) END;
1544 last := cluster; cluster := cluster.next
1545 END
1546 END;
1547 (* reverse free list *)
1548 i := N;
1549 REPEAT
1550 DEC(i);
1551 b := free[i]; fblk := sentinel;
1552 WHILE b # sentinel DO t := b; b := t.next; t.next := fblk; fblk := t END;
1553 free[i] := fblk
1554 UNTIL i = 0
1555 END Sweep;
1557 PROCEDURE Collect*;
1558 BEGIN
1559 IF root # NIL THEN
1560 CallFinalizers; (* trap cleanup *)
1561 IF debug & (watcher # NIL) THEN watcher(1) END;
1562 MarkGlobals;
1563 MarkLocals;
1564 CheckFinalizers;
1565 Sweep(TRUE);
1566 CallFinalizers
1567 END
1568 END Collect;
1570 PROCEDURE FastCollect*;
1571 BEGIN
1572 IF root # NIL THEN
1573 IF debug & (watcher # NIL) THEN watcher(2) END;
1574 MarkGlobals;
1575 MarkLocals;
1576 MarkFinObj;
1577 Sweep(FALSE)
1578 END
1579 END FastCollect;
1581 PROCEDURE WouldFinalize* (): BOOLEAN;
1582 BEGIN
1583 RETURN wouldFinalize
1584 END WouldFinalize;
1586 (* --------------------- memory allocation (portable) -------------------- *)
1588 PROCEDURE OldBlock (size: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1589 VAR b, l: FreeBlock; s, i: INTEGER;
1590 BEGIN
1591 IF debug & (watcher # NIL) THEN watcher(3) END;
1592 s := size - 4;
1593 i := MIN(N - 1, s DIV 16);
1594 WHILE (i # N - 1) & (free[i] = sentinel) DO INC(i) END;
1595 b := free[i]; l := NIL;
1596 WHILE b.size < s DO l := b; b := b.next END;
1597 IF b # sentinel THEN
1598 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1599 ELSE b := NIL
1600 END;
1601 RETURN b
1602 END OldBlock;
1604 PROCEDURE LastBlock (limit: INTEGER): FreeBlock; (* size MOD 16 = 0 *)
1605 VAR b, l: FreeBlock; s, i: INTEGER;
1606 BEGIN
1607 s := limit - 4;
1608 i := 0;
1609 REPEAT
1610 b := free[i]; l := NIL;
1611 WHILE (b # sentinel) & (S.VAL(INTEGER, b) + b.size # s) DO l := b; b := b.next END;
1612 IF b # sentinel THEN
1613 IF l = NIL THEN free[i] := b.next ELSE l.next := b.next END
1614 ELSE b := NIL
1615 END;
1616 INC(i)
1617 UNTIL (b # NIL) OR (i = N);
1618 RETURN b
1619 END LastBlock;
1621 PROCEDURE NewBlock (size: INTEGER): Block;
1622 VAR tsize, a, s: INTEGER; b: FreeBlock; new, c: Cluster; r: Reducer;
1623 BEGIN
1624 ASSERT(size>=0,20);
1625 IF size >7FFFFFECH THEN RETURN NIL END; (*20120822 Marc*)
1626 tsize := (size + 19) DIV 16 * 16;
1627 b := OldBlock(tsize); (* 1) search for free block *)
1628 IF b = NIL THEN
1629 FastCollect; b := OldBlock(tsize); (* 2) collect *)
1630 IF b = NIL THEN
1631 Collect; b := OldBlock(tsize); (* 2a) fully collect *)
1632 END;
1633 IF b = NIL THEN
1634 AllocHeapMem(tsize + 12, new); (* 3) allocate new cluster *)
1635 IF new # NIL THEN
1636 IF (root = NIL) OR (S.VAL(INTEGER, new) < S.VAL(INTEGER, root)) THEN
1637 new.next := root; root := new
1638 ELSE
1639 c := root;
1640 WHILE (c.next # NIL) & (S.VAL(INTEGER, new) > S.VAL(INTEGER, c.next)) DO c := c.next END;
1641 new.next := c.next; c.next := new
1642 END;
1643 b := S.VAL(FreeBlock, S.VAL(INTEGER, new) + 12);
1644 b.size := (new.size - 12) DIV 16 * 16 - 4
1645 ELSE
1646 RETURN NIL (* 4) give up *)
1647 END
1648 END
1649 END;
1650 (* b # NIL *)
1651 a := b.size + 4 - tsize;
1652 IF a > 0 THEN Insert(S.VAL(FreeBlock, S.VAL(INTEGER, b) + tsize), a) END;
1653 IF size > 0 THEN Erase(S.ADR(b.size), (size + 3) DIV 4) END;
1654 INC(allocated, tsize);
1655 RETURN S.VAL(Block, b)
1656 END NewBlock;
1658 PROCEDURE Allocated* (): INTEGER;
1659 BEGIN
1660 RETURN allocated
1661 END Allocated;
1663 PROCEDURE Used* (): INTEGER;
1664 BEGIN
1665 RETURN used
1666 END Used;
1668 PROCEDURE Root* (): INTEGER;
1669 BEGIN
1670 RETURN S.VAL(INTEGER, root)
1671 END Root;
1674 (* -------------------- Trap Handling --------------------- *)
1676 PROCEDURE^ InitFpu;
1678 PROCEDURE Start* (code: Command);
1679 BEGIN
1680 restart := code;
1681 S.GETREG(SP, baseStack); (* save base stack *)
1682 res := Libc.sigsetjmp(loopContext, Libc.TRUE);
1683 code()
1684 END Start;
1686 PROCEDURE Quit* (exitCode: INTEGER);
1687 VAR m: Module; term: Command; t: BOOLEAN;
1688 res: INTEGER;
1689 BEGIN
1690 trapViewer := NIL; trapChecker := NIL; restart := NIL;
1691 t := terminating; terminating := TRUE; m := modList;
1692 WHILE m # NIL DO (* call terminators *)
1693 IF ~static OR ~t THEN
1694 term := m.term; m.term := NIL;
1695 IF term # NIL THEN term() END
1696 END;
1697 (*
1698 ReleaseIPtrs(m);
1699 *)
1700 m := m.next
1701 END;
1702 CallFinalizers;
1703 hotFinalizers := finalizers; finalizers := NIL;
1704 CallFinalizers;
1705 (*
1706 IF ~inDll THEN
1707 RemoveExcp(excpPtr^);
1708 WinApi.ExitProcess(exitCode) (* never returns *)
1709 END
1710 *)
1712 res := Libc.fflush(0);
1713 Libc.exit(exitCode)
1714 END Quit;
1716 PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
1717 VAR res: INTEGER; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR;
1718 BEGIN
1719 title := "Error xy";
1720 title[6] := CHR(id DIV 10 + ORD("0"));
1721 title[7] := CHR(id MOD 10 + ORD("0"));
1722 (*
1723 res := WinApi.MessageBoxW(0, str, title, {});
1724 *)
1725 text := SHORT(str$);
1726 res := MessageBox(title$, SHORT(str), {mbOk});
1727 (*
1728 IF ~inDll THEN RemoveExcp(excpPtr^) END;
1729 *)
1730 (*
1731 WinApi.ExitProcess(1)
1732 *)
1733 Libc.exit(1)
1734 (* never returns *)
1735 END FatalError;
1737 PROCEDURE DefaultTrapViewer;
1738 VAR len, ref, end, x, a, b, c: INTEGER; mod: Module;
1739 name: Name; out: ARRAY 1024 OF SHORTCHAR;
1741 PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
1742 VAR i: INTEGER;
1743 BEGIN
1744 i := 0;
1745 WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
1746 END WriteString;
1748 PROCEDURE WriteHex (x, n: INTEGER);
1749 VAR i, y: INTEGER;
1750 BEGIN
1751 IF len + n < LEN(out) THEN
1752 i := len + n - 1;
1753 WHILE i >= len DO
1754 y := x MOD 16; x := x DIV 16;
1755 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1756 out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
1757 END;
1758 INC(len, n)
1759 END
1760 END WriteHex;
1762 PROCEDURE WriteLn;
1763 BEGIN
1764 IF len < LEN(out) - 1 THEN out[len] := 0AX (* 0DX on Windows *); INC(len) END
1765 END WriteLn;
1767 BEGIN
1768 len := 0;
1769 IF err = 129 THEN WriteString("invalid with")
1770 ELSIF err = 130 THEN WriteString("invalid case")
1771 ELSIF err = 131 THEN WriteString("function without return")
1772 ELSIF err = 132 THEN WriteString("type guard")
1773 ELSIF err = 133 THEN WriteString("implied type guard")
1774 ELSIF err = 134 THEN WriteString("value out of range")
1775 ELSIF err = 135 THEN WriteString("index out of range")
1776 ELSIF err = 136 THEN WriteString("string too long")
1777 ELSIF err = 137 THEN WriteString("stack overflow")
1778 ELSIF err = 138 THEN WriteString("integer overflow")
1779 ELSIF err = 139 THEN WriteString("division by zero")
1780 ELSIF err = 140 THEN WriteString("infinite real result")
1781 ELSIF err = 141 THEN WriteString("real underflow")
1782 ELSIF err = 142 THEN WriteString("real overflow")
1783 ELSIF err = 143 THEN WriteString("undefined real result")
1784 ELSIF err = 200 THEN WriteString("keyboard interrupt")
1785 ELSIF err = 202 THEN WriteString("illegal instruction: ");
1786 WriteHex(val, 4)
1787 ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
1788 WriteHex(val, 8); WriteString("]")
1789 ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
1790 WriteHex(val, 8); WriteString("]")
1791 ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
1792 WriteHex(val, 8); WriteString("]")
1793 ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
1794 ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
1795 WriteString("trap #"); WriteHex(err, 3)
1796 END;
1797 a := pc; b := fp; c := 12;
1798 REPEAT
1799 WriteLn; WriteString("- ");
1800 mod := modList;
1801 WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
1802 IF mod # NIL THEN
1803 DEC(a, mod.code);
1804 IF mod.refcnt >= 0 THEN
1805 WriteString(mod.name); ref := mod.refs;
1806 REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
1807 IF a < end THEN
1808 WriteString("."); WriteString(name)
1809 END
1810 ELSE
1811 WriteString("("); WriteString(mod.name); WriteString(")")
1812 END;
1813 WriteString(" ")
1814 END;
1815 WriteString("(pc="); WriteHex(a, 8);
1816 WriteString(", fp="); WriteHex(b, 8); WriteString(")");
1817 IF (b >= sp) & (b < stack) THEN
1818 S.GET(b+4, a); (* stacked pc *)
1819 S.GET(b, b); (* dynamic link *)
1820 DEC(c)
1821 ELSE c := 0
1822 END
1823 UNTIL c = 0;
1824 out[len] := 0X;
1825 x := MessageBox("BlackBox", out$, {mbOk})
1826 END DefaultTrapViewer;
1828 PROCEDURE TrapCleanup;
1829 VAR t: TrapCleaner;
1830 BEGIN
1831 WHILE trapStack # NIL DO
1832 t := trapStack; trapStack := trapStack.next; t.Cleanup
1833 END;
1834 IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
1835 END TrapCleanup;
1837 PROCEDURE SetTrapGuard* (on: BOOLEAN);
1838 BEGIN
1839 guarded := on
1840 END SetTrapGuard;
1842 PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
1843 VAR res: INTEGER; context: Libc.sigjmp_buf; oldContext: POINTER TO Libc.sigjmp_buf;
1844 BEGIN
1845 oldContext := currentTryContext;
1846 res := Libc.sigsetjmp(context, Libc.TRUE);
1847 currentTryContext := S.ADR(context);
1848 IF res = 0 THEN (* first time around *)
1849 h(a, b, c);
1850 ELSIF res = trapReturn THEN (* after a trap *)
1851 ELSE
1852 HALT(100)
1853 END;
1854 currentTryContext := oldContext;
1855 END Try;
1857 (* -------------------- Initialization --------------------- *)
1859 PROCEDURE InitFpu; (* COMPILER DEPENDENT *)
1860 (* could be eliminated, delayed for backward compatibility *)
1861 VAR cw: SET;
1862 BEGIN
1863 FINIT;
1864 FSTCW;
1865 (* denorm, underflow, precision, zero div, overflow masked *)
1866 (* invalid trapped *)
1867 (* round to nearest, temp precision *)
1868 cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9};
1869 FLDCW
1870 END InitFpu;
1872 PROCEDURE [ccall] TrapHandler (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t);
1873 BEGIN
1874 IF isReadableCheck THEN
1875 isReadableCheck := FALSE;
1876 Msg("~IsReadable");
1877 Libc.siglongjmp(isReadableContext, 1)
1878 END;
1880 (*
1881 S.GETREG(SP, sp);
1882 S.GETREG(FP, fp);
1883 *)
1884 stack := baseStack;
1886 sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *)
1887 fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *)
1888 pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *)
1889 val := siginfo.si_addr;
1891 (*
1892 Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno);
1893 Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int);
1894 *)
1895 err := sig;
1896 IF trapped THEN DefaultTrapViewer END;
1897 CASE sig OF
1898 Libc.SIGINT:
1899 err := 200 (* Interrupt (ANSI). *)
1900 | Libc.SIGILL: (* Illegal instruction (ANSI). *)
1901 err := 202; val := 0;
1902 IF IsReadable(pc, pc + 4) THEN
1903 S.GET(pc, val);
1904 IF val MOD 100H = 8DH THEN (* lea reg,reg *)
1905 IF val DIV 100H MOD 100H = 0F0H THEN
1906 err := val DIV 10000H MOD 100H (* trap *)
1907 ELSIF val DIV 1000H MOD 10H = 0EH THEN
1908 err := 128 + val DIV 100H MOD 10H (* run time error *)
1909 END
1910 END
1911 END
1912 | Libc.SIGFPE:
1913 CASE siginfo.si_code OF
1914 0: (* TODO: ?????? *)
1915 IF siginfo.si_int = 8 THEN
1916 err := 139
1917 ELSIF siginfo.si_int = 0 THEN
1918 err := 143
1919 END
1920 | Libc.FPE_INTDIV: err := 139 (* Integer divide by zero. *)
1921 | Libc.FPE_INTOVF: err := 138 (* Integer overflow. *)
1922 | Libc.FPE_FLTDIV: err := 140 (* Floating point divide by zero. *)
1923 | Libc.FPE_FLTOVF: err := 142 (* Floating point overflow. *)
1924 | Libc.FPE_FLTUND: err := 141 (* Floating point underflow. *)
1925 | Libc.FPE_FLTRES: err := 143 (* Floating point inexact result. *)
1926 | Libc.FPE_FLTINV: err := 143 (* Floating point invalid operation. *)
1927 | Libc.FPE_FLTSUB: err := 134 (* Subscript out of range. *)
1928 ELSE
1929 END
1930 | Libc.SIGSEGV: (* Segmentation violation (ANSI). *)
1931 err := 203
1932 ELSE
1933 END;
1934 INC(trapCount);
1935 InitFpu;
1936 TrapCleanup;
1937 IF err # 128 THEN
1938 IF (trapViewer = NIL) OR trapped THEN
1939 DefaultTrapViewer
1940 ELSE
1941 trapped := TRUE;
1942 trapViewer();
1943 trapped := FALSE
1944 END
1945 END;
1946 IF currentTryContext # NIL THEN (* Try failed *)
1947 Libc.siglongjmp(currentTryContext, trapReturn)
1948 ELSE
1949 IF restart # NIL THEN (* Start failed *)
1950 Libc.siglongjmp(loopContext, trapReturn)
1951 END;
1952 Quit(1); (* FIXME *)
1953 END;
1954 trapped := FALSE
1955 END TrapHandler;
1957 PROCEDURE InstallSignals*;
1958 VAR sa, old: Libc.sigaction_t; res, i: INTEGER;
1959 (*
1960 sigstk: Libc.stack_t;
1961 errno: INTEGER;
1962 *)
1963 BEGIN
1964 (*
1965 (* A. V. Shiryaev: Set alternative stack on which signals are to be processed *)
1966 sigstk.ss_sp := sigStack;
1967 sigstk.ss_size := sigStackSize;
1968 sigstk.ss_flags := 0;
1969 res := Libc.sigaltstack(sigstk, NIL);
1970 IF res # 0 THEN Msg("ERROR: Kernel.InstallSignals: sigaltstack failed!");
1971 S.GET( Libc.__errno_location(), errno );
1972 Int(errno);
1973 Libc.exit(1)
1974 END;
1975 *)
1977 sa.sa_sigaction := TrapHandler;
1978 (*
1979 res := LinLibc.sigemptyset(S.ADR(sa.sa_mask));
1980 *)
1981 res := Libc.sigfillset(S.ADR(sa.sa_mask));
1982 sa.sa_flags := (* Libc.SA_ONSTACK + *) Libc.SA_SIGINFO; (* TrapHandler takes three arguments *)
1983 (*
1984 IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END;
1985 IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END;
1986 IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END;
1987 IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END;
1988 IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END;
1989 IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END;
1990 *)
1991 (* respond to all possible signals *)
1992 FOR i := 1 TO Libc._NSIG - 1 DO
1993 IF (i # Libc.SIGKILL)
1994 & (i # Libc.SIGSTOP)
1995 & (i # Libc.SIGWINCH)
1996 THEN
1997 IF Libc.sigaction(i, sa, old) # 0 THEN (* Msg("failed to install signal"); Int(i) *) END;
1998 END
1999 END
2000 END InstallSignals;
2002 PROCEDURE Init;
2003 VAR i: INTEGER;
2004 BEGIN
2005 (*
2006 (* for sigaltstack *)
2007 sigStack := Libc.calloc(1, sigStackSize);
2008 IF sigStack = Libc.NULL THEN
2009 Msg("ERROR: Kernel.Init: calloc(1, sigStackSize) failed!");
2010 Libc.exit(1)
2011 END;
2012 *)
2013 (* for mmap *)
2014 zerofd := Libc.open("/dev/zero", Libc.O_RDWR, {0..8});
2015 IF zerofd < 0 THEN
2016 Msg("ERROR: Kernel.Init: can not open /dev/zero!");
2017 Libc.exit(1)
2018 END;
2019 (* for mprotect *)
2020 pageSize := Libc.sysconf(Libc._SC_PAGESIZE);
2021 IF pageSize < 0 THEN
2022 Msg("ERROR: Kernel.Init: pageSize < 0!");
2023 Libc.exit(1)
2024 END;
2026 isReadableCheck := FALSE;
2028 InstallSignals; (* init exception handling *)
2029 currentTryContext := NIL;
2031 allocated := 0; total := 0; used := 0;
2032 sentinelBlock.size := MAX(INTEGER);
2033 sentinel := S.ADR(sentinelBlock);
2035 (*
2036 S.PUTREG(ML, S.ADR(modList));
2037 *)
2039 i := N;
2040 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
2042 IF inDll THEN
2043 (*
2044 baseStack := FPageWord(4); (* begin of stack segment *)
2045 *)
2046 END;
2047 InitFpu;
2048 IF ~static THEN
2049 InitModule(modList);
2050 IF ~inDll THEN Quit(1) END
2051 END;
2052 told := 0; shift := 0
2053 END Init;
2055 BEGIN
2056 IF modList = NIL THEN (* only once *)
2057 S.GETREG(SP, baseStack); (* TODO: Check that this is ok. *)
2058 IF bootInfo # NIL THEN
2059 modList := bootInfo.modList (* boot loader initializes the bootInfo struct *)
2060 ELSE
2061 S.GETREG(ML, modList) (* linker loads module list to BX *)
2062 END;
2063 static := init IN modList.opts;
2064 inDll := dll IN modList.opts;
2065 Init
2066 END
2067 CLOSE
2068 IF ~terminating THEN
2069 terminating := TRUE;
2070 Quit(0)
2071 END
2072 END Kernel.