-- MMFsp.Mesa  Edited by Sandman on May 17, 1979  8:44 AM

DIRECTORY
  AltoDefs: FROM "altodefs" USING [PageSize],
  FSPDefs: FROM "fspdefs" USING [
    BlockSize, Deallocator, FreeNodePointer, NodeHeader, NodePointer,
    ZoneHeader, ZoneOverhead, ZonePointer],
  ProcessDefs: FROM "processdefs" USING [InitializeMonitor],
  StringDefs: FROM "stringdefs" USING [WordsForString],
  SystemDefs: FROM "systemdefs" USING [
    AllocateResidentPages, FreePages, PagesForWords];

MMFSP: MONITOR LOCKS z.lock USING z: ZonePointer
  IMPORTS ProcessDefs, StringDefs, SystemDefs EXPORTS FSPDefs, SystemDefs
  SHARES FSPDefs = PUBLIC
  BEGIN OPEN FSPDefs;  -- Mesa Free Storage Package --

    -- A set of procedures to manage allocation within a zone.
    -- Coalescing of free nodes occurs during allocation; all
    -- free nodes following a candidate node are merged before
    -- any space is allocated.  The logic is derived from a
    -- BCPL program by E. M. McCreight and was suggested by an
    -- exercise in Knuth Volume I, p. 453 #19

  UsedNodeSize: PRIVATE BlockSize = SIZE [inuse NodeHeader];
  FreeNodeSize: PRIVATE BlockSize = SIZE [free NodeHeader];
  ZoneHeaderSize: PRIVATE BlockSize = SIZE [ZoneHeader];

  ZoneTooSmall: ERROR [POINTER] = CODE;

  DoNothingDeallocate: Deallocator = BEGIN NULL END;

  MakeZone: PROCEDURE [base: POINTER, length: BlockSize] RETURNS [z: ZonePointer] =
    BEGIN
    RETURN[MakeNewZone[base, length, DoNothingDeallocate]];
    END;

  MakeNewZone: PROCEDURE [base: POINTER, length: BlockSize, deallocate: Deallocator]
  RETURNS [z: ZonePointer] =
    BEGIN
    fn: FreeNodePointer;
    an: POINTER TO inuse NodeHeader;
    IF length < ZoneHeaderSize+FreeNodeSize+UsedNodeSize
      THEN ERROR ZoneTooSmall[base];
    z _ base; 
    -- set up the bulk of the zone as a large free block.
    fn _ base + ZoneHeaderSize;
    fn^ _ NodeHeader[length: length-(ZoneHeaderSize+UsedNodeSize),
      extension: free[fwdp: @z.node, backp: @z.node]];
    -- set up allocated node (smallest possible) at end of block.
    an _ base + (length-UsedNodeSize);
    an^ _ NodeHeader[length: UsedNodeSize, extension: inuse[]];
    -- set up the zone header
    z^ _ ZoneHeader[rover: fn, lock:, restOfZone: NIL, length: length,
      deallocate: deallocate, threshold: FreeNodeSize, checking: FALSE,
      node: NodeHeader[length: 0, extension: free[fwdp: fn, backp: fn]]];
    ProcessDefs.InitializeMonitor[@z.lock];
    RETURN
    END;

  AddToZone: PROCEDURE [z: ZonePointer, base: POINTER, length: BlockSize] =
    BEGIN
    AddToNewZone[z, base, length, DoNothingDeallocate];
    END;

  AddToNewZone: ENTRY PROCEDURE [z: ZonePointer, base: POINTER,
    length: BlockSize, deallocate: Deallocator] =
    BEGIN
    newz: ZonePointer;
    firstnew, lastnew: FreeNodePointer;
    newz _ MakeNewZone[base, length, deallocate];
    -- splice the zones together
    firstnew _ newz.node.fwdp;  lastnew _ newz.node.backp;
    z.node.backp.fwdp _ firstnew;
    firstnew.backp _ z.node.backp;
    lastnew.fwdp _ @z.node;
    z.node.backp _ lastnew;
    -- make newz head an empty list
    newz.node.fwdp _ newz.node.backp _ @newz.node;
    newz.restOfZone _ z.restOfZone;
    z.restOfZone _ newz;
    RETURN
    END;

  NoRoomInZone: SIGNAL [ZonePointer] = CODE;

  MakeNode: PROCEDURE [z: ZonePointer, n: BlockSize] RETURNS [POINTER] =
    BEGIN
    node: NodePointer;
    IF INTEGER[n] < 0 THEN ERROR ZoneTooSmall[z];
    n _ MAX[n+UsedNodeSize, FreeNodeSize];
    WHILE (node _ GetNode[z, n]) = NIL DO
      SIGNAL NoRoomInZone[z];
      ENDLOOP;  -- try again if RESUMEd from the signal
    RETURN[node]
    END;

  GetNode: PRIVATE ENTRY PROCEDURE [z: ZonePointer, n: BlockSize] RETURNS [POINTER] =
    BEGIN
    rover: FreeNodePointer _ z.rover;
    node, neighbour: NodePointer;
    nodelength, nl: BlockSize;
    DO
      nodelength _ rover.length;
      FOR neighbour _ rover+nodelength, neighbour+nl DO 
	WITH neighbour SELECT FROM
	  inuse => EXIT;
	  free =>
	    BEGIN        -- coalesce
	    IF (nl _ length) = 0 THEN EXIT;        -- end of zone
	    fwdp.backp _ backp;  backp.fwdp _ fwdp;
	    z.rover _ rover;        -- in case neighbor was z.rover
	    nodelength _ nodelength+nl;
	    END;
	  ENDCASE;
	ENDLOOP;
      IF nodelength >= n THEN
	BEGIN
	IF (nl _ (nodelength-n)) > MAX[FreeNodeSize, z.threshold] THEN
	  BEGIN        -- split the block
	  z.rover _ rover;  rover.length _ nl;
	  node _ rover+nl;  nodelength _ n;
	  END
	ELSE
	  BEGIN
	  rover.fwdp.backp _ rover.backp;
	  z.rover _ rover.backp.fwdp _ rover.fwdp;
	  node _ rover;
	  END;
	node^ _ NodeHeader[nodelength, inuse[]];
	RETURN [node + UsedNodeSize]
	END
      ELSE rover.length _ nodelength;
      IF (rover _ rover.fwdp) = z.rover THEN EXIT;
      ENDLOOP;
    RETURN[NIL];
    END;

  FreeNode: ENTRY PROCEDURE [z: ZonePointer, p: POINTER] =
    BEGIN
    FreeThisNode[z, p ! UNWIND => NULL];
    RETURN
    END;

  InvalidNode: ERROR [POINTER] = CODE;

  FreeThisNode: PRIVATE PROCEDURE [z: ZonePointer, p: POINTER] =
    BEGIN
    node: NodePointer = p-UsedNodeSize;
    WITH node SELECT FROM
      free => ERROR InvalidNode[p];
      ENDCASE =>
	node^ _ NodeHeader[node.length, free[@z.node, z.node.backp]];
    WITH n:node SELECT FROM
      free => z.node.backp _ n.backp.fwdp _ @n;
      ENDCASE;
    RETURN
    END;

  NodeSize: PROCEDURE [p: POINTER] RETURNS [BlockSize] =
    BEGIN
    node: NodePointer = p-UsedNodeSize;
    WITH node SELECT FROM
      free => ERROR InvalidNode[p];
      ENDCASE => RETURN [length-UsedNodeSize];
    END;

  PruneZone: ENTRY PROCEDURE [z: ZonePointer] RETURNS [BOOLEAN] =
    BEGIN
    didit: BOOLEAN _ FALSE;
    rest: ZonePointer;
    zone: ZonePointer _ z;
    prev: ZonePointer _ z;
    node: NodePointer;
    nl: BlockSize;
    FOR zone _ z.restOfZone, rest UNTIL zone = NIL DO
      rest _ zone.restOfZone;
      IF zone.deallocate # DoNothingDeallocate THEN
	FOR node _ LOOPHOLE[zone+ZoneHeaderSize, NodePointer], node+nl DO
	  WITH node SELECT FROM
	    inuse =>
	      BEGIN
	      IF length = UsedNodeSize THEN
		BEGIN  -- end of zone
		FreeZone[zone ! UNWIND => NULL];
		didit _ TRUE;
		prev.restOfZone _ rest;
		END
	      ELSE prev _ zone;
	      EXIT
	      END;
	    free => nl _ length;
	    ENDCASE;
	  ENDLOOP;
      ENDLOOP;
    z.rover _ z.node.fwdp; -- reset rover incase in a freed zone
    RETURN[didit];
    END;

  FreeZone: PRIVATE PROCEDURE [zone: ZonePointer] =
    BEGIN
    node: NodePointer;
    nl: BlockSize;
    FOR node _ LOOPHOLE[zone+ZoneHeaderSize, NodePointer], node+nl DO
      WITH node SELECT FROM
	inuse => EXIT;  -- end of zone
	free =>
	  BEGIN
	  nl _ length;
	  backp.fwdp _ fwdp;
	  fwdp.backp _ backp;
	  END;
	ENDCASE;
      ENDLOOP;
    zone.deallocate[zone];
    END;


  -- DestroyZone is not an entry procedure since the monitorlock will be
  --   gone when we try to exit the procedure

  DestroyZone: PROCEDURE [z: ZonePointer] =
    BEGIN
    rest: ZonePointer;
    IF z = TheHeap THEN RETURN;
    FOR z _ z, rest UNTIL z = NIL DO
      rest _ z.restOfZone;
      z.deallocate[z];
      ENDLOOP;
    END;

  -- management of the heap

  TheHeap: PRIVATE ZonePointer;

  HeapZone: PROCEDURE RETURNS [ZonePointer] =
    BEGIN
    RETURN [TheHeap]
    END;

  AllocateHeapNode: PROCEDURE [nwords: CARDINAL] RETURNS [p: POINTER] =
    BEGIN OPEN SystemDefs;
    np: CARDINAL;
    IF INTEGER[nwords] < 0 THEN ERROR ZoneTooSmall[TheHeap];
    p _ MakeNode[TheHeap, nwords ! NoRoomInZone =>
      BEGIN
      np _ PagesForWords[nwords + ZoneOverhead + UsedNodeSize];
      AddToNewZone[z: TheHeap, base: AllocateResidentPages[np],
	length: np*AltoDefs.PageSize, deallocate: FreePages];
      RESUME
      END];
    RETURN
    END;

  FreeHeapNode: PROCEDURE [p: POINTER] =
    BEGIN
    FreeNode[TheHeap, p];  RETURN
    END;


  AllocateHeapString: PROCEDURE [nchars: CARDINAL] RETURNS [STRING] =
    BEGIN
    OPEN StringDefs;
    p: POINTER TO MACHINE DEPENDENT RECORD[	-- faked string header
      length: CARDINAL,
      maxlength: CARDINAL];
    p _ AllocateHeapNode[WordsForString[nchars]];
    p.length _ 0;  p.maxlength _ nchars;
    RETURN [LOOPHOLE[p, STRING]]
    END;

  FreeHeapString: PROCEDURE [s: STRING] =
  LOOPHOLE[FreeHeapNode];

  PruneHeap: PROCEDURE RETURNS [BOOLEAN] =
    BEGIN
    RETURN[PruneZone[TheHeap]]
    END;

  -- initialization code

    TheHeap _ MakeNewZone[SystemDefs.AllocateResidentPages[1],
      1*AltoDefs.PageSize, SystemDefs.FreePages];

END.