(******************************************************************************)
(* Copyright (c) 1988 by GMD Karlruhe, Germany				      *)
(* Gesellschaft fuer Mathematik und Datenverarbeitung			      *)
(* (German National Research Center for Computer Science)		      *)
(* Forschungsstelle fuer Programmstrukturen an Universitaet Karlsruhe	      *)
(* All rights reserved.							      *)
(******************************************************************************)

IMPLEMENTATION MODULE Storage;


   FROM SYSTEM IMPORT ADR, ADDRESS;

   FROM SysLib IMPORT sbrk;


   CONST
     Alignment	       = 4;
     MinSizeSmallBlock = 4;	(* must be aligned *)

   CONST
     MaxSizeSmallBlock     = 30;
     MinSizeLargeBlockLog  = 5;    (* Log2 32    *)
     MaxSizeLargeBlockLog  = 24;   (* Log2 2**24 *)
     PoolSize              = 10240;
     cNoMoreSpace          = -1;

   TYPE
     tBlockPtr        = POINTER TO tBlock;
     tBlock           = RECORD
			  Successor : tBlockPtr;
			  Size      : CARDINAL;
			END;
     tSmallBlockRange = [MinSizeSmallBlock    .. MaxSizeSmallBlock   ];
     tLargeBlockRange = [MinSizeLargeBlockLog .. MaxSizeLargeBlockLog];

   VAR
     SmallChain    : ARRAY tSmallBlockRange OF ADDRESS;
     LargeChain    : ARRAY tLargeBlockRange OF ADDRESS;
     PoolFreePtr   : ADDRESS;
     PoolSpaceLeft : CARDINAL;
     NoMoreSpace   : LONGINT;




   PROCEDURE Log2 (x: LONGINT) : CARDINAL;
   (* Returns the logarithm to the base 2 of 'x'.        *)
     VAR y: CARDINAL;
   BEGIN
     y := 0;
     IF x >= 65536 THEN INC (y, 16); x := x DIV 65536; END;
     IF x >=   256 THEN INC (y,  8); x := x DIV   256; END;
     IF x >=    16 THEN INC (y,  4); x := x DIV    16; END;
     IF x >=     4 THEN INC (y,  2); x := x DIV     4; END;
     IF x >=     2 THEN INC (y,  1); x := x DIV     2; END;
     RETURN y;
   END Log2;


   PROCEDURE ALLOCATE (VAR a : ADDRESS; size : CARDINAL);
   (* Allocates an area of the given size 'size' and returns it's *) 
   (* address in 'a'. If no space is available, 'a' becomes 'NIL'. *)

   VAR
     BlockPtr,
     CurrentBlock,
     PreviousBlock,
     BestBlock,
     PredecessorBlock : tBlockPtr;
     ChainNumber      : CARDINAL;
     CurrentBlockSize,
     BestBlockSize    : CARDINAL;
     j                : tLargeBlockRange;

   BEGIN
       (* align size to next Alignment boundary: *)
       size := CARDINAL( BITSET(size + (Alignment-1)) - BITSET(Alignment-1) );

       IF size < MinSizeSmallBlock THEN
	 size := MinSizeSmallBlock;
       END;

       IF size <= MaxSizeSmallBlock THEN

	 (* handle small block *)

	 IF SmallChain [size] # NIL THEN

	   (* obtain block from freelist *)

	   BlockPtr := SmallChain [size];
	   SmallChain [size] := BlockPtr^.Successor;
	   a :=  BlockPtr;

	 ELSE

	   (* obtain block from storage pool *)

	   PoolAlloc (a, size);
	 END;
       ELSE

	 (* handle large block *)

	 (* 1. search in LargeChain [Log2 (size)] using BEST FIT *)

	 ChainNumber    := Log2 (size);
	 CurrentBlock   := LargeChain [ChainNumber];
	 PreviousBlock  := ADR (LargeChain [ChainNumber]);
	 BestBlock      := NIL;
	 BestBlockSize  := MAX(CARDINAL);

	 WHILE CurrentBlock # NIL DO

	   CurrentBlockSize := CurrentBlock^.Size;
	   IF CurrentBlockSize >= size THEN

	     (* exact match *)

	     IF CurrentBlockSize = size THEN
	       PreviousBlock^.Successor := CurrentBlock^.Successor;
	       a := CurrentBlock;
	       RETURN
	     END;

	     (* improve approximation *)

	     IF CurrentBlockSize < BestBlockSize THEN
	       BestBlock        := CurrentBlock;
	       BestBlockSize    := CurrentBlockSize;
	       PredecessorBlock := PreviousBlock;
	     END;
	   END;
	   PreviousBlock := CurrentBlock;
	   CurrentBlock  := CurrentBlock^.Successor;
	 END;

	 IF BestBlock # NIL THEN
	   PredecessorBlock^.Successor := BestBlock^.Successor;
	   IF   BestBlockSize - size >= MinSizeSmallBlock
	   THEN a := ADDRESS (BestBlock) + size;
		DEALLOCATE (a, BestBlockSize - size);
	   END;
	   a := BestBlock;
	   RETURN
	 END;

	 (* 2. search in LargeChain [j], j > Log2 (size), using FIRST FIT *)

	 FOR j := ChainNumber+1 TO MaxSizeLargeBlockLog DO
	   CurrentBlock := LargeChain [j];
	   IF CurrentBlock # NIL THEN
	     LargeChain [j] := CurrentBlock^.Successor;
	     IF   CurrentBlock^.Size - size >= MinSizeSmallBlock
	     THEN a := ADDRESS (CurrentBlock) + size;
		  DEALLOCATE (a, CurrentBlock^.Size - size);
	     END;

	     a := CurrentBlock;
	     RETURN
	   END;
	 END;

	 IF size < PoolSize THEN

	   (* 3. obtain block from storage pool *)

	   PoolAlloc (a, size);
	 ELSE

	   (* 4. allocate individual block *)
	   IF INTEGER(size) >= 0 THEN
	     BlockPtr := sbrk (size);
	   ELSE
	     BlockPtr := tBlockPtr(NoMoreSpace);
	   END;

	   IF LONGINT (BlockPtr) = NoMoreSpace THEN
	     a := NIL;
	   ELSE
	     a := BlockPtr;
	   END;
	 END;
       END;
   END ALLOCATE;


   PROCEDURE DEALLOCATE (VAR a : ADDRESS; size : CARDINAL);
   (* Frees the area of size 'size' starting at address 'a' *)
   VAR
     BlockPtr    : tBlockPtr;
     ChainNumber : tLargeBlockRange;

   BEGIN
       (* align size to next Alignment boundary: *)
       size := CARDINAL( BITSET(size + (Alignment-1)) - BITSET(Alignment-1) );

       IF size < MinSizeSmallBlock THEN
	 size := MinSizeSmallBlock;
       END;

       BlockPtr := a;
       IF size <= MaxSizeSmallBlock THEN
	 BlockPtr^.Successor := SmallChain [size];
	 SmallChain [size]   := BlockPtr;
       ELSE
	 ChainNumber              := Log2 (size);
	 BlockPtr^.Successor      := LargeChain [ChainNumber];
	 BlockPtr^.Size           := size;
	 LargeChain [ChainNumber] := BlockPtr;
       END;
       a := NIL;
   END DEALLOCATE;


   PROCEDURE PoolAlloc (VAR a : ADDRESS; size: CARDINAL);
   (* Allocates 'size' bytes in the internal      *)
   (* storage pool and returns the start address. *)
   BEGIN
     IF PoolSpaceLeft < size THEN

       (* release old pool *)

       IF PoolSpaceLeft >= MinSizeSmallBlock THEN
	 DEALLOCATE (PoolFreePtr, PoolSpaceLeft);
       END;

       (* allocate new pool *)

       ALLOCATE (PoolFreePtr, PoolSize);

       PoolSpaceLeft := PoolSize;
     END;

     IF PoolFreePtr # NIL THEN
       DEC (PoolSpaceLeft, size);
       INC (PoolFreePtr, size);
       a := PoolFreePtr - size;
     ELSE
       PoolSpaceLeft := 0;
       a := NIL;
     END;
   END PoolAlloc;






   VAR
     i : tSmallBlockRange;
     j : tLargeBlockRange;
BEGIN

      FOR i := MinSizeSmallBlock TO MaxSizeSmallBlock BY 2 DO
	SmallChain [i] := NIL;
      END;
      FOR j := MinSizeLargeBlockLog TO MaxSizeLargeBlockLog DO
	LargeChain [j] := NIL;
      END;
      PoolSpaceLeft := 0;
      NoMoreSpace   := cNoMoreSpace;

END Storage.