--file Sort.mesa
--last modified by Sweet on  April 27, 1980  11:15 PM
-- translated from Ed McCreight's BCPL by Jim Frandeen
-- Copyright  Xerox Corporation 1979, 1980

DIRECTORY
  AltoDefs: FROM "AltoDefs",
  FSPDefs: FROM "fspdefs" USING [NoRoomInZone, NodeOverhead],
  GPsortDefs: FROM "GPsortDefs",
  InlineDefs: FROM "inlinedefs" USING [COPY],
  StreamDefs: FROM "StreamDefs";

Sort: PROGRAM
  IMPORTS FSPDefs, GPsortDefs, InlineDefs, StreamDefs EXPORTS GPsortDefs =
  BEGIN OPEN GPsortDefs;
  
  NFiles: CARDINAL = 3; -- number of scratch files
  
  bufferSize: INTEGER;
  compareProc: CompareProcType;
  files: ARRAY [0..NFiles] OF FdHandle;
  firstFreeEnt: CARDINAL; -- 1 + end of unsorted part of heap vector
  
  getProc: GetProcType;
  heap: DESCRIPTOR FOR ARRAY OF ItemHeaderHandle;
  heapSize: CARDINAL; -- end of heap-sorted part of heap vector
  
  inputFinished: BOOLEAN;
  itemIsLeftOver: BOOLEAN;
  leftoverItem: ItemHandle;
  leftoverItemLen: ItemLength;
  level: CARDINAL;
  maxHeapSize: CARDINAL;
  maxItemWords: CARDINAL;
  occItemWords: CARDINAL;
  putProc: PutProcType;
  recordSize: CARDINAL;
  
  RecordTooLong: PUBLIC ERROR = CODE;
  
  BuildHeap: PROCEDURE =
    BEGIN
    L: CARDINAL;
    heapSize _ 0;
    MaintainHeap[];
    heapSize _ firstFreeEnt - 1;
    L _ (heapSize/2) + 1;
    WHILE L > 1 DO L _ L - 1; SiftDown[L, heap[L]]; ENDLOOP;
    RETURN;
    END;
    
  BuildRuns: PROCEDURE =
    BEGIN
    --Continue reading and sorting, alternating in Fibonacci sequence, until the input is exhausted.
    A: CARDINAL;
    item: ItemHeaderHandle;
    i: CARDINAL;
    j: CARDINAL _ 1;
    LFile: FdHandle;
    NT: CARDINAL;
    level _ 1;
    DO 
      OPEN files[j];
      IF level > 1 THEN dh.put[dh, EOR]; -- end-of-run marker
      FOR item _ GetHeap[], GetHeap[] UNTIL item = NIL DO
	dh.put[dh, item.len];
	[] _ StreamDefs.WriteBlock[dh, @item.rec, item.len];
	occItemWords _
	  occItemWords - item.len - SIZE[ItemLength] - FSPDefs.NodeOverhead;
	Free[item];
	ENDLOOP;
      dummyRuns _ dummyRuns - 1;
      IF inputFinished AND (firstFreeEnt = 1) THEN EXIT;
      IF dummyRuns < files[j + 1].dummyRuns THEN j _ j + 1
      ELSE
	BEGIN
	j _ 1;
	IF dummyRuns = 0 THEN
	  BEGIN
	  level _ level + 1;
	  A _ files[1].totalRuns;
	  FOR i IN [1..NFiles - 1] DO
	    LFile _ files[i];
	    NT _ A + files[i + 1].totalRuns;
	    LFile.dummyRuns _ NT - LFile.totalRuns;
	    LFile.totalRuns _ NT;
	    ENDLOOP;
	  END;
	END;
      BuildHeap[];
      ENDLOOP;
    FOR i IN [1..NFiles - 1] DO 
      OPEN files[i]; dh.put[dh, EOR]; dh.reset[dh]; ENDLOOP;
    RETURN;
    END;
    
  FreeAllocatedStuff: PROCEDURE =
    BEGIN
    i: CARDINAL;
    FOR i IN [1..NFiles] DO
      IF files[i].buffer # NIL THEN Free[files[i].buffer];
      IF files[i].record # NIL THEN Free[files[i].record];
      Free[files[i]];
      ENDLOOP;
    IF BASE[heap] # NIL THEN Free[BASE[heap]];
    IF leftoverItem # NIL THEN Free[leftoverItem];
    EraseHeap[];
    RETURN;
    END;
    
  GetHeap: PROCEDURE RETURNS [itemHP: ItemHeaderHandle] =
    BEGIN
    IF heapSize = 0 THEN RETURN[NIL];
    MaintainHeap[];
    itemHP _ heap[1];
    SiftDown[1, heap[heapSize]];
    firstFreeEnt _ firstFreeEnt - 1;
    heap[heapSize] _ heap[firstFreeEnt];
    heapSize _ heapSize - 1;
    RETURN;
    END;
    
  Initialize: PROCEDURE [res, expected, max: CARDINAL] =
    BEGIN
    MDSPages: CARDINAL = 400B;
    blockSize: INTEGER;
    heapPages, i: CARDINAL;
    res _ res + 92; -- 82 for mesa(include bitmap), 10 for me
    heapPages _ MIN[MDSPages - res, 100];
    blockSize _ heapPages*AltoDefs.PageSize;
    InitHeap[heapPages];
    FOR i IN [1..NFiles] DO
      files[i] _ Alloc[SIZE[Fd]];
      files[i].buffer _ NIL;
      files[i].record _ NIL;
      ENDLOOP;
    bufferSize _ (blockSize)/NFiles - 100;
    recordSize _ IF bufferSize > LOOPHOLE[max, INTEGER] THEN max ELSE bufferSize;
    maxHeapSize _ (blockSize - recordSize)/(expected + 3); -- this 3 is magic
    maxItemWords _ blockSize - maxHeapSize - recordSize;
    occItemWords _ 0;
    RETURN;
    END;
    
  MaintainHeap: PROCEDURE =
    BEGIN
    -- Fill the heap as full as possible
    itemHP: ItemHeaderHandle;
    IF inputFinished THEN RETURN;
    WHILE firstFreeEnt <= maxHeapSize DO
      -- Try adding another heap element
      IF NOT itemIsLeftOver THEN
	BEGIN
	leftoverItemLen _ getProc[leftoverItem];
	IF LOOPHOLE[leftoverItemLen, CARDINAL] > recordSize THEN
	  ERROR RecordTooLong;
	IF leftoverItemLen = 0 THEN BEGIN inputFinished _ TRUE; EXIT; END;
	END;
      IF occItemWords >= maxItemWords THEN BEGIN itemIsLeftOver _ TRUE; EXIT; END;
      itemHP _ Alloc[
	leftoverItemLen + SIZE[ItemLength] !
	FSPDefs.NoRoomInZone =>
	  BEGIN
	  maxItemWords _ occItemWords - 100;
	  itemIsLeftOver _ TRUE;
	  EXIT;
	  END];
      occItemWords _
	occItemWords + leftoverItemLen + SIZE[ItemLength] + FSPDefs.NodeOverhead;
      itemHP.len _ leftoverItemLen;
      InlineDefs.COPY[leftoverItem, leftoverItemLen, @itemHP.rec];
      heap[firstFreeEnt] _ heap[heapSize + 1];
      firstFreeEnt _ firstFreeEnt + 1;
      heap[heapSize + 1] _ itemHP;
      itemIsLeftOver _ FALSE;
      IF heapSize > 0 AND compareProc[@itemHP.rec, @heap[1].rec] = GT THEN
	BEGIN heapSize _ heapSize + 1; SiftUp[]; END;
      ENDLOOP;
    RETURN;
    END;
    
  MergePass: PROCEDURE =
    BEGIN
    dummiesThisPass: CARDINAL;
    lastFile: FdHandle;
    OFile: FdHandle;
    runNo: CARDINAL;
    runsThisPass: CARDINAL;
    OFile _ files[NFiles];
    lastFile _ files[NFiles - 1];
    runsThisPass _ lastFile.totalRuns;
    dummiesThisPass _ lastFile.dummyRuns;
    -- FOR i IN[1..NFiles-2]
    dummiesThisPass _ MIN[dummiesThisPass, files[1].dummyRuns];
    OFile.totalRuns _ runsThisPass;
    OFile.dummyRuns _ dummiesThisPass;
    -- FOR i IN[1..NFiles-2]
    files[1].totalRuns _ files[1].totalRuns - runsThisPass;
    files[1].dummyRuns _ files[1].dummyRuns - dummiesThisPass;
    FOR runNo IN [dummiesThisPass + 1..runsThisPass] DO MergeRun[OFile]; ENDLOOP;
    IF level > 1 THEN
      BEGIN
      fd: FdHandle;
      i: CARDINAL;
      FlushBuffer[OFile];
      FOR i IN [NFiles - 1..NFiles] DO 
	OPEN files[i]; dh.reset[dh]; head _ 0; tail _ 0; ENDLOOP;
      fd _ files[NFiles];
      FOR i DECREASING IN (1..NFiles] DO files[i] _ files[i - 1]; ENDLOOP;
      files[1] _ fd;
      END;
    RETURN;
    END;
    
  MergeRun: PROCEDURE [OFile: FdHandle] =
    BEGIN
    -- Process a run.  Fill up the applicable records.
    i: CARDINAL;
    SR: CARDINAL;
    FOR i IN [1..NFiles - 1] DO 
      OPEN files[i];
      IF dummyRuns = 0 THEN [] _ ReadRecord[files[i]]
      ELSE BEGIN dummyRuns _ dummyRuns - 1; endOfRun _ TRUE; END;
      ENDLOOP;
    DO
      SR _ 0; -- selected record (which file is it from)
      FOR i IN [1..NFiles - 1] DO 
	OPEN files[i];
	IF ( NOT endOfRun) AND (SR = 0 OR compareProc[record, files[SR].record] =
	  LT) THEN SR _ i;
	ENDLOOP;
      IF SR = 0 THEN EXIT; -- come back and fix this
      IF level = 1 THEN putProc[files[SR].record, files[SR].len]
      ELSE WriteRecord[OFile, files[SR].len, files[SR].record];
      files[SR].record _ NIL; -- for cleanup guy
      [] _ ReadRecord[files[SR]];
      ENDLOOP;
    IF level > 1 THEN WriteRecord[OFile, -1, NIL]; -- end-of-run marker
    RETURN;
    END;
    
  ReadRecord: PROCEDURE [file: FdHandle] RETURNS [BOOLEAN] =
    BEGIN
    itemLen: ItemLength;
    headIndex: INTEGER;
    IF file.head = LOOPHOLE[file.tail, CARDINAL] THEN
      FillBuffer[file, bufferSize];
    headIndex _ file.head;
    itemLen _ file.buffer^[headIndex];
    file.head _ headIndex _ headIndex + 1;
    IF itemLen < 0 THEN BEGIN file.endOfRun _ TRUE; RETURN[FALSE]; END;
    IF headIndex + itemLen > file.tail THEN FillBuffer[file, bufferSize];
    headIndex _ file.head;
    file.record _ @file.buffer^[headIndex];
    file.head _ headIndex + itemLen;
    file.len _ itemLen;
    file.endOfRun _ FALSE;
    RETURN[TRUE];
    END;
    
  SiftDown: PROCEDURE [L: CARDINAL, K: ItemHeaderHandle] =
    BEGIN
    J: CARDINAL _ L;
    I: CARDINAL;
    DO
      I _ J;
      J _ J + J;
      IF J > heapSize THEN EXIT;
      IF J < heapSize THEN
	IF compareProc[@heap[J].rec, @heap[J + 1].rec] > 0 THEN J _ J + 1;
      IF compareProc[@K.rec, @heap[J].rec] <= 0 THEN EXIT;
      heap[I] _ heap[J];
      ENDLOOP;
    heap[I] _ K;
    RETURN;
    END;
    
  SiftUp: PROCEDURE =
    BEGIN
    i: CARDINAL;
    j: CARDINAL _ heapSize;
    k: ItemHeaderHandle _ heap[heapSize];
    i _ j/2;
    WHILE i > 0 DO
      IF compareProc[@heap[i].rec, @k.rec] <= 0 THEN EXIT;
      heap[j] _ heap[i];
      j _ i;
      i _ j/2;
      ENDLOOP;
    heap[j] _ k;
    RETURN;
    END;
    
  WriteRecord: PROCEDURE [
    file: FdHandle, itemLen: ItemLength, itemPtr: ItemHandle] =
    BEGIN
    buffer: ItemHandle _ file.buffer;
    tailIndex: INTEGER _ file.tail;
    IF tailIndex + (IF itemLen < 0 THEN 1 ELSE itemLen + 1) > bufferSize THEN
      BEGIN FlushBuffer[file]; tailIndex _ file.tail; END;
    buffer^[tailIndex] _ itemLen;
    tailIndex _ tailIndex + 1;
    IF itemLen >= 0 THEN
      BEGIN
      InlineDefs.COPY[itemPtr, itemLen, @buffer^[tailIndex]];
      tailIndex _ tailIndex + itemLen;
      END;
    file.tail _ tailIndex;
    RETURN;
    END;
    
  Sort: PUBLIC PROCEDURE [
    get: GetProcType, put: PutProcType, compare: CompareProcType,
    expectedItemSize: CARDINAL, maxItemSize: CARDINAL, reservedPages: CARDINAL] =
    BEGIN
    DefaultExpected: CARDINAL = 10; -- words
    DefaultMax: CARDINAL = 1000;
    DefaultReserved: CARDINAL = 10;
    item: ItemHeaderHandle;
    fid: STRING = "SORT.SCRATCH0";
    i: CARDINAL;
    lastChar: CARDINAL _ fid.length - 1;
    Initialize[
      IF reservedPages # 0 THEN reservedPages ELSE DefaultReserved,
      IF expectedItemSize # 0 THEN expectedItemSize ELSE DefaultExpected,
      IF maxItemSize # 0 THEN maxItemSize ELSE DefaultMax];
    getProc _ get;
    compareProc _ compare;
    putProc _ put;
    heap _ DESCRIPTOR[Alloc[maxHeapSize + 1], maxHeapSize + 1];
    firstFreeEnt _ 1;
    -- First, fill up the heap as much as possible and sort it.
    leftoverItem _ Alloc[recordSize];
    itemIsLeftOver _ FALSE;
    inputFinished _ FALSE;
    BuildHeap[];
    IF inputFinished THEN
      THROUGH [1..heapSize] DO item _ GetHeap[]; put[@item.rec, item.len]; ENDLOOP
    ELSE
      BEGIN
      FOR i IN [1..NFiles - 1] DO 
	OPEN StreamDefs, files[i];
	fid[lastChar] _ fid[lastChar] + 1;
	dh _ NewWordStream[fid, Append + Write + Read];
	totalRuns _ 1;
	dummyRuns _ 1;
	ENDLOOP;
      files[NFiles].totalRuns _ 0;
      files[NFiles].dummyRuns _ 0;
      BuildRuns[];
      -- Put runs on input files 1..NFiles-1 so that they have Fibonacci relationship
      Free[leftoverItem];
      leftoverItem _ NIL;
      Free[BASE[heap]];
      heap _ DESCRIPTOR[NIL, 0];
      IF level > 1 THEN
	BEGIN OPEN StreamDefs;
	fid[lastChar] _ fid[lastChar] + 1;
	files[NFiles].dh _ NewWordStream[fid, Append + Write + Read];
	END;
      FOR i IN [1..NFiles] DO 
	OPEN files[i]; buffer _ Alloc[bufferSize]; head _ 0; tail _ 0; ENDLOOP;
      -- Now carry out merge passes until the level has returned to zero.
      UNTIL level = 0 DO
	MergePass[];
	-- also cycles the files afterward if level>1
	level _ level - 1;
	IF level = 1 THEN DeleteFile[files[NFiles].dh];
	-- Output will go to the putItemParam routine
	
	ENDLOOP;
      FOR i IN [1..NFiles - 1] DO DeleteFile[files[i].dh]; ENDLOOP;
      END;
    FreeAllocatedStuff[];
    RETURN;
    END;
    
  
  END...