-- Copyright (C) 1981, 1982, 1984  by Xerox Corporation. All rights reserved. 
-- HeapFile.mesa, Transport Mechanism Filestore - heap file management
-- Stolen back from [Iris]<MCH>MCHCommon>StableStorageImpl.mesa

-- HGM, 26-Nov-84 17:53:55
-- Andrew Birrell	25-Oct-82 10:36:48
-- Randy Gobbel		29-Jun-82 16:38:42
-- Mark Johnson		19-May-81 13:30:37
-- Hankins		20-Aug-84 13:28:57	comments only

DIRECTORY
  BitMapDefs USING [Clear, Map, MapIndex, Set, Test],
  HeapFileDefs USING [],
  Inline USING [COPY, LowHalf],
  PolicyDefs USING [AmountOfFreeHeap, GapExists],
  Process USING [DisableTimeout],
  VMDefs USING [
    FileHandle, FullAddress, MarkStartWait, Page, PageAddress, PageIndex,
    PageNumber, pageSize, Release, UsePage];

HeapFile: MONITOR
  IMPORTS BitMapDefs, Inline, PolicyDefs, Process, VMDefs EXPORTS HeapFileDefs =
  BEGIN

  segmentSize: CARDINAL = 6;  -- number of pages in a segment
  headerSize: CARDINAL = SIZE[LONG INTEGER] + SIZE[SegmentIndex];
  segmentsPerPage: CARDINAL = VMDefs.pageSize / SIZE[SegmentIndex] - headerSize;
  SegmentIndex: PUBLIC TYPE = CARDINAL;
  noSegment: SegmentIndex = LAST[SegmentIndex];

  -- the 'written' chain is stored permanently on disk --
  ChainBlock: TYPE = MACHINE DEPENDENT RECORD [
    vp(0): SELECT OVERLAID * FROM
      sh => [header(0): ARRAY [0..0) OF SerialAndHead],
      chain => [next(0): ARRAY SegmentIndex [0..0) OF SegmentIndex],
      ENDCASE];

  SerialAndHead: TYPE = MACHINE DEPENDENT RECORD [
    serialNumber(0): LONG INTEGER,
    chainHead(2): SegmentIndex,
    -- head of written chain, unused on all pages but first of chain file
    fill(3): ARRAY [0..segmentsPerPage) OF UNSPECIFIED];

  ClientObject: TYPE = RECORD [
    chainHandle: VMDefs.FileHandle ¬ NIL,
    chain: POINTER TO ChainBlock ¬ NIL,
    lastWritten: SegmentIndex ¬ 0,  -- last segment allocated for a writer
    lastChained: SegmentIndex ¬ 0,  -- last segment chained onto chain.written
    lastPage: VMDefs.PageAddress ¬ NULL,  -- last page used in chain.written
    freeCount: CARDINAL ¬ 0,  -- number of free segments
    freeMap: BitMapDefs.Map,  -- free segment bitmap
    segmentCeiling: CARDINAL ¬ 0,  -- size of segment bitmap - 1

    handle: VMDefs.FileHandle ¬ NIL,
    segmentCount: CARDINAL ¬ 0,  -- number of segments
    -- synchronisation for single-page writers - beware!
    claimedPage: VMDefs.PageAddress ¬ NULL,
    claimed: BOOLEAN ¬ FALSE,
    unwrittenAllocation: BOOLEAN ¬ FALSE];

  client: ClientObject;
  notClaimed: CONDITION;
  segmentBecomesFree: CONDITION;

  Address: PUBLIC PROCEDURE [of: SegmentIndex] RETURNS [VMDefs.FullAddress] =
    BEGIN OPEN client;
    RETURN[
      [
        page: [
        file: handle,
        page:
        (of - ((of + VMDefs.pageSize) / VMDefs.pageSize) * headerSize) *
          segmentSize], word: FIRST[VMDefs.PageIndex]]];
    END;

  Segment: PUBLIC PROCEDURE [page: VMDefs.PageNumber]
    RETURNS [seg: SegmentIndex] = {
    segmentOrdinal: CARDINAL = Inline.LowHalf[page / segmentSize];
    seg ¬
      segmentOrdinal +
        ((segmentOrdinal + segmentsPerPage) / segmentsPerPage) * headerSize};

  FindSegment: INTERNAL PROCEDURE [near: SegmentIndex]
    RETURNS [new: SegmentIndex] =
    -- not same as ours but looks like works and simpler.
    BEGIN OPEN client;  -- find 'nearest' free segment;
    -- assumes (and checks) that bitmap entries for header words are "set".
    high: BitMapDefs.MapIndex ¬ near;
    low: BitMapDefs.MapIndex ¬ near;
    IF freeCount = 0 THEN ERROR;
    DO
      high ¬ MIN[high + 1, segmentCeiling];
      IF ~BitMapDefs.Test[freeMap, high] THEN {new ¬ high; EXIT};
      IF ~BitMapDefs.Test[freeMap, low] THEN {new ¬ low; EXIT};
      low ¬ MAX[low, 1] - 1;
      ENDLOOP;
    IF new MOD VMDefs.pageSize IN [0..headerSize) THEN ERROR;
    BitMapDefs.Set[freeMap, new];
    freeCount ¬ freeCount - 1;
    NotifyFreeCount[];
    END;

  RecordAllocation: PUBLIC PROCEDURE [seg: SegmentIndex] =
    BEGIN OPEN client;  -- should be INTERNAL but used by HeapRestart.
    page: CARDINAL = seg / VMDefs.pageSize;
    chainPage: VMDefs.PageNumber =
      page * 2 + (IF chain.header[page].serialNumber MOD 2 = 0 THEN 0 ELSE 1);
    diskCopy: POINTER TO SerialAndHead = LOOPHOLE[VMDefs.UsePage[
      [chainHandle, chainPage]]];
    chain.header[page].serialNumber ¬ chain.header[page].serialNumber + 1;
    Inline.COPY[
      from: @chain.header[page], to: diskCopy,
      nwords: MIN[1 + segmentCeiling - page * VMDefs.pageSize, VMDefs.pageSize]];
    VMDefs.MarkStartWait[LOOPHOLE[diskCopy]];
    -- why doesn't this use normal WritePageToFile style stuff in PilotFileSystem?
    -- this isn't a problem is it?
    VMDefs.Release[LOOPHOLE[diskCopy]];
    END;

  FirstSegment: PUBLIC ENTRY PROCEDURE RETURNS [VMDefs.FullAddress] = {
    RETURN[Address[client.chain.header[0].chainHead]]};

  InsertFirstSegment: PUBLIC ENTRY PROCEDURE RETURNS [VMDefs.FullAddress] =
    BEGIN OPEN client;
    new: SegmentIndex = FindSegment[chain.header[0].chainHead];
    IF new = noSegment THEN ERROR;
    chain.next[new] ¬ chain.header[0].chainHead;
    chain.header[0].chainHead ¬ new;
    IF new / VMDefs.pageSize # 0 THEN RecordAllocation[new];
    RecordAllocation[0];
    RETURN[Address[new]];
    END;

  NoMorePages: PUBLIC ERROR = CODE;

  NextPage: PUBLIC ENTRY PROCEDURE [given: VMDefs.FullAddress]
    RETURNS [VMDefs.FullAddress] =
    BEGIN OPEN client;
    ENABLE UNWIND => NULL;
    IF given.page.page = lastPage.page THEN ERROR NoMorePages[]
    ELSE
      IF given.page.page MOD segmentSize < segmentSize - 1 THEN
        BEGIN
        given.page.page ¬ given.page.page + 1;
        given.word ¬ FIRST[VMDefs.PageIndex];
        RETURN[given]
        END
      ELSE
        BEGIN
        seg: SegmentIndex = Segment[given.page.page];
        IF chain.next[seg] # noSegment THEN RETURN[Address[chain.next[seg]]]
        ELSE ERROR UnexpectedChaining[];
        END;
    END;


  -- Writer page allocation --

  LastPageWrong: ERROR = CODE;

  NewWriterPage: PUBLIC ENTRY PROCEDURE RETURNS [new: VMDefs.FullAddress] =
    BEGIN OPEN client;  -- see comment beside 'FreeSegment' --
    UNTIL freeCount >= 2 DO WAIT segmentBecomesFree ENDLOOP;
    lastWritten ¬ FindSegment[lastWritten];
    chain.next[lastWritten] ¬ noSegment;
    new ¬ Address[lastWritten];
    IF new.page.page = lastPage.page THEN ERROR LastPageWrong[];
    END;

  UnexpectedChaining: ERROR = CODE;

  NextWriterPage: PUBLIC ENTRY PROCEDURE [given: VMDefs.FullAddress]
    RETURNS [new: VMDefs.FullAddress] = {new ¬ InnerNextWriterPage[given]};

  InnerNextWriterPage: INTERNAL PROCEDURE [given: VMDefs.FullAddress]
    RETURNS [new: VMDefs.FullAddress] =
    BEGIN OPEN client;
    ENABLE UNWIND => NULL;
    IF given.page.page MOD segmentSize < segmentSize - 1 THEN
      BEGIN
      given.page.page ¬ given.page.page + 1;
      given.word ¬ FIRST[VMDefs.PageIndex];
      new ¬ given;
      END
    ELSE
      BEGIN
      current: SegmentIndex = Segment[given.page.page];
      IF chain.next[current] # noSegment THEN ERROR UnexpectedChaining[]
      ELSE
        BEGIN  -- reserve a page for compactor, see comment beside 'FreeSegment' --
        UNTIL freeCount >= 2 DO WAIT segmentBecomesFree ENDLOOP;
        lastWritten ¬ FindSegment[current];
        chain.next[lastWritten] ¬ noSegment;
        -- needn't record end cause don't yet know it's end (and not on chain)
        chain.next[current] ¬ lastWritten;
        RecordAllocation[current];  -- record inner seq. chaining
        new ¬ Address[lastWritten];
        END;
      END;
    IF new.page.page = lastPage.page THEN ERROR LastPageWrong[];
    END;

  CommitObject: PUBLIC ENTRY PROCEDURE [start, end: VMDefs.PageAddress] =
    BEGIN OPEN client;
    CheckForUnwrittenAllocation[];  --beware of single-page writers--
    chain.next[lastChained] ¬ Segment[start.page];
    RecordAllocation[Segment[end.page]];
    RecordAllocation[lastChained];
    lastChained ¬ Segment[end.page];
    lastPage ¬ end;
    PolicyDefs.GapExists[];
    END;

  ObjectAbandoned: PUBLIC ENTRY PROCEDURE [start: VMDefs.PageAddress] =
    BEGIN OPEN client;
    head: SegmentIndex ¬ Segment[start.page];
    WHILE head # noSegment DO
      BEGIN
      old: SegmentIndex = head;
      head ¬ chain.next[head];
      AddToFreeList[old];
      END;
      ENDLOOP;
    BROADCAST segmentBecomesFree;
    END;

  CheckForUnwrittenAllocation: INTERNAL PROCEDURE = INLINE
    BEGIN OPEN client;
    -- wait if single-page writer hasn't put its data into the single page --
    WHILE unwrittenAllocation DO WAIT notClaimed ENDLOOP;
    END;

  << WARNING: this single page stuff relies on the fact that Writer (who calls) is monitored and that no one can commit any space between a call to ClaimSinglePage and the corresponding call to CommitedSinglePage!! (else will lost data, probably not the single page writer but the other stuff)
Another tricky fact is that when ClaimSinglePage allocates a new segment, it does not fill up that segment unless no one else is putting stuff on the chain.  It always takes an available page out of last segment on chain (no matter who put it there) or, if that's not available, it used to allocate a new one (somewhat wasteful since we've already allocated one segment) so we'll treat it the same as being out of room to force the caller to use the segment they already have.
>>

  UseNormalPath: PUBLIC ERROR = CODE;

  ClaimSinglePage: PUBLIC ENTRY PROCEDURE RETURNS [next: VMDefs.PageAddress] =
    BEGIN OPEN client;  -- single-page writer wants a single page --
    ENABLE UNWIND => claimed ¬ FALSE;
    newAddr: VMDefs.PageAddress ¬ lastPage;
    WHILE claimed DO WAIT notClaimed ENDLOOP;
    claimed ¬ TRUE;
    IF newAddr.page MOD segmentSize < segmentSize - 1 THEN
      newAddr.page ¬ newAddr.page + 1  -- have a single page to use
    ELSE ERROR UseNormalPath[];
    -- force to use the page it has since would have to allocate another anyway.
    IF newAddr.page = lastPage.page THEN ERROR LastPageWrong[]
    ELSE next ¬ claimedPage ¬ newAddr;
    -- don't set "unwrittenAllocation" before here, to avoid deadlock with
    -- compactor if NewWriterPage needs to wait to allocate a page
    unwrittenAllocation ¬ TRUE;
    END;

  CommitedSinglePage: PUBLIC ENTRY PROCEDURE =
    BEGIN OPEN client;
    IF claimedPage.page MOD segmentSize = 0 THEN
      BEGIN  -- writing first page of newly allocated seg, must put it on chain --
      -- was set to end in call to NewWriterPage above.
      tempSeg: SegmentIndex ¬ Segment[claimedPage.page];
      chain.next[lastChained] ¬ tempSeg;
      -- record our ptr to end & chain ptr to us:
      RecordAllocation[tempSeg];
      RecordAllocation[client.lastChained];
      lastChained ¬ tempSeg;
      END;
    lastPage ¬ claimedPage;
    claimed ¬ FALSE;
    unwrittenAllocation ¬ FALSE;
    BROADCAST notClaimed;
    END;

  -- management of the free list --

  FreeSegment: PUBLIC ENTRY PROCEDURE [from, to: VMDefs.FullAddress]
    RETURNS [freed: CARDINAL ¬ 0] =
    BEGIN OPEN client;
    -- For the correctness of the compactor, it is necessary that its
    -- reading and writing pointers should always be on separate pages. 
    -- This would imply that we can free a segment if 'from' and 'to' would
    -- be separated by at least a page after removal of the segment. 
    -- However, if at the end of a cycle of the compactor there is a gap of
    -- less than one segment between the reading and writing pointers, and
    -- there is only one segment on the free list, and the writer is waiting
    -- for a segment (the writer can never use the last free segment, since
    -- this would stop the next cycle of the compactor starting), then it is
    -- possible that at the end of the next cycle of the compactor no
    -- segment would have been placed in the free list and so neither the
    -- compactor nor the writer could ever run again.  Accordingly, we must
    -- ensure that the reading and writing pointers are always at least one
    -- segment apart. Note that under such circumstances, the writer might
    -- wait for a long time for a segment to become available for it. --
    fromSegment: SegmentIndex = Segment[from.page.page];
    toSegment: SegmentIndex = Segment[to.page.page];
    IF fromSegment # toSegment AND chain.next[fromSegment] # toSegment THEN
      BEGIN
      ptr: SegmentIndex =
        IF from.page.page MOD segmentSize < to.page.page MOD segmentSize
        OR
          (from.page.page MOD segmentSize = to.page.page MOD segmentSize
            AND from.word <= to.word) THEN fromSegment
        ELSE chain.next[fromSegment];
      head: SegmentIndex ¬ chain.next[ptr];
      chain.next[ptr] ¬ toSegment;
      WHILE head # toSegment DO
        old: SegmentIndex = head;
        head ¬ chain.next[head];
        AddToFreeList[old];
        IF head > LAST[SegmentIndex] THEN {
          SegmentCorrupt: ERROR = CODE; ERROR SegmentCorrupt};
	freed ¬ freed + 1;
        ENDLOOP;
      CheckForUnwrittenAllocation[];  -- single-page writers --
      RecordAllocation[ptr];
      BROADCAST segmentBecomesFree;
      END;
    END;

  AddToFreeList: PUBLIC PROCEDURE [old: SegmentIndex] =
    BEGIN OPEN client;  -- should be INTERNAL but used by HeapRestart
    BitMapDefs.Clear[freeMap, old];
    freeCount ¬ freeCount + 1;
    NotifyFreeCount[];
    END;

  NotifyFreeCount: PUBLIC PROC = {
    OPEN client;
    PolicyDefs.AmountOfFreeHeap[
      Inline.LowHalf[(LONG[freeCount] * 100 + segmentCount / 2) / segmentCount]]};

  Process.DisableTimeout[@segmentBecomesFree];
  Process.DisableTimeout[@notClaimed];

  END.

log:
15-Aug-84 14:26:53 - blh:  made it almost the same as our StableStorageImpl (except signal for out of room).