
<<file BcdLiteralsImpl.mesa>>
<<last edited by Satterthwaite, October 4, 1982 11:36 am>>
<<Last Edited by: Maxwell, August 11, 1983 2:23 pm>>
<<Last Edited by: Paul Rovner, September 22, 1983 11:43 am>>

DIRECTORY
Alloc: TYPE USING [AddNotify, DropNotify, Handle, Notifier],
Basics: TYPE USING [bytesPerWord, LongMult, LowHalf],
BcdDefs: TYPE USING [
Base, BcdBase, FTIndex, FTNull, FTRecord, RFIndex, RFNull, rftype, SGIndex,
TFIndex, TFNull, tftype, VersionStamp],
BcdErrorDefs: TYPE USING [ErrorFile],
BcdLiterals: TYPE USING [],
IO: TYPE USING [STREAM, UnsafePutBlock],
OSMiscOps: TYPE USING [FreePages, Pages],
PrincOps: TYPE USING [wordsPerPage],
PrincOpsUtils: TYPE USING [BITXOR, LongCOPY],
RCMapOps: TYPE USING [MapMap, Finalize, FindMapMapEntry, GetBase, Include, Initialize],
RTBcd: TYPE USING [
AnyStamp, RefLitIndex, RefLitItem, RefLitList, RTBase, RTHeader,
StampIndex, StampList, TypeIndex, TypeItem, TypeList, UTInfo, VersionID],
UnsafeStorage: TYPE USING [GetSystemUZone];

BcdLiteralsImpl: PROGRAM
IMPORTS Alloc, Basics, BcdErrorDefs, IO, OSMiscOps, PrincOpsUtils, RCMapOps, UnsafeStorage
EXPORTS BcdLiterals = {
OPEN BcdDefs;

Copy: PROC [from: LONG POINTER, nwords: CARDINAL, to: LONG POINTER] ~
PrincOpsUtils.LongCOPY;

table: Alloc.Handle;
zone: UNCOUNTED ZONE = UnsafeStorage.GetSystemUZone[];

tfb, rfb: BcdDefs.Base;

Notifier: Alloc.Notifier ~ {tfb _ base[tftype]; rfb _ base[rftype]};


<<input>>

TypeMap: TYPE ~ RECORD [SEQUENCE length: NAT OF RTBcd.TypeIndex];
typeMap: REF TypeMap _ NIL;

LitMap: TYPE ~ RECORD [SEQUENCE length: CARDINAL OF RTBcd.RefLitIndex];
litMap: REF LitMap _ NIL;


LoadLiterals: PUBLIC PROC [
fti: FTIndex,
bcdBase: BcdDefs.BcdBase,
MapFile: PROC [FTIndex] RETURNS [FTIndex],
MapSegment: PROC [SGIndex] RETURNS [SGIndex]] ~ {
IF bcdBase.rtPages.pages # 0 THEN {

ftb: BcdDefs.Base ~ LOOPHOLE[bcdBase, BcdDefs.Base] + bcdBase.ftOffset;
ftLimit: FTIndex ~ bcdBase.ftLimit;

VersionToFile: PROC [i: RTBcd.StampIndex] RETURNS [fti: BcdDefs.FTIndex] ~ {
FOR fti _ FTIndex.FIRST, fti + FTRecord.SIZE UNTIL fti = ftLimit DO
IF stampList[i] = ftb[fti].version THEN RETURN;
ENDLOOP;
RETURN [FTNull]};

rcmMap: RCMapOps.MapMap;

MapTypeItem: PROC [old: RTBcd.TypeItem, name: LONG POINTER TO TEXT]
RETURNS [RTBcd.TypeItem] ~ {
stamp: RTBcd.StampIndex ~ IF old.ut.version = RTBcd.AnyStamp
THEN RTBcd.AnyStamp
ELSE EnterStamp[rtHeader[rtHeader.stampTable][old.ut.version]];
IF ~old.canonical AND stamp # RTBcd.AnyStamp THEN
[] _ MapFile[VersionToFile[stamp]];        -- force file entry
RETURN [[
table~MapSegment[old.table],
sei~old.sei,
canonical~old.canonical,
ct~[EnterText[name]],
ut~[version: stamp, sei: old.ut.sei],
rcMap~RCMapOps.FindMapMapEntry[rcmMap, old.rcMap]]]};

MapLitItem: PROC [old: RTBcd.RefLitItem, lit: LONG POINTER TO TEXT]
RETURNS [RTBcd.RefLitItem] ~ {
RETURN [[
referentType~MapType[old.referentType],
offset~EnterText[lit],
length~old.length]]};

rtHeader: RTBcd.RTBase ~ LOOPHOLE[bcdBase + PrincOps.wordsPerPage*bcdBase.rtPages.relPageBase];
nTypes, nLits: NAT;

IF rtHeader.versionIdent # RTBcd.VersionID THEN GO TO badFormat;
nTypes _ rtHeader[rtHeader.typeTable].length;
IF nTypes # 0 THEN {
OpenRCMap[];
rcmMap _ RCMapOps.Include[
rcmb~@rtHeader[rtHeader.rcMapBase],
nWords~rtHeader.rcMapLength,
zone~zone];
typeMap _ NEW[TypeMap[nTypes]];
FOR i: NAT IN [0 .. nTypes) DO
typeString: LONG POINTER TO TEXT ~
@rtHeader[rtHeader.litBase] + rtHeader[rtHeader.typeTable][i].ct;
typeMap[i] _ EnterType[MapTypeItem[rtHeader[rtHeader.typeTable][i], typeString]];
ENDLOOP;
IF rcmMap # NIL THEN zone.FREE[@rcmMap]};
nLits _ rtHeader[rtHeader.refLitTable].length;
IF nLits # 0 THEN {
litMap _ NEW[LitMap[nLits]];
FOR i: NAT IN [0 .. rtHeader[rtHeader.refLitTable].length) DO
pName: LONG POINTER TO TEXT ~
@rtHeader[rtHeader.litBase] + rtHeader[rtHeader.refLitTable][i].offset;
litMap[i] _ EnterRefLit[MapLitItem[rtHeader[rtHeader.refLitTable][i], pName]];
ENDLOOP};
EXITS
badFormat => BcdErrorDefs.ErrorFile[$error, "has an incompatible version"L, fti]}};


MapLitLinks: PUBLIC PROC [rfi: RFIndex] ~ {
<<called after LoadLiterals, before UnloadLiterals>>
IF litMap # NIL AND rfi # RFNull THEN {
OPEN new~~rfb[rfi];
FOR i: NAT IN [0..new.length) DO new.frag[i] _ MapLit[new.frag[i]] ENDLOOP}};

MapTypeLinks: PUBLIC PROC [tfi: TFIndex] ~ {
<<called after LoadLiterals, before UnloadLiterals>>
IF typeMap # NIL AND tfi # TFNull THEN {
OPEN new~~tfb[tfi];
FOR i: NAT IN [0..new.length) DO new.frag[i] _ MapType[new.frag[i]] ENDLOOP}};


UnloadLiterals: PUBLIC PROC ~ {
typeMap _ NIL;
litMap _ NIL};


<<data structures for auxiliary tree structures>>

Relation: TYPE ~ {ls, gr, eq};
Branch: TYPE ~ CARDINAL --[0..NAT.LAST+1]--;
nullBranch: Branch ~ NAT.LAST+1;
Nodes: TYPE ~ RECORD [SEQUENCE length: NAT OF RECORD [l, r: Branch]];

AdjustNodes: PROC [tree: REF Nodes, newLimit: NAT]
RETURNS[newTree: REF Nodes] ~ {
oldLimit: NAT ~ IF tree = NIL THEN 0 ELSE tree.length;
newTree _ NEW[Nodes[newLimit]];
IF tree # NIL THEN {
FOR i: NAT IN [0 .. MIN[oldLimit, newLimit]) DO newTree[i] _ tree[i] ENDLOOP;
};
};

Scramble: PROC [n: CARDINAL] RETURNS [WORD] ~ INLINE {  -- see Knuth, v 3, p. 509-511
RETURN [Basics.LowHalf[Basics.LongMult[n, 44451]]]};


<<types>>

MapType: PROC [old: RTBcd.TypeIndex] RETURNS [RTBcd.TypeIndex] ~ INLINE {
RETURN [typeMap[old]]};

typeList: REF RTBcd.TypeList;
nextType: NAT;
typeTree: REF Nodes;

EnterType: PROC [item: RTBcd.TypeItem] RETURNS [index: RTBcd.TypeIndex] ~ {
i: Branch _ 0;
IF nextType = 0 THEN [] _ InsertType[item];
DO
SELECT CompareTypes[item, typeList[i]] FROM
$ls => {
IF typeTree[i].l = nullBranch THEN typeTree[i].l _ InsertType[item];
i _ typeTree[i].l};
$gr => {
IF typeTree[i].r = nullBranch THEN typeTree[i].r _ InsertType[item];
i _ typeTree[i].r};
ENDCASE => RETURN [[i]]
ENDLOOP};

CompareTypes: PROC [l, r: RTBcd.TypeItem] RETURNS [Relation] ~ {
sl: WORD ~ Scramble[l.ct];
sr: WORD ~ Scramble[r.ct];
RETURN [
SELECT sl FROM
< sr => $ls,  > sr => $gr,
ENDCASE => 
SELECT TRUE FROM
l.canonical AND ~r.canonical => $ls,
~l.canonical AND r.canonical => $gr,
ENDCASE =>    -- l.canonical = r.canonical
IF l.canonical THEN $eq ELSE CompareUTFs[l.ut, r.ut]]};

CompareUTFs: PROC [l, r: RTBcd.UTInfo] RETURNS [Relation] ~ {
UTWords: TYPE ~ ARRAY [0..RTBcd.UTInfo.SIZE) OF WORD;
FOR i: NAT IN [0..RTBcd.UTInfo.SIZE) DO
SELECT LOOPHOLE[l, UTWords][i] FROM
< LOOPHOLE[r, UTWords][i] => RETURN [$ls];
> LOOPHOLE[r, UTWords][i] => RETURN [$gr];
ENDCASE;
ENDLOOP;
RETURN [$eq]};


InsertType: PROC [item: RTBcd.TypeItem] RETURNS [index: Branch] ~ {
IF typeList = NIL OR nextType >= typeList.length THEN {
oldLimit: NAT ~ IF typeList = NIL THEN 0 ELSE typeList.length;
newLimit: NAT ~ oldLimit + MAX[MIN[oldLimit/2, 500], 50];
AdjustTypeList[newLimit];  typeTree _ AdjustNodes[typeTree, newLimit]};
index _ nextType;  nextType _ nextType + 1;
typeList[index] _ item;  typeTree[index] _ [l~nullBranch, r~nullBranch];
RETURN};

AdjustTypeList: PROC [newLimit: NAT] ~ {
oldLimit: NAT ~ IF typeList = NIL THEN 0 ELSE typeList.length;
newList: REF RTBcd.TypeList ~ NEW[RTBcd.TypeList[newLimit]];
IF typeList # NIL THEN {
FOR i: NAT IN [0 .. MIN[oldLimit, newLimit]) DO newList[i] _ typeList[i] ENDLOOP;
typeList _ NIL};
typeList _ newList};


<<atoms and REFs to literals>>

MapLit: PROC [old: RTBcd.RefLitIndex] RETURNS [RTBcd.RefLitIndex] ~ INLINE {
RETURN [litMap[old]]};


litList: REF RTBcd.RefLitList;
nextLit: NAT;
litTree: REF Nodes;

EnterRefLit: PROC [item: RTBcd.RefLitItem] RETURNS [RTBcd.RefLitIndex] ~ {
i: Branch _ 0;
IF nextLit = 0 THEN [] _ InsertRefLit[item];
DO
SELECT CompareLits[item, litList[i]] FROM
$ls => {
IF litTree[i].l = nullBranch THEN litTree[i].l _ InsertRefLit[item];
i _ litTree[i].l};
$gr => {
IF litTree[i].r = nullBranch THEN litTree[i].r _ InsertRefLit[item];
i _ litTree[i].r};
ENDCASE => RETURN [[i]]
ENDLOOP};

CompareLits: PROC [l, r: RTBcd.RefLitItem] RETURNS [Relation] ~ {
sl: WORD ~ Scramble[l.offset];
sr: WORD ~ Scramble[r.offset];
RETURN [SELECT sl FROM
< sr => $ls,
> sr => $gr,
ENDCASE => SELECT l.length FROM
= r.length =>
SELECT l.referentType - r.referentType FROM
= 0 => $eq, > 0 => $gr, ENDCASE => $ls,
< r.length => $ls,
ENDCASE => $gr]};

InsertRefLit: PROC [item: RTBcd.RefLitItem] RETURNS [index: Branch] ~ {
IF litList = NIL OR nextLit >= litList.length THEN {
oldLimit: NAT ~ IF litList = NIL THEN 0 ELSE litList.length;
newLimit: NAT ~ oldLimit + MAX[MIN[oldLimit/2, 500], 50];
AdjustLitList[newLimit];  litTree _ AdjustNodes[litTree, newLimit]};
index _ nextLit;  nextLit _ nextLit + 1;
litList[index] _ item;  litTree[index] _ [l~nullBranch, r~nullBranch];
RETURN};

AdjustLitList: PROC [newLimit: NAT] ~ {
oldLimit: NAT ~ IF litList = NIL THEN 0 ELSE litList.length;
newList: REF RTBcd.RefLitList ~ NEW[RTBcd.RefLitList[newLimit]];
IF litList # NIL THEN
FOR i: NAT IN [0 .. MIN[oldLimit, newLimit]) DO newList[i] _ litList[i] ENDLOOP;
litList _ newList};


<<RC maps>>

rcmOpen: BOOL;

OpenRCMap: PROC ~ {
IF ~rcmOpen THEN {
RCMapOps.Initialize[nPages~0, ptr~NIL, expansionOK~TRUE];
rcmOpen _ TRUE}};

CloseRCMap: PROC ~ {
IF rcmOpen THEN {RCMapOps.Finalize[];  rcmOpen _ FALSE}};


<<literal values>>

textSpace: LONG POINTER;    -- to words
textOffset, textLimit: CARDINAL;
textPages: CARDINAL;

HVIndex: TYPE ~ [0 .. 251);
HTIndex: TYPE ~ CARDINAL;
HTNull: HTIndex ~ HTIndex.LAST;
HashNode: TYPE ~ RECORD [offset: CARDINAL, link: HTIndex];
HashSeq: TYPE ~ RECORD [SEQUENCE length: CARDINAL OF HashNode];

hashVec: REF ARRAY HVIndex OF HTIndex;
ht: REF HashSeq;
nextHti: HTIndex;


LitText: PROC [offset: CARDINAL] RETURNS [LONG POINTER TO TEXT] ~ INLINE {
RETURN [textSpace + offset]};

EnterText: PROC [s: LONG POINTER TO TEXT] RETURNS [offset: CARDINAL] ~ {
hvi: HVIndex ~ HashValue[s];
hti: HTIndex;
nw: CARDINAL;
FOR hti _ hashVec[hvi], ht[hti].link UNTIL hti = HTNull DO
t: LONG POINTER TO TEXT ~ LitText[ht[hti].offset];
IF EqText[s, t] THEN RETURN [ht[hti].offset];
ENDLOOP;
nw _ TEXT[s.length].SIZE;
WHILE textOffset + nw > textLimit DO ExpandTextSpace[] ENDLOOP;
offset _ textOffset;
Copy[from~s, to~textSpace+textOffset, nwords~nw];
textOffset _ textOffset + nw;
hti _ AllocateHash[];
ht[hti] _ [link~hashVec[hvi], offset~offset];  hashVec[hvi] _ hti;
RETURN};

HashValue: PROC [s: LONG POINTER TO TEXT] RETURNS [HVIndex] ~ {
n: CARDINAL ~ s.length;
v: WORD ~ (IF n = 0 THEN 0 ELSE (s[0]-0c)*177b + (s[n-1]-0c));
RETURN [PrincOpsUtils.BITXOR[v, n*17b] MOD hashVec^.LENGTH]};

EqText: PROC [t1, t2: LONG POINTER TO TEXT] RETURNS [BOOL] ~ INLINE {
IF t1.length # t2.length THEN RETURN [FALSE];
FOR i: NAT IN [0..t1.length) DO
IF t1[i] # t2[i] THEN RETURN [FALSE] ENDLOOP;
RETURN [TRUE]};

ExpandTextSpace: PROC ~ {
newPages: CARDINAL ~ textPages + MAX[MIN[textPages/2, 16], 4];
newSpace: LONG POINTER ~ OSMiscOps.Pages[newPages];
IF textSpace # NIL THEN {
Copy[from~textSpace, to~newSpace, nwords~textOffset];
OSMiscOps.FreePages[textSpace]};
textSpace _ newSpace;
textPages _ newPages;  textLimit _ newPages*PrincOps.wordsPerPage};

AllocateHash: PROC RETURNS [hti: HTIndex] ~ {
IF ht = NIL OR nextHti >= ht.length THEN ExpandHashSpace[];
hti _ nextHti;  nextHti _ nextHti + 1;
RETURN};

ExpandHashSpace: PROC ~ {
oldLength: CARDINAL ~ IF ht = NIL THEN 0 ELSE ht.length;
newLength: CARDINAL ~ oldLength + MAX[MIN[oldLength/2, 1024], 256];
newHt: REF HashSeq ~ NEW[HashSeq[newLength]];
IF ht # NIL THEN FOR i: NAT IN [0 .. ht.length) DO newHt[i] _ ht[i] ENDLOOP;
ht _ newHt};


<<version stamps>>

stampList: REF RTBcd.StampList;
nextStamp: NAT;

EnterStamp: PROC [stamp: BcdDefs.VersionStamp] RETURNS [index: RTBcd.StampIndex] ~ {
FOR i: NAT IN [1 .. nextStamp) DO
IF stamp = stampList[i] THEN RETURN [[i]];
ENDLOOP;  
IF stampList = NIL OR nextStamp >= stampList.limit THEN ExpandStampList[];
index _ [nextStamp];  stampList[nextStamp] _ stamp;  nextStamp _ nextStamp + 1;
RETURN};

ExpandStampList: PROC ~ INLINE {
oldSize: NAT ~ IF stampList = NIL THEN 0 ELSE stampList.limit-1;
AdjustStampList[oldSize + MAX[MIN[oldSize/2, 256], 64]]};

AdjustStampList: PROC [newSize: NAT] ~ {
oldSize: NAT ~ IF stampList = NIL THEN 0 ELSE stampList.limit-1;
newList: REF RTBcd.StampList ~ NEW[RTBcd.StampList[newSize]];
FOR i: NAT IN [1 .. MIN[oldSize, newSize]] DO newList[i] _ stampList[i] ENDLOOP;
stampList _ newList};


<<output>>

EnterVersionFiles: PUBLIC PROC [
ftb: BcdDefs.Base, ftLimit: BcdDefs.FTIndex,
MapFile: PROC [BcdDefs.FTIndex] RETURNS [BcdDefs.FTIndex]] ~ {

VersionToFile: PROC [i: RTBcd.StampIndex] RETURNS [fti: BcdDefs.FTIndex] ~ {
FOR fti _ FTIndex.FIRST, fti + FTRecord.SIZE UNTIL fti = ftLimit DO
IF stampList[i] = ftb[fti].version THEN RETURN;
ENDLOOP;
RETURN [FTNull]};

FOR i: NAT IN [0 .. nextType) DO
IF ~typeList[i].canonical AND typeList[i].ut.version # RTBcd.AnyStamp THEN
[] _ MapFile[VersionToFile[typeList[i].ut.version]];
ENDLOOP};


RTHeaderSize: CARDINAL ~ RTBcd.RTHeader.SIZE;

LitSegSize: PUBLIC PROC RETURNS [nWords: CARDINAL] ~ {
RETURN [IF litList = NIL AND typeList = NIL
THEN 0
ELSE RTHeaderSize +
RTBcd.RefLitList[nextLit].SIZE + textOffset + 
RTBcd.TypeList[nextType].SIZE +
RTBcd.StampList[nextStamp-1].SIZE + RCMapOps.GetBase[].nWords]};

UpdateSegments: PUBLIC PROC [MapSegment: PROC [SGIndex] RETURNS [SGIndex]] ~ {
<<called if output packing has produced new sgis>>
FOR i: NAT IN [0 .. nextType) DO
typeList[i].table _ MapSegment[typeList[i].table] ENDLOOP};

SealLiterals: PUBLIC PROC ~ {
hashVec _ NIL;
ht _ NIL;
litTree _ NIL;
typeTree _ NIL};

WriteLiterals: PUBLIC PROC [stream: IO.STREAM] ~ {
IF litList # NIL OR typeList # NIL THEN {
bytesPerWord: CARDINAL ~ Basics.bytesPerWord;
litSize: CARDINAL ~ RTBcd.RefLitList[nextLit].SIZE;
typeSize: CARDINAL ~ RTBcd.TypeList[nextType].SIZE;
stampSize: CARDINAL ~ RTBcd.StampList[nextStamp-1].SIZE;
rcmSize: CARDINAL ~ RCMapOps.GetBase[].nWords;
header: RTBcd.RTHeader _ [
refLitTable~LOOPHOLE[RTHeaderSize],
litBase~LOOPHOLE[RTHeaderSize + litSize],
litLength~textOffset,
rcMapBase~LOOPHOLE[LONG[RTHeaderSize + litSize + textOffset]],
rcMapLength~rcmSize,
stampTable~LOOPHOLE[RTHeaderSize + litSize + textOffset + rcmSize],
typeTable~LOOPHOLE[RTHeaderSize + litSize + textOffset + rcmSize + stampSize]];
stream.UnsafePutBlock[[LOOPHOLE[LONG[@header], LONG POINTER TO PACKED ARRAY [0..0) OF CHAR], 0, RTHeaderSize*bytesPerWord]];
AdjustLitList[nextLit];
stream.UnsafePutBlock
[[LOOPHOLE[litList, LONG POINTER], 0, litSize*bytesPerWord]];
litList _ NIL;
IF textSpace # NIL THEN {
stream.UnsafePutBlock[[textSpace, 0, textOffset*bytesPerWord]];
OSMiscOps.FreePages[textSpace]};
IF rcmSize # 0 THEN
stream.UnsafePutBlock[[RCMapOps.GetBase[].base, 0, rcmSize*bytesPerWord]];
CloseRCMap[];
AdjustStampList[nextStamp-1];
stream.UnsafePutBlock
[[LOOPHOLE[stampList, LONG POINTER], 0, stampSize*bytesPerWord]];
stampList _ NIL;
AdjustTypeList[nextType];
stream.UnsafePutBlock
[[LOOPHOLE[typeList, LONG POINTER], 0, typeSize*bytesPerWord]];
typeList _ NIL}};


Initialize: PUBLIC PROC [ownTable: Alloc.Handle] ~ {
table _ ownTable; table.AddNotify[Notifier];
litList _ NIL;  litTree _ NIL;  nextLit _ 0;
textSpace _ NIL;  textPages _ 0;  textOffset _ textLimit _ 0;
hashVec _ NEW[ARRAY HVIndex OF HTIndex _ ALL[HTNull]];
ht _ NIL;  nextHti _ 0;
rcmOpen _ FALSE;
stampList _ NIL;  nextStamp _ 1;
typeList _ NIL;  typeTree _ NIL;  nextType _ 0};

Finalize: PUBLIC PROC ~ {
table.DropNotify[Notifier]; table _ NIL};

}.