MODULE Linker0;
IMPORT SYSTEM, Streams, Files, KernelLog;
CONST
DefaultExtension = ".Obx";
HeapSize = 630*1024;
AddressSize = SYSTEM.SIZEOF (SYSTEM.ADDRESS);
LenOfs = 3 * AddressSize;
Unmarked = 0;
MemBlockDescModule = "Machine"; MemBlockDescType = "MemoryBlockDesc";
ModDescModule = "Modules"; ModDescType = "Module";
TypeDescModule = "Modules"; TypeDescType = "TypeDesc";
HdPtrDescModule = "Loader"; HdPtrDescType = "@HdPtrDesc";
ExportDescModule = "Modules"; ExportDescType = "ExportDesc";
InitPtrModule = "Modules"; InitPtrName = "initBlock";
ModRootModule = "Modules"; ModRootName = "root";
ProcOffsetsName = "procOffsets"; NumProcsName = "numProcs";
PtrOffsetsName = "ptrOffsets"; NumPtrsName = "numPtrs";
HeapModule = "Heaps";
FreeBlockDescType = "FreeBlockDesc"; SystemBlockDescType = "SystemBlockDesc"; RecordBlockDescType = "RecordBlockDesc";
ProtRecBlockDescType = "ProtRecBlockDesc"; ArrayBlockDescType = "ArrayBlockDesc";
FreeBlockTagPtrName = "freeBlockTagPtr"; SystemBlockTagPtrName = "systemBlockTagPtr"; RecordBlockTagPtrName = "recordBlockTagPtr";
ProtRecBlockTagPtrName = "protRecBlockTagPtr"; ArrayBlockTagPtrName = "arrayBlockTagPtr";
CurrentMarkValueName = "currentMarkValue";
StartModule = "Objects"; StartCommand = "Terminate";
MainModule = "BootConsole";
FreeBlockId = 0;
SystemBlockId = 1;
RecordBlockId = 2;
ProtRecBlockId = 3;
ArrayBlockId = 4;
ProtectedModule = TRUE;
TraceDump = FALSE;
TraceRefs = TRUE & TraceDump;
TraceDuplicates = FALSE & TraceDump;
LogName = "Linker.Log";
HeaderSize = 40H;
EndBlockOfs = 38H;
NumPriorities* = 6;
TYPE
AdrTable = POINTER TO ARRAY OF SYSTEM.ADDRESS;
CONST
MaxTags* = 16;
Tag0Ofs* = -2 * AddressSize;
Mth0Ofs* = Tag0Ofs - AddressSize * MaxTags;
Ptr0Ofs* = AddressSize;
ProtTypeBit* = 31;
BlockSize = 32;
ArrayAlignment = 8;
BlockHeaderSize = 2 * AddressSize;
HeapBlockOffset = - 2 * AddressSize;
TypeDescOffset = - AddressSize;
MinPtrOfs = -40000000H;
MethodEndMarker* = MinPtrOfs;
InitTableLen = 1024 + 256;
InitPtrTableLen = 2048;
TypeDescRecSize* = 5 * AddressSize + 32;
NilVal* = 0;
TYPE
RootObject* = OBJECT
VAR nextRoot: RootObject;
PROCEDURE FindRoots*;
BEGIN
HALT(30101)
END FindRoots;
END RootObject;
ProcessLink* = OBJECT (RootObject)
VAR next*, prev*: ProcessLink
END ProcessLink;
ProcessQueue* = RECORD
head*, tail*: ProcessLink
END;
MemoryBlock = POINTER TO MemoryBlockDesc;
MemoryBlockDesc = RECORD
next {UNTRACED}: MemoryBlock;
startAdr: SYSTEM.ADDRESS;
size: SYSTEM.SIZE;
beginBlockAdr, endBlockAdr: SYSTEM.ADDRESS
END;
HeapBlock = POINTER TO HeapBlockDesc;
HeapBlockDesc = RECORD
mark: LONGINT;
dataAdr: SYSTEM.ADDRESS;
size: SYSTEM.SIZE;
nextRealtime: HeapBlock;
END;
FreeBlock = POINTER TO FreeBlockDesc;
FreeBlockDesc = RECORD (HeapBlockDesc)
END;
SystemBlock = POINTER TO SystemBlockDesc;
SystemBlockDesc = RECORD (HeapBlockDesc)
END;
RecordBlock = POINTER TO RecordBlockDesc;
RecordBlockDesc = RECORD (HeapBlockDesc)
END;
ProtRecBlock* = POINTER TO ProtRecBlockDesc;
ProtRecBlockDesc* = RECORD (RecordBlockDesc)
count*: LONGINT;
locked*: BOOLEAN;
awaitingLock*: ProcessQueue;
awaitingCond*: ProcessQueue;
lockedBy*: ANY;
lock*: ANY;
waitingPriorities*: ARRAY NumPriorities OF LONGINT;
END;
ArrayBlock = POINTER TO ArrayBlockDesc;
ArrayBlockDesc = RECORD (HeapBlockDesc)
END;
StaticTypeBlock*= POINTER TO StaticTypeDesc;
StaticTypeDesc* = RECORD
recSize: SYSTEM.SIZE;
pointerOffsets* {UNTRACED}: PointerOffsets;
END;
PointerOffsets = POINTER TO ARRAY OF SYSTEM.SIZE;
TYPE
Name* = ARRAY 32 OF CHAR;
CommandProc* = PROCEDURE;
CommandParProc* = PROCEDURE(par: ANY): ANY;
Command* = RECORD
name*: Name;
argTdAdr*, retTdAdr* : SYSTEM.ADDRESS;
entryAdr* : SYSTEM.ADDRESS;
END;
ExportDesc* = RECORD
fp*: SYSTEM.ADDRESS;
adr*: SYSTEM.ADDRESS;
exports*: LONGINT;
dsc*: ExportArray
END;
ExportArray* = POINTER TO ARRAY OF ExportDesc;
Bytes* = POINTER TO ARRAY OF CHAR;
TerminationHandler* = PROCEDURE;
ExceptionTableEntry* = RECORD
pcFrom*: SYSTEM.ADDRESS;
pcTo*: SYSTEM.ADDRESS;
pcHandler*: SYSTEM.ADDRESS;
END;
ExceptionTable* = POINTER TO ARRAY OF ExceptionTableEntry;
ProcTableEntry* = RECORD
pcFrom*, pcLimit*, pcStatementBegin*, pcStatementEnd*: SYSTEM.ADDRESS;
noPtr*: LONGINT;
END;
ProcTable* = POINTER TO ARRAY OF ProcTableEntry;
PtrTable* = POINTER TO ARRAY OF SYSTEM.SIZE;
ProcOffsetEntry* = RECORD
data*: ProcTableEntry;
startIndex: LONGINT;
END;
ProcOffsetTable* = POINTER TO ARRAY OF ProcOffsetEntry;
Module* = OBJECT (RootObject)
VAR
next*: Module;
name*: Name;
init, published: BOOLEAN;
refcnt*: LONGINT;
sb*: SYSTEM.ADDRESS;
entry*: POINTER TO ARRAY OF SYSTEM.ADDRESS;
command*: POINTER TO ARRAY OF Command;
ptrAdr*: POINTER TO ARRAY OF SYSTEM.ADDRESS;
typeInfo*: POINTER TO ARRAY OF TypeDesc;
module*: POINTER TO ARRAY OF Module;
procTable*: ProcTable;
ptrTable*: PtrTable;
data*, code*, staticTypeDescs* , refs*: Bytes;
export*: ExportDesc;
term*: TerminationHandler;
exTable*: ExceptionTable;
noProcs*: LONGINT;
firstProc*: SYSTEM.ADDRESS;
maxPtrs*: LONGINT;
END Module;
TypeDesc* = POINTER TO RECORD
descSize: LONGINT;
sentinel: LONGINT;
tag*: SYSTEM.ADDRESS;
flags*: SET;
mod*: Module;
name*: Name;
END;
VAR
logWriter: Streams.Writer; logFile: Files.File;
root-: SYSTEM.ADDRESS;
procOffsets {UNTRACED}: ProcOffsetTable;
numProcs: LONGINT;
ptrOffsets {UNTRACED}: PtrTable;
numPtrs: LONGINT;
heap: ANY;
memBlock {UNTRACED}: MemoryBlock;
beginMemBlockAdr, endMemBlockAdr: SYSTEM.ADDRESS;
beginAdr, freeAdr, baseAdr : SYSTEM.ADDRESS;
heapOfs: SYSTEM.SIZE;
exportTags, relocates: LONGINT;
exportTagAdr: AdrTable;
relocateAdr: AdrTable;
curRelocate: LONGINT;
refsMissed: LONGINT;
prefix,suffix: Files.FileName;
loadObj*: PROCEDURE (name, fileName: ARRAY OF CHAR; VAR res: LONGINT;
VAR msg: ARRAY OF CHAR): Module;
getProcs: ARRAY 9 OF BOOLEAN;
freeBlockTag, systemBlockTag, recordBlockTag, protRecBlockTag, arrayBlockTag: SYSTEM.ADDRESS;
initBlock {UNTRACED}: ANY;
currentMarkValue: LONGINT;
PROCEDURE Fill4 (destAdr: SYSTEM.ADDRESS; size: SYSTEM.SIZE; filler: LONGINT);
BEGIN
WHILE size > 0 DO
SYSTEM.PUT (destAdr, filler);
INC (destAdr, SYSTEM.SIZEOF(LONGINT));
DEC (size);
END;
END Fill4;
PROCEDURE Char*(c: CHAR);
BEGIN
logWriter.Char(c);
END Char;
PROCEDURE String*(CONST s: ARRAY OF CHAR);
BEGIN
logWriter.String(s);
END String;
PROCEDURE Ln*;
BEGIN
logWriter.Ln();
END Ln;
PROCEDURE Int*(x, w: LONGINT);
BEGIN
logWriter.Int(x,w);
END Int;
PROCEDURE Hex*(x, w: LONGINT);
BEGIN
logWriter.Hex(x,w);
END Hex;
PROCEDURE Address*(x: SYSTEM.ADDRESS);
BEGIN
logWriter.Address(x);
END Address;
PROCEDURE Memory*(adr, size: LONGINT);
VAR i, j, t: LONGINT; buf: ARRAY 4 OF CHAR; reset, missed: BOOLEAN;
BEGIN
buf[1] := 0X; size := adr+size-1;
reset := FALSE;
FOR i := adr TO size BY 16 DO
Hex(i, 9); missed := FALSE;
FOR j := i TO i+15 DO
IF j <= size THEN
IF curRelocate >= 0 THEN
IF (j >= relocateAdr[curRelocate]) & (j <= relocateAdr[curRelocate]+3) THEN
reset := TRUE
ELSIF j = relocateAdr[curRelocate]+4 THEN
INC(curRelocate);
IF curRelocate # relocates THEN
IF j = relocateAdr[curRelocate] THEN
reset := TRUE
ELSIF TraceDuplicates & (j = relocateAdr[curRelocate]+4) THEN
reset := TRUE;
REPEAT
INC(curRelocate)
UNTIL (curRelocate = relocates) OR (j # relocateAdr[curRelocate]+4)
END
ELSE
curRelocate := -1
END
ELSIF TraceRefs THEN
IF j <= adr+size-4 THEN
SYSTEM.GET(j, t);
IF (t > beginMemBlockAdr) & (t < freeAdr) THEN
INC(refsMissed); missed := TRUE;
reset := TRUE
END
END
END
END;
SYSTEM.GET(j, buf[0]);
Hex(SYSTEM.VAL(SHORTINT, buf[0]), -3);
ELSE
buf := " "; String(buf); buf[1] := 0X
END
END;
buf[0] := " "; String(buf);
FOR j := i TO i+15 DO
IF j <= size THEN
SYSTEM.GET(j, buf[0]);
IF (buf[0] < " ") OR (buf[0] >= CHR(127)) THEN
buf[0] := "."
END;
String(buf)
END
END;
IF missed THEN String(" <--missed?") END;
Ln
END;
END Memory;
PROCEDURE Bits*(x: SET; ofs, n: LONGINT);
BEGIN
REPEAT
DEC(n);
IF (ofs+n) IN x THEN Char("1") ELSE Char("0") END
UNTIL n = 0
END Bits;
PROCEDURE Enter*;
BEGIN
Char("{")
END Enter;
PROCEDURE Exit*;
BEGIN
Char("}"); Ln
END Exit;
PROCEDURE InitFreeBlock(freeBlock: FreeBlock; mark: LONGINT; dataAdr: SYSTEM.ADDRESS; size: SYSTEM.SIZE);
VAR freeBlockAdr: SYSTEM.ADDRESS;
BEGIN
freeBlock.mark := mark;
freeBlock.dataAdr := dataAdr;
freeBlock.size := size;
freeBlock.nextRealtime := NIL;
freeBlockAdr := SYSTEM.VAL(SYSTEM.ADDRESS, freeBlock);
SYSTEM.PUT(freeBlockAdr + TypeDescOffset, FreeBlockId);
SYSTEM.PUT(freeBlockAdr + HeapBlockOffset, NilVal)
END InitFreeBlock;
PROCEDURE NewBlock(size: SYSTEM.SIZE): SYSTEM.ADDRESS;
VAR p, freeBlockAdr: SYSTEM.ADDRESS; freeBlock: FreeBlock; blockSize: SYSTEM.SIZE;
BEGIN
ASSERT(size MOD BlockSize = 0);
freeBlock := SYSTEM.VAL(FreeBlock, freeAdr + BlockHeaderSize);
blockSize := freeBlock.size;
p := freeAdr; INC(freeAdr, size);
ASSERT(freeAdr + BlockHeaderSize + SYSTEM.SIZEOF(FreeBlockDesc) <= memBlock.endBlockAdr);
freeBlockAdr := freeAdr + BlockHeaderSize;
freeBlock := SYSTEM.VAL(FreeBlock, freeBlockAdr);
InitFreeBlock(freeBlock, Unmarked, NilVal, blockSize - size);
RETURN p
END NewBlock;
PROCEDURE NewSys*(VAR p: ANY; size: SYSTEM.SIZE);
VAR systemBlockSize, blockSize: SYSTEM.SIZE; systemBlockAdr, dataBlockAdr: SYSTEM.ADDRESS;
systemBlock: SystemBlock;
BEGIN
ASSERT((BlockHeaderSize MOD ArrayAlignment = 0));
systemBlockSize := BlockHeaderSize + SYSTEM.SIZEOF(SystemBlockDesc);
systemBlockSize := ((systemBlockSize + ArrayAlignment - 1) DIV ArrayAlignment) * ArrayAlignment;
blockSize := systemBlockSize + BlockHeaderSize + size;
INC(blockSize,(-blockSize) MOD BlockSize);
systemBlockAdr := NewBlock(blockSize) + BlockHeaderSize;
SYSTEM.PUT(systemBlockAdr + TypeDescOffset, SystemBlockId);
SYSTEM.PUT(systemBlockAdr + HeapBlockOffset, NilVal);
dataBlockAdr := systemBlockAdr + systemBlockSize ;
SYSTEM.PUT(dataBlockAdr + TypeDescOffset, NilVal);
SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, systemBlockAdr);
Relocate(dataBlockAdr + HeapBlockOffset);
systemBlock := SYSTEM.VAL(SystemBlock, systemBlockAdr);
systemBlock.mark := currentMarkValue;
systemBlock.dataAdr := dataBlockAdr;
systemBlock.nextRealtime := NIL;
Relocate(SYSTEM.ADR(systemBlock.dataAdr));
Relocate(SYSTEM.ADR(systemBlock.nextRealtime));
systemBlock.size := blockSize;
p := SYSTEM.VAL(ANY, dataBlockAdr);
Fill4(dataBlockAdr, (blockSize - systemBlockSize - BlockHeaderSize) DIV 4, 0);
END NewSys;
PROCEDURE NewRealArr*(VAR p: ANY; numElems, elemSize: SYSTEM.SIZE; numDims: LONGINT);
VAR arrayBlockAdr, dataBlockAdr, firstElem, elemTag: SYSTEM.ADDRESS; arrSize, arrayBlockSize, blockSize, fillSize: SYSTEM.SIZE;
arrayBlock: ArrayBlock;
arrayDataOffset: SYSTEM.SIZE;
BEGIN
elemTag := 0;
arrSize := numElems * elemSize;
ASSERT(arrSize > 0);
ASSERT((BlockHeaderSize MOD ArrayAlignment = 0));
arrayDataOffset := numDims * AddressSize + 3 * AddressSize;
INC(arrayDataOffset, (-arrayDataOffset) MOD ArrayAlignment);
arrayBlockSize := BlockHeaderSize + SYSTEM.SIZEOF(ArrayBlockDesc);
INC(arrayBlockSize,(-arrayBlockSize) MOD ArrayAlignment);
blockSize := arrayBlockSize + BlockHeaderSize + (arrayDataOffset + arrSize);
INC(blockSize,(-blockSize) MOD BlockSize);
arrayBlockAdr := NewBlock(blockSize) + BlockHeaderSize;
SYSTEM.PUT(arrayBlockAdr + TypeDescOffset, ArrayBlockId);
SYSTEM.PUT(arrayBlockAdr + HeapBlockOffset, NilVal);
dataBlockAdr := arrayBlockAdr + arrayBlockSize ;
SYSTEM.PUT(dataBlockAdr + TypeDescOffset, elemTag);
SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, arrayBlockAdr);
Relocate(dataBlockAdr + HeapBlockOffset);
arrayBlock := SYSTEM.VAL(ArrayBlock, arrayBlockAdr);
arrayBlock.mark := currentMarkValue;
arrayBlock.dataAdr := dataBlockAdr;
arrayBlock.nextRealtime := NIL;
Relocate(SYSTEM.ADR(arrayBlock.dataAdr));
Relocate(SYSTEM.ADR(arrayBlock.nextRealtime));
arrayBlock.size := blockSize;
fillSize := blockSize - arrayBlockSize - BlockHeaderSize;
ASSERT(fillSize MOD 4 = 0);
Fill4(dataBlockAdr, fillSize DIV 4, 0);
firstElem := dataBlockAdr + arrayDataOffset;
SYSTEM.PUT(dataBlockAdr, firstElem + arrSize - elemSize);
Relocate(dataBlockAdr);
SYSTEM.PUT(dataBlockAdr + AddressSize, NIL);
SYSTEM.PUT(dataBlockAdr + 2 * AddressSize, firstElem);
Relocate(dataBlockAdr + 2 * AddressSize);
p := SYSTEM.VAL(ANY, dataBlockAdr);
END NewRealArr;
PROCEDURE NewTypeDesc*(VAR p: ANY; recSize: SYSTEM.SIZE);
VAR blockSize: SYSTEM.SIZE; recordBlockAdr, dataBlockAdr: SYSTEM.ADDRESS;
recordBlock: RecordBlock;
BEGIN
blockSize := BlockHeaderSize + SYSTEM.SIZEOF(RecordBlockDesc) + BlockHeaderSize + recSize;
INC(blockSize, (-blockSize) MOD BlockSize);
recordBlockAdr := NewBlock(blockSize) + BlockHeaderSize;
SYSTEM.PUT(recordBlockAdr + TypeDescOffset, RecordBlockId);
SYSTEM.PUT(recordBlockAdr + HeapBlockOffset, NilVal);
dataBlockAdr := recordBlockAdr + SYSTEM.SIZEOF(RecordBlockDesc) + BlockHeaderSize;
SYSTEM.PUT(dataBlockAdr + TypeDescOffset, NilVal);
SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, recordBlockAdr);
Relocate(dataBlockAdr + HeapBlockOffset);
recordBlock := SYSTEM.VAL(RecordBlock, recordBlockAdr);
recordBlock.mark := currentMarkValue;
recordBlock.dataAdr := dataBlockAdr;
recordBlock.nextRealtime := NIL;
Relocate(SYSTEM.ADR(recordBlock.dataAdr));
Relocate(SYSTEM.ADR(recordBlock.nextRealtime));
recordBlock.size := blockSize;
p := SYSTEM.VAL(ANY, dataBlockAdr);
Fill4(dataBlockAdr, (blockSize - SYSTEM.SIZEOF(RecordBlockDesc) - 2 * BlockHeaderSize) DIV 4, 0);
END NewTypeDesc;
PROCEDURE FillStaticType*(VAR staticTypeAddr: SYSTEM.ADDRESS; startAddr, typeInfoAdr: SYSTEM.ADDRESS; size, recSize: SYSTEM.SIZE;
numPtrs, numSlots: LONGINT);
VAR p, offset: SYSTEM.ADDRESS; staticTypeBlock {UNTRACED}: StaticTypeBlock;
BEGIN
Fill4(startAddr, size DIV 4, 0);
SYSTEM.PUT(startAddr, MethodEndMarker);
offset := AddressSize * (numSlots + 1 + 1);
p := startAddr + offset;
SYSTEM.PUT(p + TypeDescOffset, typeInfoAdr);
Relocate(p + TypeDescOffset);
staticTypeBlock := SYSTEM.VAL(StaticTypeBlock, p);
staticTypeBlock.recSize := recSize;
staticTypeAddr := p;
INC(p, SYSTEM.SIZEOF(StaticTypeDesc));
IF p MOD (2 * AddressSize) # 0 THEN INC(p, AddressSize) END;
ASSERT(p MOD (2 * AddressSize) = 0);
SYSTEM.PUT(p + 3 * AddressSize, numPtrs);
staticTypeBlock.pointerOffsets := SYSTEM.VAL(PointerOffsets, p);
Relocate(SYSTEM.ADR(staticTypeBlock.pointerOffsets));
END FillStaticType;
PROCEDURE Append*(CONST from: ARRAY OF CHAR; VAR to: ARRAY OF CHAR);
VAR i, j, m: LONGINT;
BEGIN
j := 0; WHILE to[j] # 0X DO INC(j) END;
m := LEN(to)-1;
i := 0; WHILE (from[i] # 0X) & (j # m) DO to[j] := from[i]; INC(i); INC(j) END;
to[j] := 0X
END Append;
PROCEDURE Publish(VAR m: Module; VAR new: BOOLEAN);
VAR n: Module; i: LONGINT;
BEGIN
n := SYSTEM.VAL(Module, root);
WHILE (n # NIL) & (n.name # m.name) DO n := n.next END;
IF n # NIL THEN
m := n; new := FALSE
ELSE
m.published := TRUE;
m.next := SYSTEM.VAL(Module, root);
root := SYSTEM.VAL(SYSTEM.ADDRESS, m);
m.refcnt := 0;
FOR i := 0 TO LEN(m.module)-1 DO INC(m.module[i].refcnt) END;
new := TRUE
END
END Publish;
PROCEDURE ModuleByName(CONST name: ARRAY OF CHAR): Module;
VAR m: Module;
BEGIN
m := SYSTEM.VAL(Module, root);
WHILE (m # NIL) & (m.name # name) DO m := m.next END;
RETURN m
END ModuleByName;
PROCEDURE GetFileName(CONST name: ARRAY OF CHAR; VAR fileName: ARRAY OF CHAR);
VAR i, j: LONGINT;
BEGIN
i := 0; WHILE prefix[i] # 0X DO fileName[i] := prefix[i]; INC(i) END;
j := 0; WHILE name[j] # 0X DO fileName[i] := name[j]; INC(i); INC(j) END;
j := 0; WHILE suffix[j] # 0X DO fileName[i] := suffix[j]; INC(i); INC(j) END;
fileName[i] := 0X
END GetFileName;
PROCEDURE ThisModule*(CONST name: ARRAY OF CHAR; VAR res: LONGINT; VAR msg: ARRAY OF CHAR): Module;
VAR m, p: Module; fileName: ARRAY 64 OF CHAR; new: BOOLEAN;
BEGIN
res := 0; msg[0] := 0X; m := ModuleByName(name);
IF m = NIL THEN
GetFileName(name, fileName);
m := loadObj(name, fileName, res, msg);
IF (m # NIL) & ~m.published THEN
p := m; Publish(m, new);
IF new THEN
m.init := TRUE
ELSE
HALT(99)
END
END
END;
RETURN m
END ThisModule;
PROCEDURE ThisType*(m: Module; CONST name: ARRAY OF CHAR): TypeDesc;
VAR i: LONGINT; type: TypeDesc;
BEGIN
i := 0;
WHILE (i < LEN(m.typeInfo)) & (m.typeInfo[i].name # name) DO INC(i) END;
IF i = LEN(m.typeInfo) THEN
type := NIL
ELSE
type := m.typeInfo[i]
END;
RETURN type
END ThisType;
PROCEDURE WriteType(t: SYSTEM.ADDRESS);
VAR typeDesc: TypeDesc;
BEGIN
IF t # NilVal THEN
SYSTEM.GET (t + TypeDescOffset, typeDesc);
IF typeDesc.mod # NIL THEN
String(typeDesc.mod.name)
ELSE
String("NIL");
END;
Char(".");
String(typeDesc.name)
ELSE
String("no type")
END
END WriteType;
PROCEDURE FindInsertionPos(VAR entry: ProcTableEntry; VAR pos: LONGINT): BOOLEAN;
VAR l, r, x: LONGINT; success, isHit: BOOLEAN;
BEGIN
pos := -1;
success := FALSE;
IF numProcs = 0 THEN
pos := 0; success := TRUE
ELSE
l := 0; r := numProcs - 1;
REPEAT
x := (l + r) DIV 2;
IF entry.pcLimit < procOffsets[x].data.pcFrom THEN r := x - 1 ELSE l := x + 1 END;
isHit := ((x = 0) OR (procOffsets[x - 1].data.pcLimit < entry.pcFrom)) & (entry.pcLimit < procOffsets[x].data.pcFrom);
UNTIL isHit OR (l > r);
IF isHit THEN
pos := x; success := TRUE
ELSE
IF (x = numProcs - 1) & (procOffsets[x].data.pcLimit < entry.pcFrom) THEN
pos := x + 1; success := TRUE
END
END
END;
RETURN success
END FindInsertionPos;
PROCEDURE NumTotalPtrs(procTable: ProcTable): LONGINT;
VAR i, num: LONGINT;
BEGIN
num := 0;
FOR i := 0 TO LEN(procTable) - 1 DO
num := num + procTable[i].noPtr
END;
RETURN num
END NumTotalPtrs;
PROCEDURE InsertProcOffsets*(procTable: ProcTable; ptrTable: PtrTable; maxPtr: LONGINT);
VAR success: BOOLEAN; i, j, pos, poslast, num: LONGINT;
BEGIN
IF LEN(procTable) > 0 THEN
ASSERT(numProcs + LEN(procTable) <= LEN(procOffsets));
num := NumTotalPtrs(procTable);
ASSERT(numPtrs + num <= LEN(ptrOffsets));
success := FindInsertionPos(procTable[0], pos); success := success & FindInsertionPos(procTable[LEN(procTable) - 1], poslast);
ASSERT(success & (pos = poslast));
FOR i := numProcs - 1 TO pos BY -1 DO procOffsets[i + LEN(procTable)] := procOffsets[i] END;
FOR i := 0 TO LEN(procTable) - 1 DO
procOffsets[pos + i].data := procTable[i];
procOffsets[pos + i].startIndex := numPtrs;
FOR j := 0 TO procTable[i].noPtr - 1 DO
ptrOffsets[numPtrs + j] := ptrTable[i * maxPtr + j]
END;
numPtrs := numPtrs + procTable[i].noPtr;
END;
numProcs := numProcs + LEN(procTable)
END
END InsertProcOffsets;
PROCEDURE GrowTable(VAR table: AdrTable);
VAR new: AdrTable; i: LONGINT;
BEGIN
NEW(new, 2*LEN(table));
FOR i := 0 TO LEN(table)-1 DO new[i] := table[i] END;
table := new
END GrowTable;
PROCEDURE Relocate*(adr: SYSTEM.ADDRESS);
BEGIN
IF relocates = LEN(relocateAdr) THEN GrowTable(relocateAdr) END;
relocateAdr[relocates] := adr; INC(relocates);
SYSTEM.GET(adr, adr);
ASSERT((adr = 0) OR (adr > beginMemBlockAdr) & (adr <= freeAdr))
END Relocate;
PROCEDURE Open*(CONST namePrefix,nameSuffix: ARRAY OF CHAR; base: SYSTEM.ADDRESS; log: Streams.Writer);
VAR i: LONGINT; w: Files.Writer;
BEGIN
COPY(namePrefix, prefix);
IF nameSuffix = "" THEN
suffix := DefaultExtension
ELSE
COPY(nameSuffix, suffix)
END;
baseAdr := base;
InitHeap;
root := 0;
freeAdr := memBlock.beginBlockAdr;
heapOfs := baseAdr - beginAdr;
exportTags := 0; relocates := 0; refsMissed := 0;
curRelocate := -1;
IF log # NIL THEN logWriter := log; logFile := NIL ELSE logFile := Files.New(LogName); NEW(w, logFile,0); logWriter := w END;
FOR i := 0 TO LEN(getProcs) - 1 DO getProcs[i] := FALSE END;
NewProcOffsets(procOffsets, InitTableLen);
numProcs := 0;
NewPtrOffsets(ptrOffsets, InitPtrTableLen);
numPtrs := 0;
END Open;
PROCEDURE RelocateModules;
VAR adr: SYSTEM.ADDRESS; i: LONGINT; type, hdPtrDescType: TypeDesc; m: Module;
BEGIN
type := ThisType(ModuleByName(ModDescModule), ModDescType);
hdPtrDescType := ThisType(ModuleByName(HdPtrDescModule), HdPtrDescType);
ASSERT((type # NIL) & (hdPtrDescType # NIL));
IF ProtectedModule THEN
INCL(type.flags, ProtTypeBit)
END;
m := SYSTEM.VAL(Module, root);
WHILE m # NIL DO
adr := SYSTEM.VAL(SYSTEM.ADDRESS, m);
SYSTEM.PUT(adr + TypeDescOffset, type.tag); Relocate(adr + TypeDescOffset);
IF LEN(m.typeInfo) > 0 THEN
adr := SYSTEM.VAL(SYSTEM.ADDRESS, m.typeInfo);
SYSTEM.PUT(adr + TypeDescOffset, hdPtrDescType.tag);
Relocate(adr + TypeDescOffset)
END;
IF LEN(m.module) > 0 THEN
adr := SYSTEM.VAL(SYSTEM.ADDRESS, m.module);
SYSTEM.PUT(adr + TypeDescOffset, hdPtrDescType.tag);
Relocate(adr + TypeDescOffset)
END;
Relocate(SYSTEM.ADR(m.next));
Relocate(m.sb);
Relocate(SYSTEM.ADR(m.sb));
FOR i := 0 TO LEN(m.entry)-1 DO Relocate(SYSTEM.ADR(m.entry[i])) END;
Relocate(SYSTEM.ADR(m.entry));
FOR i := 0 TO LEN(m.command)-1 DO
Relocate(SYSTEM.ADR(m.command[i].entryAdr));
IF (m.command[i].argTdAdr > 1) THEN Relocate(SYSTEM.ADR(m.command[i].argTdAdr)); END;
IF (m.command[i].retTdAdr > 1) THEN Relocate(SYSTEM.ADR(m.command[i].retTdAdr)); END;
END;
Relocate(SYSTEM.ADR(m.command));
FOR i := 0 TO LEN(m.ptrAdr)-1 DO Relocate(SYSTEM.ADR(m.ptrAdr[i])) END;
Relocate(SYSTEM.ADR(m.ptrAdr));
FOR i := 0 TO LEN(m.typeInfo) - 1 DO
Relocate(SYSTEM.ADR(m.typeInfo[i]));
Relocate(SYSTEM.ADR(m.typeInfo[i].tag));
Relocate(SYSTEM.ADR(m.typeInfo[i].mod))
END;
Relocate(SYSTEM.ADR(m.typeInfo));
FOR i := 0 TO LEN(m.module)-1 DO Relocate(SYSTEM.ADR(m.module[i])) END;
Relocate(SYSTEM.ADR(m.module));
Relocate(SYSTEM.ADR(m.data));
Relocate(SYSTEM.ADR(m.code));
Relocate(SYSTEM.ADR(m.staticTypeDescs));
Relocate(SYSTEM.ADR(m.refs));
FOR i := 0 TO LEN(m.exTable)-1 DO
Relocate(SYSTEM.ADR(m.exTable[i].pcFrom));
Relocate(SYSTEM.ADR(m.exTable[i].pcTo));
Relocate(SYSTEM.ADR(m.exTable[i].pcHandler))
END;
Relocate(SYSTEM.ADR(m.exTable));
Relocate(SYSTEM.ADR(m.firstProc));
Relocate(SYSTEM.ADR(m.export.dsc));
m := m.next
END
END RelocateModules;
PROCEDURE RelocateArrayFields(tagAdr: SYSTEM.ADDRESS);
VAR adr, p, lastElem: SYSTEM.ADDRESS; staticTypeBlock {UNTRACED}: StaticTypeBlock; i: LONGINT;
BEGIN
SYSTEM.GET(tagAdr + AddressSize, lastElem);
SYSTEM.GET(tagAdr + 3 * AddressSize, p);
SYSTEM.GET(tagAdr, adr);
staticTypeBlock := SYSTEM.VAL(StaticTypeBlock, adr);
LOOP
FOR i := 0 TO LEN(staticTypeBlock.pointerOffsets) - 1 DO
Relocate(p + staticTypeBlock.pointerOffsets[i]);
END;
IF p = lastElem THEN EXIT END;
INC(p, staticTypeBlock.recSize)
END
END RelocateArrayFields;
PROCEDURE RelocateExports;
VAR type: TypeDesc; i: LONGINT;
BEGIN
type := ThisType(ModuleByName(ExportDescModule), ExportDescType);
ASSERT(type # NIL);
FOR i := 0 TO exportTags - 1 DO
SYSTEM.PUT(exportTagAdr[i], type.tag);
Relocate(exportTagAdr[i]);
RelocateArrayFields(exportTagAdr[i]);
END
END RelocateExports;
PROCEDURE RelocateProcOffsets;
VAR i: LONGINT;
BEGIN
FOR i := 0 TO numProcs - 1 DO
Relocate(SYSTEM.ADR(procOffsets[i].data.pcFrom));
Relocate(SYSTEM.ADR(procOffsets[i].data.pcLimit));
Relocate(SYSTEM.ADR(procOffsets[i].data.pcStatementBegin));
Relocate(SYSTEM.ADR(procOffsets[i].data.pcStatementEnd));
END;
END RelocateProcOffsets;
PROCEDURE FixupTypeDescTags;
VAR type: TypeDesc; i: LONGINT; m: Module; adr: SYSTEM.ADDRESS;
BEGIN
type := ThisType(ModuleByName(TypeDescModule), TypeDescType);
ASSERT(type # NIL);
m := SYSTEM.VAL(Module, root);
WHILE m # NIL DO
FOR i := 0 TO LEN(m.typeInfo) - 1 DO
adr := SYSTEM.VAL(SYSTEM.ADDRESS, m.typeInfo[i]);
SYSTEM.PUT(adr + TypeDescOffset, type.tag);
Relocate(adr + TypeDescOffset);
END;
m := m.next
END
END FixupTypeDescTags;
PROCEDURE FixupHeapBlockTags;
VAR type: TypeDesc; m: Module; heapBlock {UNTRACED}: HeapBlock; adr, heapBlockAdr: SYSTEM.ADDRESS; val: LONGINT;
BEGIN
m := ModuleByName(HeapModule); ASSERT(m # NIL);
type := ThisType(m, FreeBlockDescType); ASSERT(type # NIL); freeBlockTag := type.tag;
type := ThisType(m, SystemBlockDescType); ASSERT(type # NIL); systemBlockTag := type.tag;
type := ThisType(m, RecordBlockDescType); ASSERT(type # NIL); recordBlockTag := type.tag;
type := ThisType(m, ProtRecBlockDescType); ASSERT(type # NIL); protRecBlockTag := type.tag;
type := ThisType(m, ArrayBlockDescType); ASSERT(type # NIL); arrayBlockTag := type.tag;
adr := beginMemBlockAdr;
WHILE adr < endMemBlockAdr DO
heapBlockAdr := adr + BlockHeaderSize;
SYSTEM.GET(heapBlockAdr + TypeDescOffset, val);
CASE val OF
FreeBlockId: SYSTEM.PUT(heapBlockAdr + TypeDescOffset, freeBlockTag);
| SystemBlockId: SYSTEM.PUT(heapBlockAdr + TypeDescOffset, systemBlockTag);
| RecordBlockId: SYSTEM.PUT(heapBlockAdr + TypeDescOffset, recordBlockTag);
| ProtRecBlockId: SYSTEM.PUT(heapBlockAdr + TypeDescOffset, protRecBlockTag);
| ArrayBlockId: SYSTEM.PUT(heapBlockAdr + TypeDescOffset, arrayBlockTag);
END;
Relocate(heapBlockAdr + TypeDescOffset);
heapBlock := SYSTEM.VAL(HeapBlock, heapBlockAdr);
adr := adr + heapBlock.size
END;
END FixupHeapBlockTags;
PROCEDURE SortRelocates;
VAR h, i, j: LONGINT; p: SYSTEM.ADDRESS;
BEGIN
h := 1; REPEAT h := h*3 + 1 UNTIL h > relocates;
REPEAT
h := h DIV 3; i := h;
WHILE i < relocates DO
p := relocateAdr[i]; j := i;
WHILE (j >= h) & (relocateAdr[j-h] > p) DO
relocateAdr[j] := relocateAdr[j-h]; j := j-h;
END;
relocateAdr[j] := p; INC(i)
END
UNTIL h = 1;
IF ~TraceDuplicates THEN
FOR i := 1 TO relocates-1 DO ASSERT(relocateAdr[i-1] < relocateAdr[i]) END
END
END SortRelocates;
PROCEDURE GetNum(refs: Bytes; VAR i, num: LONGINT);
VAR n, s: LONGINT; x: CHAR;
BEGIN
s := 0; n := 0;
x := refs[i]; INC(i);
WHILE ORD(x) >= 128 DO
INC(n, ASH(ORD(x) - 128, s));
INC(s, 7);
x := refs[i]; INC(i)
END;
num := n + ASH(ORD(x) MOD 64 - ORD(x) DIV 64 * 64, s)
END GetNum;
PROCEDURE VarByName(refs: Bytes; i: LONGINT; CONST name: ARRAY OF CHAR): SYSTEM.SIZE;
VAR mode: CHAR; j, m, adr, type, t: LONGINT; s: Name; found: BOOLEAN;
BEGIN
m := LEN(refs^); found := FALSE;
mode := refs[i]; INC(i);
WHILE (i < m) & ((mode = 1X) OR (mode = 3X)) & ~found DO
type := ORD(refs[i]); INC(i);
IF (type >= 81H) OR (type = 16H) OR (type = 1DH) THEN
GetNum(refs, i, t)
END;
GetNum(refs, i, adr);
j := 0; REPEAT s[j] := refs[i]; INC(i); INC(j) UNTIL s[j-1] = 0X;
IF s = name THEN found := TRUE
ELSIF i < m THEN mode := refs[i]; INC(i)
END
END;
IF found THEN
ASSERT((mode = 1X) & ((type = 0DH) OR (type = 1DH) OR (type = 06H)))
ELSE
adr := 0
END;
RETURN SYSTEM.VAL(SYSTEM.SIZE, adr)
END VarByName;
PROCEDURE InitTable(diff: SYSTEM.SIZE; baseAdr, loadAdr: SYSTEM.ADDRESS);
VAR i, n: LONGINT; adr: SYSTEM.ADDRESS; m: Module;
PROCEDURE InitBody(m: Module);
BEGIN
IF m = NIL THEN
NewSys(initBlock, 5*n + (5+3)); adr := SYSTEM.VAL(SYSTEM.ADDRESS, initBlock)
ELSE
INC(n); InitBody(m.next);
Address(SYSTEM.ADR(m.code[0])+diff); Char("H"); Char(" "); String(m.name); Ln;
SYSTEM.PUT(adr, 0E8X);
SYSTEM.PUT(adr+1, SYSTEM.ADR(m.code[0]) - (adr+5));
INC(adr, 5)
END
END InitBody;
BEGIN
String("BEGIN"); Ln;
n := 0; InitBody(SYSTEM.VAL(Module, root));
String("END"); Ln;
m := ModuleByName(StartModule);
i := 0; WHILE m.command[i].name # StartCommand DO INC(i) END;
Address(SYSTEM.VAL(SYSTEM.ADDRESS, m.command[i].entryAdr)+diff); Char(" ");
String(m.name); Char("."); String(StartCommand); Ln;
SYSTEM.PUT(adr, 0E8X);
SYSTEM.PUT(adr+1, SYSTEM.VAL(LONGINT, m.command[i].entryAdr) - (adr+5));
INC(adr, 5);
SYSTEM.PUT(adr, 6AX);
SYSTEM.PUT(adr+1, 0FFX);
SYSTEM.PUT(adr+2, 0CCX);
FOR adr := beginAdr TO beginAdr+HeaderSize-1 DO
SYSTEM.PUT(adr, 0X)
END;
IF baseAdr = loadAdr THEN
SYSTEM.PUT(beginAdr, 0E8X);
SYSTEM.PUT(beginAdr+1, SYSTEM.VAL(SYSTEM.ADDRESS, initBlock) - (beginAdr+5))
ELSE
adr := beginAdr;
SYSTEM.PUT(adr, 60X);
INC(adr);
SYSTEM.PUT(adr, 0BEX);
SYSTEM.PUT(adr+1, loadAdr);
INC(adr, 5);
SYSTEM.PUT(adr, 0BFX);
SYSTEM.PUT(adr+1, baseAdr);
INC(adr, 5);
SYSTEM.PUT(adr, 0B9X);
SYSTEM.PUT(adr+1, (freeAdr-beginAdr+3) DIV 4);
INC(adr, 5);
SYSTEM.PUT(adr, 0FCX);
SYSTEM.PUT(adr+1, 0F3X);
SYSTEM.PUT(adr+2, 0A5X);
INC(adr, 3);
SYSTEM.PUT(adr, 61X);
INC(adr);
SYSTEM.PUT(adr, 0E8X);
SYSTEM.PUT(adr+1, SYSTEM.VAL(SYSTEM.ADDRESS, initBlock) - (adr+5) + (baseAdr-loadAdr));
INC(adr, 5);
ASSERT(adr-beginAdr <= EndBlockOfs)
END;
SYSTEM.PUT(beginAdr + EndBlockOfs, freeAdr); Relocate(beginAdr + EndBlockOfs)
END InitTable;
PROCEDURE RootGlobals;
VAR m: Module; i: LONGINT; ofs: SYSTEM.SIZE;
BEGIN
m := ModuleByName(InitPtrModule);
ASSERT((m.refs[0] = 0F8X) & (m.refs[1] = 0X) & (m.refs[2] = "$") & (m.refs[3] = "$") & (m.refs[4] = 0X));
i := 5; ofs := VarByName(m.refs, i, InitPtrName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, initBlock); Relocate(m.sb + ofs);
m := ModuleByName(ModRootModule);
ASSERT((m.refs[0] = 0F8X) & (m.refs[1] = 0X) & (m.refs[2] = "$") & (m.refs[3] = "$") & (m.refs[4] = 0X));
i := 5;
ofs := VarByName(m.refs, i, ModRootName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, root); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, ProcOffsetsName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, SYSTEM.VAL(SYSTEM.ADDRESS, procOffsets)); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, NumProcsName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, numProcs);
ofs := VarByName(m.refs, i, PtrOffsetsName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, SYSTEM.VAL(SYSTEM.ADDRESS, ptrOffsets)); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, NumPtrsName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, numPtrs);
m := ModuleByName(HeapModule);
ASSERT((m.refs[0] = 0F8X) & (m.refs[1] = 0X) & (m.refs[2] = "$") & (m.refs[3] = "$") & (m.refs[4] = 0X));
i := 5;
ofs := VarByName(m.refs, i, FreeBlockTagPtrName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, freeBlockTag); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, SystemBlockTagPtrName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, systemBlockTag); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, RecordBlockTagPtrName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, recordBlockTag); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, ProtRecBlockTagPtrName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, protRecBlockTag); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, ArrayBlockTagPtrName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, arrayBlockTag); Relocate(m.sb + ofs);
ofs := VarByName(m.refs, i, CurrentMarkValueName); ASSERT(ofs # 0);
SYSTEM.PUT(m.sb + ofs, currentMarkValue)
END RootGlobals;
PROCEDURE ScopeInfo(diff: SYSTEM.SIZE; baseAdr: SYSTEM.ADDRESS; root: Module);
VAR main: SYSTEM.ADDRESS; m: Module; i: LONGINT;
BEGIN
m := root; WHILE (m # NIL) & (m.name # MainModule) DO m := m.next END;
IF m = NIL THEN main := -1 ELSE main := SYSTEM.ADR(m.code[0])+diff END;
IF main = -1 THEN String(MainModule); String(" not found"); Ln END;
String("SCOPE.BEGIN 0"); Address(baseAdr); String("H 0"); Address(main); Char("H"); Ln;
m := root;
WHILE m # NIL DO
String(" "); String(m.name); String(" 0");
Address(SYSTEM.ADR(m.code[0])+diff); String("H 0");
Hex(LEN(m.code), 8); String("H 0");
Address(m.sb); String("H "); Int(LEN(m.typeInfo), 1); Ln;
FOR i := 0 TO LEN(m.typeInfo)-1 DO
String(" 0"); Hex(-1, 8); String("H 0");
Address(SYSTEM.VAL(SYSTEM.ADDRESS, m.typeInfo[i].tag)+diff); Char("H"); Ln
END;
m := m.next
END;
String("SCOPE.END"); Ln
END ScopeInfo;
PROCEDURE CheckLinkerHeap;
VAR p, tagAdr, typeDescAdr: SYSTEM.ADDRESS; heapBlock: HeapBlock;
BEGIN
p := beginMemBlockAdr;
heapBlock := SYSTEM.VAL(HeapBlock, p + BlockHeaderSize);
WHILE p < endMemBlockAdr DO
SYSTEM.GET(SYSTEM.VAL(SYSTEM.ADDRESS, heapBlock) + TypeDescOffset, tagAdr);
IF tagAdr = freeBlockTag THEN
String("FreeBlock at adr = "); Address(p); Ln
ELSIF tagAdr = systemBlockTag THEN
String("SystemBlock at adr = "); Address(p); Ln
ELSIF tagAdr = recordBlockTag THEN
SYSTEM.GET(heapBlock.dataAdr + TypeDescOffset, typeDescAdr);
String("RecordBlock at adr = "); Address(p); String(" type = "); WriteType(typeDescAdr); Ln
ELSIF tagAdr = protRecBlockTag THEN
SYSTEM.GET(heapBlock.dataAdr + TypeDescOffset, typeDescAdr);
String("ProtRecBlock at adr = "); Address(p); String(" type = "); WriteType(typeDescAdr); Ln
ELSIF tagAdr = arrayBlockTag THEN
SYSTEM.GET(heapBlock.dataAdr + TypeDescOffset, typeDescAdr);
String("ArrayBlock at adr = "); Address(p); String(" element type = "); WriteType(typeDescAdr); Ln
ELSE
HALT(9999)
END;
p := p + heapBlock.size;
heapBlock := SYSTEM.VAL(HeapBlock, p + BlockHeaderSize)
END
END CheckLinkerHeap;
PROCEDURE Close*(w: Files.Writer; loadAdr: SYSTEM.ADDRESS; res: LONGINT; CONST msg: ARRAY OF CHAR; log: Streams.Writer);
VAR i: LONGINT; adr: SYSTEM.ADDRESS; diff: SYSTEM.SIZE; ch: CHAR;
BEGIN
IF res = 0 THEN
IF baseAdr = -1 THEN diff := 0 ELSE diff := baseAdr - beginAdr END;
FixupTypeDescTags;
InitTable(diff, baseAdr, loadAdr);
memBlock.endBlockAdr := freeAdr;
memBlock.size := freeAdr - beginMemBlockAdr;
FixupHeapBlockTags;
RootGlobals;
ScopeInfo(diff, baseAdr, SYSTEM.VAL(Module, root));
RelocateMemoryBlock;
RelocateModules;
RelocateProcOffsets;
RelocateExports;
FOR i := 0 TO relocates-1 DO
SYSTEM.GET(relocateAdr[i], adr);
IF adr # 0 THEN
IF ~(((adr > beginMemBlockAdr) & (adr <= freeAdr))) THEN
KernelLog.String("problem with adr in Linker0.Close ");
KernelLog.Int(beginMemBlockAdr,1);
KernelLog.String("<=");
KernelLog.Int(adr,1);
KernelLog.String("<=");
KernelLog.Int(freeAdr,1);
KernelLog.String(" at "); KernelLog.Int(i,1); KernelLog.String(":"); KernelLog.Int(relocates,1);
KernelLog.Ln;
END;
SYSTEM.PUT(relocateAdr[i], adr + diff)
END
END;
IF TraceDump THEN
SortRelocates; curRelocate := 0;
Memory(beginAdr, freeAdr - beginAdr);
ASSERT(curRelocate = -1)
END;
String(" exports: "); Int(exportTags, 1); String(" relocates: "); Int(relocates, 1);
IF TraceRefs THEN String(" possible missed references: "); Int(refsMissed, 1) END;
Ln;
FOR adr := beginAdr TO freeAdr - 1 DO
SYSTEM.GET(adr, ch);
w.Char( ch)
END;
FOR adr := 1 TO AddressSize DO
w.Char(0X)
END;
String("Written bytes"); Char(" "); Address(freeAdr - beginAdr+AddressSize); Ln
END;
String("Result = "); Int(res, 1); Char(" "); String(msg); Ln; logWriter.Update;
IF res = 0 THEN
log.String("Linker0 Ok. #Bytes= "); log.Address(freeAdr - beginAdr);
IF logFile # NIL THEN
log.String(" "); log.String(LogName);
END;
ELSE
log.String( "Error report in "); log.String( LogName);
END;
log.Ln;
IF logFile # NIL THEN
logWriter.Update();
logFile.Update();
Files.Register(logFile);
logFile := NIL; logWriter := NIL
END;
END Close;
PROCEDURE NewModule*(VAR m: Module);
VAR size, blockSize: SYSTEM.SIZE; protRecBlockAdr, dataBlockAdr: SYSTEM.ADDRESS;
protRecBlock: ProtRecBlock; i: LONGINT;
BEGIN
size := SYSTEM.GET32(SYSTEM.TYPECODE(Module));
blockSize := BlockHeaderSize + SYSTEM.SIZEOF(ProtRecBlockDesc) + BlockHeaderSize + size;
INC(blockSize, (-blockSize) MOD BlockSize);
protRecBlockAdr := NewBlock(blockSize) + BlockHeaderSize;
SYSTEM.PUT(protRecBlockAdr + TypeDescOffset, ProtRecBlockId);
SYSTEM.PUT(protRecBlockAdr + HeapBlockOffset, NilVal);
dataBlockAdr := protRecBlockAdr + SYSTEM.SIZEOF(ProtRecBlockDesc) + BlockHeaderSize;
SYSTEM.PUT(dataBlockAdr + TypeDescOffset, NilVal);
SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, protRecBlockAdr);
Relocate(dataBlockAdr + HeapBlockOffset);
protRecBlock := SYSTEM.VAL(ProtRecBlock, protRecBlockAdr);
protRecBlock.mark := currentMarkValue;
protRecBlock.dataAdr := dataBlockAdr;
protRecBlock.nextRealtime := NIL;
Relocate(SYSTEM.ADR(protRecBlock.dataAdr));
Relocate(SYSTEM.ADR(protRecBlock.nextRealtime));
protRecBlock.size := blockSize;
protRecBlock.count := 0;
protRecBlock.awaitingLock.head := NIL;
protRecBlock.awaitingLock.tail := NIL;
protRecBlock.awaitingCond.head := NIL;
protRecBlock.awaitingCond.tail := NIL;
protRecBlock.lockedBy := NIL;
protRecBlock.lock := NIL;
FOR i := 0 TO NumPriorities - 1 DO
protRecBlock.waitingPriorities[i] := 0
END;
INC(protRecBlock.waitingPriorities[0]);
m := SYSTEM.VAL(Module, dataBlockAdr);
Fill4(dataBlockAdr, (blockSize - SYSTEM.SIZEOF(ProtRecBlockDesc) - 2 * BlockHeaderSize) DIV 4, 0);
END NewModule;
PROCEDURE NewExportDesc*(VAR p: ExportArray; numElems: LONGINT);
VAR adr: SYSTEM.ADDRESS; block: ANY;
BEGIN
NewRealArr(block, numElems, SYSTEM.SIZEOF(ExportDesc), 1);
adr := SYSTEM.VAL(SYSTEM.ADDRESS, block);
SYSTEM.PUT(adr + LenOfs, numElems);
p := SYSTEM.VAL(ExportArray, block);
IF exportTags = LEN(exportTagAdr) THEN GrowTable(exportTagAdr) END;
exportTagAdr[exportTags] := adr + TypeDescOffset; INC(exportTags);
END NewExportDesc;
PROCEDURE ArraySize*(numElems, elemSize: SYSTEM.SIZE; numDims: LONGINT): SYSTEM.SIZE;
VAR arrSize, arrayDataOffset: SYSTEM.SIZE;
BEGIN
arrSize := numElems * elemSize;
arrayDataOffset := numDims * AddressSize + 3 * AddressSize;
INC(arrayDataOffset,(-arrayDataOffset) MOD ArrayAlignment);
RETURN arrayDataOffset + arrSize
END ArraySize;
PROCEDURE NewProcOffsets(VAR p: ProcOffsetTable; numElems: LONGINT);
VAR adr: SYSTEM.ADDRESS; block: ANY;
BEGIN
NewSys(block, ArraySize(numElems, SYSTEM.SIZEOF(ProcOffsetEntry), 1));
adr := SYSTEM.VAL(SYSTEM.ADDRESS, block);
SYSTEM.PUT(adr + LenOfs, numElems);
p := SYSTEM.VAL(ProcOffsetTable, block)
END NewProcOffsets;
PROCEDURE NewPtrOffsets(VAR p: PtrTable; numElems: LONGINT);
VAR adr: SYSTEM.ADDRESS; block: ANY;
BEGIN
NewSys(block, ArraySize(numElems, SYSTEM.SIZEOF(SYSTEM.SIZE), 1));
adr := SYSTEM.VAL(SYSTEM.ADDRESS, block);
SYSTEM.PUT(adr + LenOfs, numElems);
p := SYSTEM.VAL(PtrTable, block)
END NewPtrOffsets;
PROCEDURE FitMemoryBlock(startAdr: SYSTEM.ADDRESS; size: SYSTEM.SIZE; VAR memBlock: MemoryBlock);
VAR blockSize: SYSTEM.SIZE; recordBlock: RecordBlock; recordBlockAdr, dataBlockAdr: SYSTEM.ADDRESS;
BEGIN
blockSize := BlockHeaderSize + SYSTEM.SIZEOF(RecordBlockDesc) + BlockHeaderSize + SYSTEM.SIZEOF(MemoryBlockDesc);
INC(blockSize,(-blockSize) MOD BlockSize);
recordBlockAdr := startAdr + BlockHeaderSize;
SYSTEM.PUT(recordBlockAdr + TypeDescOffset, RecordBlockId);
SYSTEM.PUT(recordBlockAdr + HeapBlockOffset, NilVal);
dataBlockAdr := recordBlockAdr + SYSTEM.SIZEOF(RecordBlockDesc) + BlockHeaderSize;
SYSTEM.PUT(dataBlockAdr + TypeDescOffset, NilVal);
SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, recordBlockAdr);
recordBlock := SYSTEM.VAL(RecordBlock, recordBlockAdr);
recordBlock.mark := currentMarkValue;
recordBlock.dataAdr := dataBlockAdr;
recordBlock.size := blockSize;
recordBlock.nextRealtime := NIL;
memBlock := SYSTEM.VAL(MemoryBlock, dataBlockAdr);
memBlock.next := NIL;
memBlock.startAdr := NilVal;
memBlock.size := 0;
memBlock.beginBlockAdr := startAdr + blockSize;
memBlock.endBlockAdr := startAdr + size;
ASSERT(memBlock.beginBlockAdr < memBlock.endBlockAdr);
ASSERT(memBlock.beginBlockAdr MOD BlockSize = 0);
ASSERT(memBlock.endBlockAdr MOD BlockSize = 0);
END FitMemoryBlock;
PROCEDURE RelocateMemoryBlock;
VAR type: TypeDesc; memBlockAdr: SYSTEM.ADDRESS; recordBlock: RecordBlock;
BEGIN
type := ThisType(ModuleByName(MemBlockDescModule), MemBlockDescType);
ASSERT(type # NIL);
memBlockAdr := SYSTEM.VAL(SYSTEM.ADDRESS, memBlock);
SYSTEM.PUT(memBlockAdr + TypeDescOffset, type.tag);
Relocate(memBlockAdr + TypeDescOffset);
Relocate(memBlockAdr + HeapBlockOffset);
SYSTEM.GET(memBlockAdr + HeapBlockOffset, recordBlock);
Relocate(SYSTEM.ADR(recordBlock.dataAdr));
Relocate(SYSTEM.ADR(recordBlock.nextRealtime));
Relocate(SYSTEM.ADR(memBlock.beginBlockAdr));
Relocate(SYSTEM.ADR(memBlock.endBlockAdr))
END RelocateMemoryBlock;
PROCEDURE InitHeap;
VAR freeBlock: FreeBlock; alignOffset: SYSTEM.SIZE;
BEGIN
SYSTEM.NEW(heap, HeapSize);
beginMemBlockAdr := SYSTEM.VAL(SYSTEM.ADDRESS, heap) + HeaderSize;
alignOffset := (-beginMemBlockAdr) MOD BlockSize;
beginMemBlockAdr := beginMemBlockAdr + alignOffset;
beginAdr := beginMemBlockAdr - HeaderSize;
endMemBlockAdr := beginMemBlockAdr + HeapSize - HeaderSize - alignOffset;
DEC(endMemBlockAdr, endMemBlockAdr MOD BlockSize);
ASSERT(beginMemBlockAdr < endMemBlockAdr);
ASSERT(beginMemBlockAdr MOD BlockSize = 0);
ASSERT(endMemBlockAdr MOD BlockSize = 0);
FitMemoryBlock(beginMemBlockAdr, endMemBlockAdr - beginMemBlockAdr, memBlock);
freeBlock := SYSTEM.VAL(FreeBlock, memBlock.beginBlockAdr + BlockHeaderSize);
InitFreeBlock(freeBlock, Unmarked, NilVal, memBlock.endBlockAdr - memBlock.beginBlockAdr);
END InitHeap;
PROCEDURE ProcByName (refs: Bytes; CONST name: ARRAY OF CHAR): SYSTEM.SIZE;
VAR i, j, m, t, pofs: LONGINT; ch: CHAR; found: BOOLEAN;
BEGIN
i := 0; m := LEN(refs^); found := FALSE;
ch := refs[i]; INC(i);
WHILE (i < m) & ((ch = 0F8X) OR (ch = 0F9X)) & ~found DO
GetNum(refs, i, pofs);
IF ch = 0F9X THEN
GetNum(refs, i, t);
INC(i, 3)
END;
j := 0; WHILE (name[j] = refs[i]) & (name[j] # 0X) DO INC(i); INC(j) END;
IF (name[j] = 0X) & (refs[i] = 0X) THEN
found := TRUE
ELSE
WHILE refs[i] # 0X DO INC(i) END;
INC(i);
IF i < m THEN
ch := refs[i]; INC(i);
WHILE (i < m) & ((ch = 1X) OR (ch = 3X)) DO
ch := refs[i]; INC(i);
IF (ch >= 81X) OR (ch = 16X) OR (ch = 1DX) THEN
GetNum(refs, i, t)
END;
GetNum(refs, i, t);
REPEAT ch := refs[i]; INC(i) UNTIL ch = 0X;
ch := refs[i]; INC(i)
END
END
END
END;
IF ~found THEN pofs := -1 END;
RETURN SYSTEM.VAL(SYSTEM.SIZE, pofs)
END ProcByName;
PROCEDURE GetProc(m: Module; i: LONGINT; CONST mod, proc: ARRAY OF CHAR): SYSTEM.ADDRESS;
VAR adr: SYSTEM.SIZE;
BEGIN
IF m.name # mod THEN
m := ModuleByName(mod)
END;
adr := ProcByName(m.refs, proc);
IF ~getProcs[i] THEN
String("GetProc "); String(mod); Char("."); String(proc); Address(adr); Ln;
getProcs[i] := TRUE
END;
ASSERT(adr # -1);
RETURN SYSTEM.ADR(m.code[0]) + adr
END GetProc;
PROCEDURE GetKernelProc*(m: Module; num: LONGINT): SYSTEM.ADDRESS;
VAR adr: SYSTEM.ADDRESS;
BEGIN
CASE num OF
|243: adr := GetProc(m, 8, "Modules", "GetProcedure")
|246: adr := GetProc(m, 1, "Objects", "Unlock")
|247: adr := GetProc(m, 2, "Objects", "Lock")
|249: adr := GetProc(m, 3, "Objects", "Await")
|250: adr := GetProc(m, 4, "Objects", "CreateProcess")
|251: adr := GetProc(m, 5, "Heaps", "NewArr")
|252: adr := GetProc(m, 6, "Heaps", "NewSys")
|253: adr := GetProc(m, 7, "Heaps", "NewRec")
END;
RETURN adr
END GetKernelProc;
PROCEDURE WriteLog*;
BEGIN
logWriter.Update(); logFile.Update(); Files.Register(logFile); logFile := NIL; logWriter := NIL;
KernelLog.String(LogName); KernelLog.Ln;
END WriteLog;
BEGIN
suffix := DefaultExtension; prefix := "";
logFile := NIL; logWriter := NIL;
currentMarkValue := Unmarked + 1; ;
NEW(relocateAdr, 2048); NEW(exportTagAdr, 32)
END Linker0.
(*
19.05.98 pjm Started
23.05.99 pjm Fixed Find for non-sorted tables
*)
Linker0.Find 10A3C4H
Linker0.WriteLog
SystemTools.Free PELinker Linker1 Linker0 ~