-- Fsp.Mesa  Edited by Sandman on August 1, 1980  10:08 AM
-- Copyright  Xerox Corporation 1979, 1980

DIRECTORY
  AltoDefs USING [PageSize],
  FSPDefs USING [
    BlockSize, Deallocator, FreeNodePointer, NodeHeader, NodePointer, ZoneHeader,
    ZoneOverhead, ZonePointer],
  InlineDefs USING [COPY],
  NucleusOps USING [],
  ProcessDefs USING [InitializeMonitor],
  SegmentDefs USING [
    DataSegmentAddress, DataSegmentHandle, DefaultMDSBase, HardDown, HeapDS,
    MakeDataSegment, VMtoDataSegment],
  Storage USING [FreePages, PagesForWords],
  StringDefs USING [WordsForString],
  SystemDefs USING [];

FSP: MONITOR LOCKS z.lock USING z: ZonePointer
  IMPORTS InlineDefs, ProcessDefs, SegmentDefs, StringDefs, Storage
  EXPORTS FSPDefs, NucleusOps, Storage, 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;
  ZoneTooLarge: 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];
    IF CARDINAL[length] > CARDINAL[LAST[BlockSize]] THEN ERROR ZoneTooLarge[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;
    ValidateZone[z ! UNWIND => NULL];
    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;
    IF z.checking THEN CheckZone[z ! UNWIND => NULL];
    RETURN
    END;

  InvalidZone: ERROR [POINTER] = CODE; -- zone header looks fishy


  ValidateZone: PRIVATE PROCEDURE [z: ZonePointer] =
    BEGIN
    SELECT TRUE FROM
      (z.node.length # 0),
	((@z.node + z.length - UsedNodeSize).length # UsedNodeSize),
	(z.node.fwdp.backp # @z.node OR z.node.backp.fwdp # @z.node) =>
	ERROR InvalidZone[z];
      ENDCASE;
    RETURN
    END;

  NodeLoop: ERROR [ZonePointer] = CODE;

  CheckZone: PRIVATE PROCEDURE [z: ZonePointer] =
    BEGIN
    node: FreeNodePointer;
    count: INTEGER;
    ValidateZone[z];
    count _ (LAST[BlockSize] - FIRST[BlockSize])/FreeNodeSize + 1;
    node _ @z.node;
    DO
      CheckNode[z, node, FALSE];
      IF (count _ count - 1) < 0 THEN ERROR NodeLoop[z];
      IF (node _ node.fwdp) = @z.node THEN EXIT;
      ENDLOOP;
    RETURN
    END;

  InvalidNode: ERROR [POINTER] = CODE; -- node appears damaged


  CheckNode: PRIVATE PROCEDURE [
    z: ZonePointer, node: NodePointer, free: BOOLEAN] =
    BEGIN
    OP: TYPE = ORDERED POINTER;
    p: OP;
    zone: ZonePointer;
    FOR zone _ z, zone.restOfZone UNTIL zone = NIL DO
      p _ LOOPHOLE[zone, OP];
      IF LOOPHOLE[node, OP] IN [p..p + zone.length) THEN EXIT;
      REPEAT FINISHED => GOTO error;
      ENDLOOP;
    WITH node SELECT FROM free => IF free THEN ERROR; ENDCASE;
    DO
      WITH node SELECT FROM
	inuse => IF length = UsedNodeSize THEN EXIT; -- end of zone

	free =>
	  BEGIN
	  IF fwdp.backp # node OR backp.fwdp # node THEN GO TO error;
	  IF length = 0 AND node # @z.node THEN GO TO error;
	  END;
	ENDCASE;
      node _ node + node.length;
      IF node.state # inuse THEN EXIT;
      ENDLOOP;
    RETURN
    EXITS
      error =>
	BEGIN z.checking _ FALSE; ERROR InvalidNode[node + UsedNodeSize]; END;
    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;
    IF z.checking THEN CheckZone[z ! UNWIND => NULL];
    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
	  rover.length _ nl;
	  node _ rover + nl;
	  nodelength _ n;
	  z.rover _ rover;
	  node^ _ NodeHeader[nodelength, inuse[]];
	  RETURN[node + UsedNodeSize]
	  END
	ELSE
	  BEGIN
	  rover.fwdp.backp _ rover.backp;
	  z.rover _ rover.backp.fwdp _ rover.fwdp;
	  node _ rover;
	  node^ _ NodeHeader[nodelength, inuse[]];
	  RETURN[node + UsedNodeSize]
	  END;
	END;
      rover.length _ nodelength;
      IF (rover _ rover.fwdp) = z.rover THEN EXIT;
      ENDLOOP;
    RETURN[NIL];
    END;

  FreeNode: ENTRY PROCEDURE [z: ZonePointer, p: POINTER] =
    BEGIN
    IF z.checking THEN
      BEGIN
      CheckZone[z ! UNWIND => NULL];
      CheckNode[z, p - UsedNodeSize, TRUE ! UNWIND => NULL];
      END;
    FreeThisNode[z, p ! UNWIND => NULL];
    RETURN
    END;

  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;

  SplitNode: ENTRY PROCEDURE [z: ZonePointer, p: POINTER, n: BlockSize] =
    BEGIN
    node: NodePointer = p - UsedNodeSize;
    lastpart: NodePointer;
    t: BlockSize;
    IF z.checking THEN
      BEGIN
      CheckZone[z ! UNWIND => NULL];
      CheckNode[z, node, TRUE ! UNWIND => NULL];
      END;
    n _ MAX[n + UsedNodeSize, FreeNodeSize];
    WITH node SELECT FROM
      free => RETURN WITH ERROR InvalidNode[p];
      ENDCASE =>
	IF (t _ node.length - n) >= MAX[FreeNodeSize, z.threshold] THEN
	  BEGIN
	  lastpart _ node + n;
	  lastpart^ _ NodeHeader[t, inuse[]];
	  FreeThisNode[z, lastpart + UsedNodeSize ! UNWIND => NULL];
	  node.length _ n;
	  END;
    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;

  LargeNode: CARDINAL = 150;

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

  Node, AllocateHeapNode: PROCEDURE [nwords: CARDINAL] RETURNS [p: POINTER] =
    BEGIN OPEN Storage;
    IF INTEGER[nwords] < 0 THEN ERROR ZoneTooSmall[TheHeap];
    IF nwords + UsedNodeSize > LargeNode THEN
      BEGIN
      p _ GetMorePages[PagesForWords[nwords + UsedNodeSize]];
      p^ _ NodeHeader[length: nwords + UsedNodeSize, extension: inuse[]];
      RETURN[p + 1]
      END;
    p _ MakeNode[
      TheHeap, nwords !
      NoRoomInZone =>
	BEGIN
	Expand[PagesForWords[nwords + ZoneOverhead + UsedNodeSize]];
	RESUME
	END];
    RETURN
    END;

  Expand: PROCEDURE [pages: CARDINAL] =
    BEGIN OPEN Storage;
    AddToNewZone[
      z: TheHeap, base: GetMorePages[pages], length: pages*AltoDefs.PageSize,
      deallocate: FreePages];
    END;

  GetMorePages: PROCEDURE [pages: CARDINAL] RETURNS [POINTER] =
    BEGIN OPEN SegmentDefs;
    seg: DataSegmentHandle _ MakeDataSegment[DefaultMDSBase, pages, HardDown];
    seg.type _ HeapDS;
    RETURN[DataSegmentAddress[seg]];
    END;

  Free, FreeHeapNode: PROCEDURE [p: POINTER] =
    BEGIN OPEN SegmentDefs;
    pp: POINTER;
    IF p = NIL THEN RETURN;
    IF LOOPHOLE[(pp _ p - 1), POINTER TO inuse NodeHeader].length > LargeNode AND
      DataSegmentAddress[VMtoDataSegment[pp]] = pp THEN {
      Storage.FreePages[pp]; RETURN};
    FreeNode[TheHeap, p];
    RETURN
    END;

  String, AllocateHeapString: PROCEDURE [nchars: CARDINAL] RETURNS [s: STRING] =
    BEGIN
    s _ AllocateHeapNode[StringDefs.WordsForString[nchars]];
    s^ _ StringBody[length: 0, maxlength: nchars, text:];
    RETURN[s]
    END;

  FreeString, FreeHeapString: PROCEDURE [s: STRING] = LOOPHOLE[Free];

  CopyString: PROCEDURE [s: STRING, longer: CARDINAL _ 0] RETURNS [STRING] =
    BEGIN
    ns: STRING;
    IF s = NIL THEN RETURN[IF longer = 0 THEN NIL ELSE String[longer]];
    ns _ AllocateHeapString[s.length + longer];
    InlineDefs.COPY[from: @s.text, to: @ns.text, nwords: (s.length + 1)/2];
    ns.length _ s.length;
    RETURN[ns];
    END;

  ExpandString: PROCEDURE [s: POINTER TO STRING, longer: CARDINAL _ 0] =
    BEGIN
    ns: STRING;
    IF s^ = NIL THEN {IF longer # 0 THEN s^ _ String[longer]; RETURN};
    ns _ AllocateHeapString[s.maxlength + longer];
    InlineDefs.COPY[from: @s.text, to: @ns.text, nwords: (s.length + 1)/2];
    ns.length _ s.length;
    FreeHeapString[s^];
    s^ _ ns;
    END;

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

  -- initialization code

  TheHeap _ MakeNewZone[GetMorePages[2], 2*AltoDefs.PageSize, Storage.FreePages];

  END.