-- file BcdLiteralsImpl.mesa
-- last edited by Satterthwaite, October 4, 1982 11:36 am

DIRECTORY
  Alloc: TYPE USING [AddNotify, DropNotify, Handle, Notifier],
  BcdDefs: TYPE USING [
    Base, FTIndex, FTNull, FTRecord, RFIndex, RFNull, rftype, SGIndex,
    TFIndex, TFNull, tftype, VersionStamp],
  BcdOps: TYPE USING [BcdBase],
  BcdErrorDefs: TYPE USING [ErrorFile],
  BcdLiterals: TYPE USING [],
  Environment: TYPE USING [bytesPerWord, wordsPerPage],
  Inline: TYPE USING [BITXOR, LongCOPY, LongMult, LowHalf],
  OSMiscOps: TYPE USING [FreePages, Pages],
  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],
  Stream: TYPE USING [Handle, PutBlock];

BcdLiteralsImpl: PROGRAM
    IMPORTS Alloc, BcdErrorDefs, Inline, OSMiscOps, RCMapOps, Stream
    EXPORTS BcdLiterals = {
  OPEN BcdDefs;
  
  Copy: PROC [from: LONG POINTER, nwords: CARDINAL, to: LONG POINTER] ~
    Inline.LongCOPY;
    
  table: Alloc.Handle;
  zone: UNCOUNTED ZONE;
  
  tfb, rfb: BcdDefs.Base;

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


 -- input
 
  TypeMap: TYPE ~ RECORD [SEQUENCE length: NAT OF RTBcd.TypeIndex];
  typeMap: LONG POINTER TO TypeMap _ NIL;

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


  LoadLiterals: PUBLIC PROC [
      fti: FTIndex,
      bcdBase: BcdOps.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 + Environment.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 _ zone.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 _ zone.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 ~ {
    IF typeMap # NIL THEN zone.FREE[@typeMap];
    IF litMap # NIL THEN zone.FREE[@litMap]};


 -- 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: POINTER TO LONG POINTER TO Nodes, newLimit: NAT] ~ {
    oldLimit: NAT ~ IF tree^ = NIL THEN 0 ELSE tree^.length;
    newTree: LONG POINTER TO Nodes ~ zone.NEW[Nodes[newLimit]];
    IF tree^ # NIL THEN {
      FOR i: NAT IN [0 .. MIN[oldLimit, newLimit]) DO newTree[i] _ tree^[i] ENDLOOP;
      zone.FREE[@(tree^)]};
    tree^ _ newTree};

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

 -- types
 
  MapType: PROC [old: RTBcd.TypeIndex] RETURNS [RTBcd.TypeIndex] ~ INLINE {
    RETURN [typeMap[old]]};
    
  typeList: LONG POINTER TO RTBcd.TypeList;
  nextType: NAT;
  typeTree: LONG POINTER TO 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];  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: LONG POINTER TO RTBcd.TypeList ~ zone.NEW[RTBcd.TypeList[newLimit]];
    IF typeList # NIL THEN {
      FOR i: NAT IN [0 .. MIN[oldLimit, newLimit]) DO newList[i] _ typeList[i] ENDLOOP;
      zone.FREE[@typeList]};
    typeList _ newList};


 -- atoms and REFs to literals
 
  MapLit: PROC [old: RTBcd.RefLitIndex] RETURNS [RTBcd.RefLitIndex] ~ INLINE {
    RETURN [litMap[old]]};
    

  litList: LONG POINTER TO RTBcd.RefLitList;
  nextLit: NAT;
  litTree: LONG POINTER TO 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];  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: LONG POINTER TO RTBcd.RefLitList ~ zone.NEW[RTBcd.RefLitList[newLimit]];
    IF litList # NIL THEN {
      FOR i: NAT IN [0 .. MIN[oldLimit, newLimit]) DO newList[i] _ litList[i] ENDLOOP;
      zone.FREE[@litList]};
    litList _ newList};


 -- RC maps
 
  rcmOpen: BOOL;
    
  OpenRCMap: PROC ~ {
    IF ~rcmOpen THEN {
      RCMapOps.Initialize[nPages~0, ptr~NIL, expansionZone~zone];
      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: LONG POINTER TO ARRAY HVIndex OF HTIndex;
  ht: LONG POINTER TO 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 [Inline.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*Environment.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: LONG POINTER TO HashSeq ~ zone.NEW[HashSeq[newLength]];
    IF ht # NIL THEN {
      FOR i: NAT IN [0 .. ht.length) DO newHt[i] _ ht[i] ENDLOOP;
      zone.FREE[@ht]};
    ht _ newHt};
  
      
 -- version stamps
 
  stampList: LONG POINTER TO 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: LONG POINTER TO RTBcd.StampList ~ 
      zone.NEW[RTBcd.StampList[newSize]];
    FOR i: NAT IN [1 .. MIN[oldSize, newSize]] DO newList[i] _ stampList[i] ENDLOOP;
    IF stampList # NIL THEN zone.FREE[@stampList];
    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 ~ {
    zone.FREE[@hashVec];
    IF ht # NIL THEN zone.FREE[@ht];
    IF litTree # NIL THEN zone.FREE[@litTree];
    IF typeTree # NIL THEN zone.FREE[@typeTree]};

  WriteLiterals: PUBLIC PROC [stream: Stream.Handle] ~ {
    IF litList # NIL OR typeList # NIL THEN {
      bytesPerWord: CARDINAL ~ Environment.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.PutBlock[[@header, 0, RTHeaderSize*bytesPerWord]];
      AdjustLitList[nextLit];
      stream.PutBlock[[litList, 0, litSize*bytesPerWord]];
      zone.FREE[@litList];
      IF textSpace # NIL THEN {
	stream.PutBlock[[textSpace, 0, textOffset*bytesPerWord]];
	OSMiscOps.FreePages[textSpace]};
      IF rcmSize # 0 THEN
        stream.PutBlock[[RCMapOps.GetBase[].base, 0, rcmSize*bytesPerWord]];
      CloseRCMap[];
      AdjustStampList[nextStamp-1];
      stream.PutBlock[[stampList, 0, stampSize*bytesPerWord]];
      zone.FREE[@stampList];
      AdjustTypeList[nextType];
      stream.PutBlock[[typeList, 0, typeSize*bytesPerWord]];
      zone.FREE[@typeList]}};
    

  Initialize: PUBLIC PROC [ownTable: Alloc.Handle, scratchZone: UNCOUNTED ZONE] ~ {
    table _ ownTable; table.AddNotify[Notifier];
    zone _ scratchZone;
    litList _ NIL;  litTree _ NIL;  nextLit _ 0;
    textSpace _ NIL;  textPages _ 0;  textOffset _ textLimit _ 0;
    hashVec _ zone.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 ~ {
    zone _ NIL;
    table.DropNotify[Notifier]; table _ NIL};
    
  }.