46c55e247346c4e90da94a64350a64e26cbd452a
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 (*
1682 S.GETREG(SP, baseStack); (* save base stack *)
1683 *)
1684 res := Libc.sigsetjmp(loopContext, Libc.TRUE);
1685 code()
1686 END Start;
1688 PROCEDURE Quit* (exitCode: INTEGER);
1689 VAR m: Module; term: Command; t: BOOLEAN;
1690 res: INTEGER;
1691 BEGIN
1692 trapViewer := NIL; trapChecker := NIL; restart := NIL;
1693 t := terminating; terminating := TRUE; m := modList;
1694 WHILE m # NIL DO (* call terminators *)
1695 IF ~static OR ~t THEN
1696 term := m.term; m.term := NIL;
1697 IF term # NIL THEN term() END
1698 END;
1699 (*
1700 ReleaseIPtrs(m);
1701 *)
1702 m := m.next
1703 END;
1704 CallFinalizers;
1705 hotFinalizers := finalizers; finalizers := NIL;
1706 CallFinalizers;
1707 (*
1708 IF ~inDll THEN
1709 RemoveExcp(excpPtr^);
1710 WinApi.ExitProcess(exitCode) (* never returns *)
1711 END
1712 *)
1714 res := Libc.fflush(0);
1715 Libc.exit(exitCode)
1716 END Quit;
1718 PROCEDURE FatalError* (id: INTEGER; str: ARRAY OF CHAR);
1719 VAR res: INTEGER; title: ARRAY 16 OF CHAR; text: ARRAY 256 OF SHORTCHAR;
1720 BEGIN
1721 title := "Error xy";
1722 title[6] := CHR(id DIV 10 + ORD("0"));
1723 title[7] := CHR(id MOD 10 + ORD("0"));
1724 (*
1725 res := WinApi.MessageBoxW(0, str, title, {});
1726 *)
1727 text := SHORT(str$);
1728 res := MessageBox(title$, SHORT(str), {mbOk});
1729 (*
1730 IF ~inDll THEN RemoveExcp(excpPtr^) END;
1731 *)
1732 (*
1733 WinApi.ExitProcess(1)
1734 *)
1735 Libc.exit(1)
1736 (* never returns *)
1737 END FatalError;
1739 PROCEDURE DefaultTrapViewer;
1740 VAR len, ref, end, x, a, b, c: INTEGER; mod: Module;
1741 name: Name; out: ARRAY 1024 OF SHORTCHAR;
1743 PROCEDURE WriteString (s: ARRAY OF SHORTCHAR);
1744 VAR i: INTEGER;
1745 BEGIN
1746 i := 0;
1747 WHILE (len < LEN(out) - 1) & (s[i] # 0X) DO out[len] := s[i]; INC(i); INC(len) END
1748 END WriteString;
1750 PROCEDURE WriteHex (x, n: INTEGER);
1751 VAR i, y: INTEGER;
1752 BEGIN
1753 IF len + n < LEN(out) THEN
1754 i := len + n - 1;
1755 WHILE i >= len DO
1756 y := x MOD 16; x := x DIV 16;
1757 IF y > 9 THEN y := y + (ORD("A") - ORD("0") - 10) END;
1758 out[i] := SHORT(CHR(y + ORD("0"))); DEC(i)
1759 END;
1760 INC(len, n)
1761 END
1762 END WriteHex;
1764 PROCEDURE WriteLn;
1765 BEGIN
1766 IF len < LEN(out) - 1 THEN out[len] := 0AX (* 0DX on Windows *); INC(len) END
1767 END WriteLn;
1769 BEGIN
1770 len := 0;
1771 IF err = 129 THEN WriteString("invalid with")
1772 ELSIF err = 130 THEN WriteString("invalid case")
1773 ELSIF err = 131 THEN WriteString("function without return")
1774 ELSIF err = 132 THEN WriteString("type guard")
1775 ELSIF err = 133 THEN WriteString("implied type guard")
1776 ELSIF err = 134 THEN WriteString("value out of range")
1777 ELSIF err = 135 THEN WriteString("index out of range")
1778 ELSIF err = 136 THEN WriteString("string too long")
1779 ELSIF err = 137 THEN WriteString("stack overflow")
1780 ELSIF err = 138 THEN WriteString("integer overflow")
1781 ELSIF err = 139 THEN WriteString("division by zero")
1782 ELSIF err = 140 THEN WriteString("infinite real result")
1783 ELSIF err = 141 THEN WriteString("real underflow")
1784 ELSIF err = 142 THEN WriteString("real overflow")
1785 ELSIF err = 143 THEN WriteString("undefined real result")
1786 ELSIF err = 200 THEN WriteString("keyboard interrupt")
1787 ELSIF err = 202 THEN WriteString("illegal instruction: ");
1788 WriteHex(val, 4)
1789 ELSIF err = 203 THEN WriteString("illegal memory read [ad = ");
1790 WriteHex(val, 8); WriteString("]")
1791 ELSIF err = 204 THEN WriteString("illegal memory write [ad = ");
1792 WriteHex(val, 8); WriteString("]")
1793 ELSIF err = 205 THEN WriteString("illegal execution [ad = ");
1794 WriteHex(val, 8); WriteString("]")
1795 ELSIF err < 0 THEN WriteString("exception #"); WriteHex(-err, 2)
1796 ELSE err := err DIV 100 * 256 + err DIV 10 MOD 10 * 16 + err MOD 10;
1797 WriteString("trap #"); WriteHex(err, 3)
1798 END;
1799 a := pc; b := fp; c := 12;
1800 REPEAT
1801 WriteLn; WriteString("- ");
1802 mod := modList;
1803 WHILE (mod # NIL) & ((a < mod.code) OR (a >= mod.code + mod.csize)) DO mod := mod.next END;
1804 IF mod # NIL THEN
1805 DEC(a, mod.code);
1806 IF mod.refcnt >= 0 THEN
1807 WriteString(mod.name); ref := mod.refs;
1808 REPEAT GetRefProc(ref, end, name) UNTIL (end = 0) OR (a < end);
1809 IF a < end THEN
1810 WriteString("."); WriteString(name)
1811 END
1812 ELSE
1813 WriteString("("); WriteString(mod.name); WriteString(")")
1814 END;
1815 WriteString(" ")
1816 END;
1817 WriteString("(pc="); WriteHex(a, 8);
1818 WriteString(", fp="); WriteHex(b, 8); WriteString(")");
1819 IF (b >= sp) & (b < stack) THEN
1820 S.GET(b+4, a); (* stacked pc *)
1821 S.GET(b, b); (* dynamic link *)
1822 DEC(c)
1823 ELSE c := 0
1824 END
1825 UNTIL c = 0;
1826 out[len] := 0X;
1827 x := MessageBox("BlackBox", out$, {mbOk})
1828 END DefaultTrapViewer;
1830 PROCEDURE TrapCleanup;
1831 VAR t: TrapCleaner;
1832 BEGIN
1833 WHILE trapStack # NIL DO
1834 t := trapStack; trapStack := trapStack.next; t.Cleanup
1835 END;
1836 IF (trapChecker # NIL) & (err # 128) THEN trapChecker END
1837 END TrapCleanup;
1839 PROCEDURE SetTrapGuard* (on: BOOLEAN);
1840 BEGIN
1841 guarded := on
1842 END SetTrapGuard;
1844 PROCEDURE Try* (h: TryHandler; a, b, c: INTEGER);
1845 VAR res: INTEGER; context: Libc.sigjmp_buf; oldContext: POINTER TO Libc.sigjmp_buf;
1846 BEGIN
1847 oldContext := currentTryContext;
1848 res := Libc.sigsetjmp(context, Libc.TRUE);
1849 currentTryContext := S.ADR(context);
1850 IF res = 0 THEN (* first time around *)
1851 h(a, b, c);
1852 ELSIF res = trapReturn THEN (* after a trap *)
1853 ELSE
1854 HALT(100)
1855 END;
1856 currentTryContext := oldContext;
1857 END Try;
1859 (* -------------------- Initialization --------------------- *)
1861 PROCEDURE InitFpu; (* COMPILER DEPENDENT *)
1862 (* could be eliminated, delayed for backward compatibility *)
1863 VAR cw: SET;
1864 BEGIN
1865 FINIT;
1866 FSTCW;
1867 (* denorm, underflow, precision, zero div, overflow masked *)
1868 (* invalid trapped *)
1869 (* round to nearest, temp precision *)
1870 cw := cw - {0..5, 8..11} + {1, 2, 3, 4, 5, 8, 9};
1871 FLDCW
1872 END InitFpu;
1874 PROCEDURE [ccall] TrapHandler (sig: INTEGER; siginfo: Libc.Ptrsiginfo_t; context: Libc.Ptrucontext_t);
1875 BEGIN
1876 IF isReadableCheck THEN
1877 isReadableCheck := FALSE;
1878 Msg("~IsReadable");
1879 Libc.siglongjmp(isReadableContext, 1)
1880 END;
1882 (*
1883 S.GETREG(SP, sp);
1884 S.GETREG(FP, fp);
1885 *)
1886 stack := baseStack;
1888 sp := context.uc_mcontext.gregs[7]; (* TODO: is the stack pointer really stored in register 7? *)
1889 fp := context.uc_mcontext.gregs[6]; (* TODO: is the frame pointer really stored in register 6? *)
1890 pc := context.uc_mcontext.gregs[14]; (* TODO: is the pc really stored in register 14? *)
1891 val := siginfo.si_addr;
1893 (*
1894 Int(sig); Int(siginfo.si_signo); Int(siginfo.si_code); Int(siginfo.si_errno);
1895 Int(siginfo.si_status); Int(siginfo.si_value); Int(siginfo.si_int);
1896 *)
1897 err := sig;
1898 IF trapped THEN DefaultTrapViewer END;
1899 CASE sig OF
1900 Libc.SIGINT:
1901 err := 200 (* Interrupt (ANSI). *)
1902 | Libc.SIGILL: (* Illegal instruction (ANSI). *)
1903 err := 202; val := 0;
1904 IF IsReadable(pc, pc + 4) THEN
1905 S.GET(pc, val);
1906 IF val MOD 100H = 8DH THEN (* lea reg,reg *)
1907 IF val DIV 100H MOD 100H = 0F0H THEN
1908 err := val DIV 10000H MOD 100H (* trap *)
1909 ELSIF val DIV 1000H MOD 10H = 0EH THEN
1910 err := 128 + val DIV 100H MOD 10H (* run time error *)
1911 END
1912 END
1913 END
1914 | Libc.SIGFPE:
1915 CASE siginfo.si_code OF
1916 0: (* TODO: ?????? *)
1917 IF siginfo.si_int = 8 THEN
1918 err := 139
1919 ELSIF siginfo.si_int = 0 THEN
1920 err := 143
1921 END
1922 | Libc.FPE_INTDIV: err := 139 (* Integer divide by zero. *)
1923 | Libc.FPE_INTOVF: err := 138 (* Integer overflow. *)
1924 | Libc.FPE_FLTDIV: err := 140 (* Floating point divide by zero. *)
1925 | Libc.FPE_FLTOVF: err := 142 (* Floating point overflow. *)
1926 | Libc.FPE_FLTUND: err := 141 (* Floating point underflow. *)
1927 | Libc.FPE_FLTRES: err := 143 (* Floating point inexact result. *)
1928 | Libc.FPE_FLTINV: err := 143 (* Floating point invalid operation. *)
1929 | Libc.FPE_FLTSUB: err := 134 (* Subscript out of range. *)
1930 ELSE
1931 END
1932 | Libc.SIGSEGV: (* Segmentation violation (ANSI). *)
1933 err := 203
1934 ELSE
1935 END;
1936 INC(trapCount);
1937 InitFpu;
1938 TrapCleanup;
1939 IF err # 128 THEN
1940 IF (trapViewer = NIL) OR trapped THEN
1941 DefaultTrapViewer
1942 ELSE
1943 trapped := TRUE;
1944 trapViewer();
1945 trapped := FALSE
1946 END
1947 END;
1948 IF currentTryContext # NIL THEN (* Try failed *)
1949 Libc.siglongjmp(currentTryContext, trapReturn)
1950 ELSE
1951 IF restart # NIL THEN (* Start failed *)
1952 Libc.siglongjmp(loopContext, trapReturn)
1953 END;
1954 Quit(1); (* FIXME *)
1955 END;
1956 trapped := FALSE
1957 END TrapHandler;
1959 PROCEDURE InstallSignals*;
1960 VAR sa, old: Libc.sigaction_t; res, i: INTEGER;
1961 (*
1962 sigstk: Libc.stack_t;
1963 errno: INTEGER;
1964 *)
1965 BEGIN
1966 (*
1967 (* A. V. Shiryaev: Set alternative stack on which signals are to be processed *)
1968 sigstk.ss_sp := sigStack;
1969 sigstk.ss_size := sigStackSize;
1970 sigstk.ss_flags := 0;
1971 res := Libc.sigaltstack(sigstk, NIL);
1972 IF res # 0 THEN Msg("ERROR: Kernel.InstallSignals: sigaltstack failed!");
1973 S.GET( Libc.__errno_location(), errno );
1974 Int(errno);
1975 Libc.exit(1)
1976 END;
1977 *)
1979 sa.sa_sigaction := TrapHandler;
1980 (*
1981 res := LinLibc.sigemptyset(S.ADR(sa.sa_mask));
1982 *)
1983 res := Libc.sigfillset(S.ADR(sa.sa_mask));
1984 sa.sa_flags := (* Libc.SA_ONSTACK + *) Libc.SA_SIGINFO; (* TrapHandler takes three arguments *)
1985 (*
1986 IF LinLibc.sigaction(LinLibc.SIGINT, sa, old) # 0 THEN Msg("failed to install SIGINT") END;
1987 IF LinLibc.sigaction(LinLibc.SIGILL, sa, old) # 0 THEN Msg("failed to install SIGILL") END;
1988 IF LinLibc.sigaction(LinLibc.SIGFPE, sa, old) # 0 THEN Msg("failed to install SIGFPE") END;
1989 IF LinLibc.sigaction(LinLibc.SIGSEGV, sa, old) # 0 THEN Msg("failed to install SIGSEGV") END;
1990 IF LinLibc.sigaction(LinLibc.SIGPIPE, sa, old) # 0 THEN Msg("failed to install SIGPIPE") END;
1991 IF LinLibc.sigaction(LinLibc.SIGTERM, sa, old) # 0 THEN Msg("failed to install SIGTERM") END;
1992 *)
1993 (* respond to all possible signals *)
1994 FOR i := 1 TO Libc._NSIG - 1 DO
1995 IF (i # Libc.SIGKILL)
1996 & (i # Libc.SIGSTOP)
1997 & (i # Libc.SIGWINCH)
1998 THEN
1999 IF Libc.sigaction(i, sa, old) # 0 THEN (* Msg("failed to install signal"); Int(i) *) END;
2000 END
2001 END
2002 END InstallSignals;
2004 PROCEDURE Init;
2005 VAR i: INTEGER;
2006 BEGIN
2007 (*
2008 (* for sigaltstack *)
2009 sigStack := Libc.calloc(1, sigStackSize);
2010 IF sigStack = Libc.NULL THEN
2011 Msg("ERROR: Kernel.Init: calloc(1, sigStackSize) failed!");
2012 Libc.exit(1)
2013 END;
2014 *)
2015 (* for mmap *)
2016 zerofd := Libc.open("/dev/zero", Libc.O_RDWR, {0..8});
2017 IF zerofd < 0 THEN
2018 Msg("ERROR: Kernel.Init: can not open /dev/zero!");
2019 Libc.exit(1)
2020 END;
2021 (* for mprotect *)
2022 pageSize := Libc.sysconf(Libc._SC_PAGESIZE);
2023 IF pageSize < 0 THEN
2024 Msg("ERROR: Kernel.Init: pageSize < 0!");
2025 Libc.exit(1)
2026 END;
2028 isReadableCheck := FALSE;
2030 InstallSignals; (* init exception handling *)
2031 currentTryContext := NIL;
2033 allocated := 0; total := 0; used := 0;
2034 sentinelBlock.size := MAX(INTEGER);
2035 sentinel := S.ADR(sentinelBlock);
2037 (*
2038 S.PUTREG(ML, S.ADR(modList));
2039 *)
2041 i := N;
2042 REPEAT DEC(i); free[i] := sentinel UNTIL i = 0;
2044 IF inDll THEN
2045 (*
2046 baseStack := FPageWord(4); (* begin of stack segment *)
2047 *)
2048 END;
2049 InitFpu;
2050 IF ~static THEN
2051 InitModule(modList);
2052 IF ~inDll THEN Quit(1) END
2053 END;
2054 told := 0; shift := 0
2055 END Init;
2057 BEGIN
2058 IF modList = NIL THEN (* only once *)
2059 S.GETREG(SP, baseStack); (* TODO: Check that this is ok. *)
2060 IF bootInfo # NIL THEN
2061 modList := bootInfo.modList (* boot loader initializes the bootInfo struct *)
2062 ELSE
2063 S.GETREG(ML, modList) (* linker loads module list to BX *)
2064 END;
2065 static := init IN modList.opts;
2066 inDll := dll IN modList.opts;
2067 Init
2068 END
2069 CLOSE
2070 IF ~terminating THEN
2071 terminating := TRUE;
2072 Quit(0)
2073 END
2074 END Kernel.