(*********************************************************************)
(* Title:	Storage - Implementation			     *)
(* Author: 	Jeremy Dion, Mick Jordan			     *)
(* 		CUCL, ARC              	                             *)
(*********************************************************************)


(*
  $Revision: 1.3 $
  $Author: mjj $
  $Date: 85/06/04 18:01:46 $
  $Source: /util/m2/lib/Standard/RCS/Storage.mod,v $
  $State: Exp $
*)

IMPLEMENTATION MODULE Storage;

FROM OSStorage IMPORT WordAlign, AddressesPerUnit, HeapAllocate;
FROM SYSTEM IMPORT 
    ADDRESS, WORD, MAXCARD, TSIZE;
FROM Exceptions IMPORT RAISE;

(* $T-,$R- *)

(* This is a machine-independent storage allocator based on the idea of
   keeping lists of free blocks of differing sizes.
   
   Each block in the heap has a free word at the front. When the block
   is free, this word contains the size of the block, and the next word
   is used as a chain pointer to blocks of similar size. If
   the block is in use, the first word contains either the negative of the
   size of the block, if the block is large enough to be on the overflow
   list, or the negative of the index of the block in the array of free lists,
   otherwise. The reason for the negative is to trap deallocations of already
   free objects. All sizes in this code are in the (arbitrary) storage units
   defined by TSIZE (WORD).

   The block sizes are allocated in intervals of about 20%. This means
   that fragmentation is about 10%. The last slot in the block list is used
   for very large allocations. This is the only slot for which the
   dependent list of free blocks will not all have the same size.
   
   To allocate a block of memory, we first go to the list of blocks of
   size just greater than that requested. If this is NIL, then we make a
   new block of this size by getting it from the end of the current block
   of heap. Otherwise, we chain down the list looking for a block which is
   large enough. In all cases but the overflow list, the first block on the
   list will be found.  In order to avoid the case where the outside world
   has no more space to give and a particular list is exhausted, large blocks
   are recycled when there is more deallocated space the allocated.

   To dispose of a block, we look at the index word stored with it. This must
   be negative if the block is indeed in use, and if so, consider its
   absolute value. If this is small, it is the index of the list on which to
   chain the word. Otherwise it is the actual size of the block, which must
   be put on the overflow list. We insist that the argument given to 
   DEALLOCATE be at least as large as the actual size of the object.
   
*)

TYPE
  Block = POINTER TO BlockData;

  BlockData = RECORD
    size:   INTEGER;   (* or FreeList index in used blocks *)
    block:  Block;     (* only in free blocks *)
  END;

CONST Overflow = 56;

VAR freeList: ARRAY [1..Overflow] OF BlockData;

VAR
  base:        ADDRESS;               (* base of free space block     *)
  free:        CARDINAL;              (* size of free space block     *)
  resetBase:   BOOLEAN;               (* after recycling *)
  allocated,                     (* ALLOCATEd and not DEALLOCATEd *)
  deAllocated: CARDINAL;         (* DEALLOCATEd and not ALLOCATEd *)

CONST
  AllocateFailed = "ALLOCATE failed";
  DeAllocateFailed = "DEALLOCATE failed";

PROCEDURE ALLOCATE (VAR a: ADDRESS; n: CARDINAL);
  VAR index, half, need: INTEGER;
    rem: CARDINAL;
    b, p: Block;
  BEGIN
    IF WordAlign THEN
      rem := n MOD TSIZE (WORD);
      IF rem # 0 THEN INC (n, TSIZE (WORD) - rem) END
    END;
    need := n + TSIZE (INTEGER);  (* allow space for the size word *)

    (* now find the correct slot by binary chop, biased towards small sizes *)
    index := Overflow DIV 4;
    half := index DIV 2;
    LOOP
      IF need > freeList [index].size THEN
        INC (index, half);
        IF index = Overflow THEN EXIT END;
      ELSIF need > freeList [index-1].size THEN
        EXIT
      ELSE DEC (index, half);
        IF index = 1 THEN EXIT END;
      END;
      IF half > 1 THEN half := half DIV 2 END;
    END;

    (* now either choose a free block of the right size or get a new one *)
    b := freeList [index].block;
    p := NIL;
    WHILE (b # NIL) AND (b^.size < need) DO
      p := b;
      b := b^.block
    END;
    IF b = NIL THEN
      IF index # Overflow THEN need :=freeList[index].size END;
      IF (INTEGER (free) < need) AND NOT GetBlock (index, need) THEN
        RAISE(AllocateFailed);
      END;
      b := base;
      INC (base, need * AddressesPerUnit);
      DEC (free, CARDINAL (need));
    ELSE
      DEC(deAllocated, b^.size);
      IF p = NIL THEN
        freeList [index].block := b^.block;
      ELSE 
        p^.block := b^.block
      END;
    END;
    INC (allocated, n);
    a := ADDRESS (b) + AddressesPerUnit*TSIZE(INTEGER);
    IF index = Overflow THEN b^.size := -need ELSE b^.size := -index END
  END ALLOCATE;


PROCEDURE DEALLOCATE (VAR a: ADDRESS; n: CARDINAL);
  VAR b: Block;
    index, rem: CARDINAL;
  BEGIN
    IF a # NIL THEN
      IF WordAlign THEN
        rem := n MOD TSIZE (WORD);
        IF rem # 0 THEN INC (n, TSIZE (WORD) - rem) END
      END;
      b := Block (a - AddressesPerUnit*TSIZE(WORD));
      IF b^.size < 0 THEN index := -b^.size ELSE RAISE(DeAllocateFailed) END;
      IF index < Overflow THEN
        IF INTEGER (n) > freeList [index].size THEN
          RAISE(DeAllocateFailed)
        END;
        b^.block := freeList [index].block;
        b^.size := freeList [index].size;
        freeList [index].block := b;
      ELSE
        IF INTEGER (n) > -b^.size THEN RAISE(DeAllocateFailed) END;
        b^.block := freeList [Overflow].block;
        freeList [Overflow].block := b;
        b^.size := -b^.size;
      END;
      INC (deAllocated, n);
      DEC (allocated, n);
      a := NIL;
    END;
  END DEALLOCATE;

PROCEDURE GetBlock (index, n: CARDINAL): BOOLEAN;
  VAR
    ix: CARDINAL;
    p, b: Block;
  BEGIN
    (*  this is a rather crude attempt to recycle disposed
    blocks once they begin to accumulate *)
    IF resetBase THEN base := NIL END;
    resetBase := FALSE;
    
    IF ((index # Overflow) AND (deAllocated > allocated)) OR 
       NOT HeapAllocate(n, base, free) THEN
      FOR ix := Overflow TO index+1 BY -1 DO
        b := freeList [ix].block;
        p := NIL;
        WHILE (b # NIL) AND (b^.size < INTEGER(n)) DO
          p := b;
          b := b^.block;
        END;
        IF b # NIL THEN
          base := b; free := b^.size;
          DEC(deAllocated, free);
          IF p = NIL THEN
            freeList [ix].block := b^.block;
          ELSE 
            p^.block := b^.block
          END;
          resetBase := TRUE;
          (* so that when we next go to HeapAllocate,
          'base' is reset correctly. *)
          RETURN TRUE;
        END;
      END;
      (* in case we came in because deAllocated > allocated and failed *)
      RETURN HeapAllocate(n, base, free);
    END;
    RETURN TRUE;
  END GetBlock;

PROCEDURE Set8 (index, s1, s2, s3, s4, s5, s6, s7, s8: CARDINAL);
  VAR i, s: CARDINAL;
  BEGIN
    FOR i := index TO index + 7 DO 
      CASE i-index OF
        0: s := s1
      | 1: s := s2;
      | 2: s := s3;
      | 3: s := s4;
      | 4: s := s5;
      | 5: s := s6;
      | 6: s := s7;
      | 7: s := s8;
      END;
      WITH freeList[i] DO
        size := s*TSIZE(WORD);
        block := NIL;
      END;
    END;
  END Set8;

BEGIN
  allocated := 0;
  deAllocated := 0;
  base := NIL;
  resetBase := TRUE;
  free := 0;
  Set8 (1,     2,    3,    4,    5,    6,    7,    8,    9);
  Set8 (9,    10,   11,   12,   13,   14,   15,   16,   17);
  Set8 (17,   18,   19,   20,   21,   22,   23,   24,   25);
  Set8 (25,   26,   27,   28,   29,   30,   31,   32,   33);
  Set8 (33,   39,   47,   57,   65,   82,   98,  117,  129);
  Set8 (41,  168,  201,  241,  257,  290,  348,  418,  501);
  Set8 (49,  601,  722, 1039, 1246, 1496, 1795, 2154, 2585);
END Storage.

(*
$Log:	Storage.mod,v $
Revision 1.3  85/06/04  18:01:46  mjj
Modify strategy to recycle large blocks once deallocations occur
in large numbers.

*)