(* Copyright (C) 1990, Digital Equipment Corporation.         *)
(* All rights reserved.                                       *)
(* See the file COPYRIGHT for a full description.             *)

(* Last modified on Thu Nov  7 08:50:58 PST 1991 by kalsow    *)
(*      modified on Sat Mar  9 01:34:26 1991 by muller        *)
(*      modified on Thu Nov  8 14:21:56 PST 1990 by crelier   *)

UNSAFE MODULE PklWrite EXPORTS Pkl, PklRep;

IMPORT RTHeap, RTType, RTTypeFP, RTProc, Wr, Thread, Word, Text;

CONST
  HashFactor = -1640531527; (* =.6180339887*2^32 *)

TYPE
  HashTable = REF ARRAY OF RECORD
    r     : REFANY := NIL;
    index : INTEGER := 0
  END;

TYPE
  ProcAdr = REF ARRAY OF RECORD
    val   : ADDRESS := NIL;
    index : INTEGER
  END;

TYPE
  TypeMap = REF ARRAY OF RTType.Typecode;

TYPE
  State = REF RECORD
    wr           : Wr.T;
    maxObjs      : INTEGER;
    maxObjsMask  : INTEGER;
    maxObjsShift : INTEGER;
    objectsSize  : INTEGER := 0;
    specsSize    : INTEGER := 0;
    nTypes       : INTEGER := 0;
    nProcs       : INTEGER := 0;
    tcToLoc      : TypeMap := NIL;
    locToTc      : TypeMap := NIL;
    procAdr      : ProcAdr := NIL;
    procNum      : REF ARRAY OF INTEGER;
    lowIndex     : INTEGER; (* insert point for pending normal obj *)
    highIndex    : INTEGER; (* insert point for pending special obj *)
    queue        : REF ARRAY OF REFANY;
    visited      : HashTable;
    procMask     : INTEGER;
    procShift    : INTEGER;
    rootIndex    : INTEGER;
    nextAdr      : ADDRESS; (* used within Scan *)
  END;

PROCEDURE Write (r: REFANY;  wr: Wr.T;  lg2maxObjs := 14)
  RAISES {Wr.Failure, Thread.Alerted, Error} =
  VAR s := NEW (State);  headerpos, endpos: CARDINAL;
  BEGIN
    Init ();
    IF NOT Wr.Seekable(wr) THEN RAISE Error(Code.Unseekable) END;

    (* initialize the global state *)
    s.wr           := wr;
    s.maxObjs      := Word.Shift(1, lg2maxObjs);
    s.maxObjsMask  := 2 * s.maxObjs - 1;
    s.maxObjsShift := lg2maxObjs + 1 - BITSIZE(REFANY);
    s.tcToLoc      := NEW(TypeMap, RTType.MaxTypeCode()+1);
    s.locToTc      := NEW(TypeMap, RTType.MaxTypeCode()+1);
    s.procNum      := NEW(REF ARRAY OF INTEGER, RTProc.NumProcedures());
    s.lowIndex     := 0; (* insert point for pending normal obj *)
    s.highIndex    := s.maxObjs; (* insert point for pending special obj *)
    s.queue        := NEW(REF ARRAY OF REFANY, s.maxObjs);
    s.visited      := NEW(HashTable, 2 * s.maxObjs);
    s.procShift    := Log2(RTProc.NumProcedures()) + 2;
    s.procMask     := Word.Shift(1, s.procShift);
    s.procShift    := s.procShift - BITSIZE(ADDRESS);
    s.procAdr      := NEW(ProcAdr, s.procMask);
    DEC(s.procMask);
    FOR i := 0 TO LAST(s.tcToLoc^) DO  s.tcToLoc[i] := RTType.NoSuchType  END;

    Wr.PutText   (s.wr, "PPkl");
    Wr.PutString (s.wr, LOOPHOLE(Version, Integer));
    headerpos := Wr.Index (s.wr);
    WriteHeader (s); (* dummy header *)

    RTHeap.DisableCollection();
    TRY
      IF r # NIL THEN
        s.rootIndex := Visit (s, r);
        s.objectsSize := Wr.Index (s.wr);
        Scan (s);
        s.specsSize := Wr.Index (s.wr);
        s.objectsSize := s.specsSize - s.objectsSize;
        WriteBytes (s);
        s.specsSize := Wr.Index (s.wr) - s.specsSize;
        WriteTypes (s);
        WriteProcs (s)
      ELSE
        s.rootIndex := -1
      END;
      endpos := Wr.Index (s.wr);
      Wr.Seek (s.wr, headerpos);
      WriteHeader (s);
    FINALLY
      RTHeap.EnableCollection ();
    END;

    Wr.Seek (s.wr, endpos)
  END Write;

PROCEDURE WriteHeader (s: State) RAISES {Wr.Failure, Thread.Alerted} =
  BEGIN
    Wr.PutString(s.wr, LOOPHOLE(s.lowIndex, Integer));
    Wr.PutString(s.wr, LOOPHOLE(s.objectsSize, Integer));
    Wr.PutString(s.wr, LOOPHOLE(s.maxObjs-s.highIndex, Integer));
    Wr.PutString(s.wr, LOOPHOLE(s.specsSize, Integer));
    Wr.PutString(s.wr, LOOPHOLE(s.nTypes, Integer));
    Wr.PutString(s.wr, LOOPHOLE(s.nProcs, Integer));
    Wr.PutString(s.wr, LOOPHOLE(s.rootIndex, Integer))
  END WriteHeader;

PROCEDURE ResizeVQ (s: State) =
  VAR nh, index: INTEGER; newvisited: HashTable; newqueue: REF ARRAY OF REFANY;
  BEGIN
    s.maxObjsMask := 2*s.maxObjsMask + 1;
    INC(s.maxObjsShift);
    IF s.rootIndex >= s.highIndex THEN INC(s.rootIndex, s.maxObjs) END;
    newvisited := NEW(HashTable, s.maxObjsMask + 1);
    FOR h := 0 TO s.maxObjs-1 DO
      WITH r = s.visited[h].r DO
        IF r # NIL THEN
          nh := Word.Shift(Word.Times(HashFactor, LOOPHOLE(r, INTEGER)),
            s.maxObjsShift);
          WHILE newvisited[nh].r # NIL DO
            nh := Word.And(nh + 1, s.maxObjsMask)
          END;
          newvisited[nh].r := r;
          index := s.visited[h].index;
          IF index >= s.highIndex THEN INC(index, s.maxObjs) END;
          newvisited[nh].index := index
        END
      END
    END;
    s.visited := newvisited;
    newqueue := NEW(REF ARRAY OF REFANY, 2*s.maxObjs);
    SUBARRAY(newqueue^, 0, s.lowIndex) := SUBARRAY(s.queue^, 0, s.lowIndex);
    SUBARRAY(newqueue^, s.highIndex+s.maxObjs, s.maxObjs-s.highIndex) :=
      SUBARRAY(s.queue^, s.highIndex, s.maxObjs-s.highIndex);
    s.queue := newqueue;
    INC(s.highIndex, s.maxObjs);
    s.maxObjs := 2*s.maxObjs
  END ResizeVQ;
  
PROCEDURE Visit(s: State;  r: REFANY): INTEGER =
  (* if r already visited then return its index in queue
     else
       if r's type is new then insert it in locToTc
       end
       if convProc for r's type then copy and convert r into r2
       else r2 := r
       end
       if bytesProc for r's type then insert r2 in high part of queue
       else insert r2 in low part of queue
       end
       returns index in queue
    end
  *)
  VAR h: INTEGER;  tc, ltc: RTType.Typecode;  r2: REFANY;  conv: ConvertList;
  BEGIN
    (* r # NIL *)
    h := Word.Shift(Word.Times(HashFactor, LOOPHOLE(r, INTEGER)),
                      s.maxObjsShift);
    LOOP
      r2 := s.visited[h].r;
      IF r2 = r THEN RETURN s.visited[h].index END;
      IF r2 = NIL THEN EXIT END;
      h := Word.And(h + 1, s.maxObjsMask)
    END;

    (* new object *)
    s.visited[h].r := r;
    tc := TYPECODE(r);
    ltc := s.tcToLoc[tc];
    IF ltc = RTType.NoSuchType THEN (* new type *)
      s.locToTc[s.nTypes] := tc;
      ltc := s.nTypes;
      s.tcToLoc[tc] := ltc; INC(s.nTypes)
    END;

    conv := procs[tc].first;
    IF conv # NIL THEN
      (* copy ... *)
      r2 := RTHeap.Duplicate(r);
      (* ... and convert *)
      WHILE conv # NIL DO
        procs[conv.tc].wrconv(r2);
        conv := conv.next
      END
    ELSE r2 := r
    END;

    IF s.lowIndex = s.highIndex THEN ResizeVQ (s) END;
    IF procs[tc].wrbytes # NIL THEN
      DEC(s.highIndex);
      s.visited[h].index := s.highIndex;
      s.queue[s.highIndex] := r2;
      RETURN s.highIndex
    ELSE
      s.visited[h].index := s.lowIndex;
      s.queue[s.lowIndex] := r2;
      INC(s.lowIndex);
      RETURN s.lowIndex - 1
    END
  END Visit;

PROCEDURE Scan (s: State) RAISES {Wr.Failure, Thread.Alerted} =
  VAR
    ndim, index: INTEGER;
    shape: UNTRACED REF ARRAY [0..999] OF INTEGER;
    tc, ltc: RTType.Typecode;
    over: ADDRESS;
    r: REFANY;
  BEGIN
    index := 0;
    WHILE index < s.lowIndex DO
      r := s.queue[index];
      tc := TYPECODE(r);
      ltc := s.tcToLoc[tc];
      Wr.PutString(s.wr, LOOPHOLE(ltc, Integer));
      RTHeap.GetShape (r, ndim, shape);
      IF ndim > 0 THEN
        Wr.PutString(s.wr, SUBARRAY(LOOPHOLE(shape, ToChars)^, 0,
          BYTESIZE(INTEGER)*ndim))
      END;
      s.nextAdr := RTHeap.GetDataAdr(r);
      over := s.nextAdr + RTHeap.GetDataSize(r);
      <*FATAL ANY*> BEGIN
        RTType.Visit(s, r, HandleRef);
      END;
      (* write rest: *)
      Wr.PutString(s.wr, SUBARRAY(LOOPHOLE(s.nextAdr, ToChars)^,
                                    0, over - s.nextAdr));
      INC(index)
    END
  END Scan;

PROCEDURE HandleRef(arg     : REFANY;
                    fldadr  : ADDRESS;
         <*UNUSED*> objadr  : ADDRESS;
                    fldtype : RTType.RefType)
    RAISES {Wr.Failure, Thread.Alerted} =
    VAR s: State := arg;  index, num: INTEGER;  fld, padr: ADDRESS;
    BEGIN
      Wr.PutString(s.wr, SUBARRAY(LOOPHOLE(s.nextAdr, ToChars)^,
                                    0, fldadr - s.nextAdr));
      fld := LOOPHOLE(fldadr, REF ADDRESS)^;
      IF (fld = NIL) OR (fldtype = RTType.RefType.Untraced) THEN
        Wr.PutString(s.wr, LOOPHOLE(NIL, Integer))
      ELSE
        IF fldtype = RTType.RefType.Traced THEN
          index := Visit(s, LOOPHOLE(fld, REFANY));
          IF index >= s.highIndex THEN num := s.maxObjs-1 - index + FirstSpec
          ELSE num := index + FirstObj
          END
        ELSE (* fldtype = RTType.RefType.Proc *)
          index := Word.Shift(Word.Times(HashFactor, LOOPHOLE(fld, INTEGER)),
            s.procShift);
          LOOP
            padr := s.procAdr[index].val;
            IF padr = fld THEN EXIT END;
            IF padr = NIL THEN
              s.procAdr[index].val := fld; s.procAdr[index].index := s.nProcs;
              s.procNum[s.nProcs] := index; INC(s.nProcs);
              EXIT
            END;
            index := Word.And(index + 1, s.procMask)
          END;
          num := s.procAdr[index].index + FirstProc
        END;
        Wr.PutString(s.wr, LOOPHOLE(num, Integer))
      END;
      s.nextAdr := fldadr + ADRSIZE(ADDRESS);
    END HandleRef;

PROCEDURE WriteBytes (s: State) RAISES {Wr.Failure, Thread.Alerted} =
  VAR r: REFANY;  tc: RTType.Typecode;  text: TEXT;
  BEGIN
    FOR index := s.maxObjs-1 TO s.highIndex BY -1 DO
      r := s.queue[index];
      tc := TYPECODE(r);
      text := procs[tc].wrbytes(r);
      Wr.PutString(s.wr, LOOPHOLE(s.tcToLoc[tc], Integer));
      Wr.PutString(s.wr, LOOPHOLE(Text.Length(text), Integer));
      Wr.PutText(s.wr, text)
    END 
  END WriteBytes;

PROCEDURE WriteTypes (s: State)  RAISES {Wr.Failure, Thread.Alerted} =
  VAR tc: RTType.Typecode;  fp: RTTypeFP.Fingerprint;
  BEGIN
    FOR i := 0 TO s.nTypes-1 DO
      tc := s.locToTc[i];
      fp := RTTypeFP.ToFingerprint(tc);
      FOR j := FIRST(fp) TO LAST(fp) DO
        Wr.PutString(s.wr, LOOPHOLE(fp[j], Integer))
      END
    END
  END WriteTypes;

PROCEDURE WriteProcs (s: State)  RAISES {Wr.Failure, Thread.Alerted} =
  VAR fp: RTProc.Fingerprint;
  BEGIN
    FOR i := 0 TO s.nProcs-1 DO
      fp := RTProc.ToFingerprint (s.procAdr[s.procNum[i]].val);
      FOR j := FIRST(fp) TO LAST(fp) DO
        Wr.PutString(s.wr, LOOPHOLE(fp[j], Integer))
      END
    END
  END WriteProcs;

PROCEDURE Log2(n: INTEGER): INTEGER =  (* n >= 0 *)
  VAR i := 0;
  BEGIN
    i := 0;
    WHILE n > 1 DO n := n DIV 2; INC(i) END;
    RETURN i
  END Log2;

BEGIN
END PklWrite.