(* Copyright (C) 1990, Digital Equipment Corporation           *)
(* All rights reserved.                                        *)
(* See the file COPYRIGHT for a full description.              *)

(* Last modified on Tue Dec 22 16:58:21 PST 1992 by rustan     *)
(*      modified on Fri Sep 18 14:58:21 PDT 1992 by rustan     *)

UNSAFE MODULE RTHeap;

IMPORT RT0, RT0u, RTMisc, Word, Thread, ThreadF, RTStack, RTMemory;
IMPORT Cruntime, System, Processor, IPC, Surrogate;
FROM RT0 IMPORT Typecode;
FROM RTMemory IMPORT MEMORY_Start, MEMORY_End, AddrPerAlign;

(* This module implements the memory management part of the run-time 
   system for Modula-3. Both the TRACED and UNTRACED referents are 
   processed here. 
*)

(*-------------------------------------------------- low-level allocation ---*)

TYPE
  (* NOTE.  It is assumed that the first two fields, i.e., 'size' and
     'typecode', in Header and Descriptor are the same.

     The 'size' field is the number of addressable units in the node,
     including the Header or Descriptor record itself.  'size' is
     invariantly at least MinMemoryNodeSize and a multiple of AddrPerAlign.

     'typecode' is the typecode of the variable stored in the node,
     and is TcFree if the node is free.

     After these two fields the Header and Descriptor records may
     differ in any way (e.g., their sizes are not required to be the same). *)

  (* NOTE.  The following type must be in synch with _refHeader defined in
     M3Runtime.h, except that the latter should be padded to so that it
     is of size HeaderSize.
     Also, the type needs to be in synch with the compiler's TextExpr
     module. *)
  RefHeader = UNTRACED REF Header;
  Header = RECORD
    size: CARDINAL;
    typecode: Typecode;
    gcStatus: GcStatus
  END;
  (* Note, the RecursivelyMarked value in the following type must be in
     synch with the compiler's TextExpr module *)
  GcStatus = { Untraced, NotMarked, Marked, RecursivelyMarked };
  RefDescriptor = UNTRACED REF Descriptor;
  Descriptor = RECORD
    size: CARDINAL;
    typecode: Typecode;  (* always TcFree *)
    nextFree: RefDescriptor (* next memory block on the free list *)
  END;

CONST
  (* HeaderSize is the smallest multiple of AddrPerAlign that is at
     least ADRSIZE( Header ).
     NOTE.  Changing this value will also require a change in M3Runtime.h
     (see comment on RefHeader and Header above). *)
  HeaderSize = (( ADRSIZE( Header ) + AddrPerAlign - 1 ) DIV AddrPerAlign)
               * AddrPerAlign;
  DescriptorSize = ADRSIZE( Descriptor );
  (* MinMemoryNodeSize is the minimum size of memory available in a node.
     This minimum exists so that any used node can be converted into a
     descriptor node at any time. *)
  MinMemoryNodeSize = MAX( HeaderSize,
                           ((DescriptorSize+AddrPerAlign-1) DIV AddrPerAlign)
                           * AddrPerAlign );

  TcFree = LAST( Typecode );

VAR
  (* head of linked list of free memory nodes, sorted in order of increasing
     memory address *)
  freelist: RefDescriptor := NIL;

PROCEDURE InitHeap() =
  (* Called as the first things from RTMain.Run, so this procedure
     cannot depend on anything that can't be statically initialized
     by the C compiler.  This procedure initializes the heap.  After
     this procedure returns, NEW can be called.  Note, though, that
     the garbage collector may not be in place until later during the
     initializations.  Thus, if there's not enough memory for the
     initializations, the garbage collector might not be invoked.
     That is very reasonable, however, since if the initialization
     cannot be carried to completion, then it is not likely that
     there would be enough space for anything else either. *)
  BEGIN
    (* InitHeap can only be called once.  If not called before, then
       freelist = NIL.  (But not necessarily the other way around.)  *)
    <* ASSERT freelist = NIL *>

    (* set up the global memory pointers *)
    RTMemory.Init( GcStackSize DIV ADRSIZE(Word.T));

    IF MEMORY_End - MEMORY_Start < MinMemoryNodeSize THEN
      RTMisc.FatalError( RTMisc.Fault.HeapTooSmall )
    END;

    freelist := MEMORY_Start;
    freelist.size := MEMORY_End - MEMORY_Start;
    <* ASSERT freelist.size MOD AddrPerAlign = 0 *>
    freelist.typecode := TcFree;
    freelist.nextFree := NIL
  END InitHeap;

PROCEDURE GetMem( size: CARDINAL; tc: Typecode ): ADDRESS =
  (* REQUIRES inSystemCritical *)
  (* Returns the address of a memory block of size at least 'size'
     addressable units, and which is to be used as storage for a variable
     with typecode 'tc'. *)
  (* Returns NIL if no memory is available *)
  (* This procedure should be called only by GetMemory. *)
  VAR d: RefDescriptor := freelist;
      back: RefDescriptor := NIL;
      remaining: CARDINAL;
      newDescriptor: RefDescriptor;
      adrSizeRequested := MAX( (( size + AddrPerAlign - 1 )
                                DIV ( AddrPerAlign )) * AddrPerAlign
                               + HeaderSize,
                               MinMemoryNodeSize );
      sizeUsed: CARDINAL;
  BEGIN
    WHILE d # NIL AND d.size < adrSizeRequested DO
      back := d;  d := d.nextFree
    END;
    IF d = NIL THEN (* no memory *) RETURN NIL END;

    (* ASSERT <FORALL d :: d.size MOD AddrPerAlign = 0 AND
                           d.size >= MinMemoryNodeSize>
       (Only one d is actually checked here, and only the first conjunct) *)
    <* ASSERT d.size MOD AddrPerAlign = 0 *>

    remaining := d.size - adrSizeRequested;
    IF remaining >= MinMemoryNodeSize THEN
      (* create new descriptor for the remaining memory *)
      newDescriptor := d + adrSizeRequested;
      newDescriptor.size := remaining;
      newDescriptor.typecode := TcFree;
      newDescriptor.nextFree := d.nextFree;
      IF back = NIL
        THEN freelist := newDescriptor
        ELSE back.nextFree := newDescriptor
      END;
      sizeUsed := adrSizeRequested
    ELSE
      (* not enough room for another descriptor in the remaining memory *)
      IF back = NIL
        THEN freelist := d.nextFree
        ELSE back.nextFree := d.nextFree
      END;
      sizeUsed := d.size
    END;

    WITH h = LOOPHOLE( d, RefHeader ) DO
      h.size := sizeUsed;
      h.typecode := tc;
      IF tc < RT0u.tcAddress
        THEN h.gcStatus := GcStatus.NotMarked
        ELSE h.gcStatus := GcStatus.Untraced
      END
    END;
    RETURN d + HeaderSize
  END GetMem;

PROCEDURE ReturnMem( a: ADDRESS ) =
  (* REQUIRES inSystemCritical *)
  (* Return a memory block that was allocated by a call to GetMem.
     Upon return from this procedure, the location pointed to by
     'a' must not be used. *)
  (* Note, the running time of this procedure is linear in the number
     of free nodes on the heap. *)
  VAR addr: ADDRESS;
      back: RefDescriptor := NIL;
  BEGIN
    addr := a - HeaderSize;
    VAR p := freelist; BEGIN
      WHILE p # NIL AND p < addr DO back := p;  p := p.nextFree END;
      <* ASSERT p # addr *>
    END;
    ReturnMemAux( addr, back )
  END ReturnMem;

PROCEDURE ReturnMemAux( addr: ADDRESS; back: RefDescriptor ) =
  (* REQUIRES inSystemCritical *)
  (* Performs the same function as ReturnMem, except that its
     parameters are different.  Here, 'addr' is the address of
     a Header in the heap, and 'back' is the address of the
     free node preceding 'addr' in order of increasing addresses
     (or NIL, if no free node precedes 'addr'). *)
  VAR size: CARDINAL;
      d: RefDescriptor;
  BEGIN
    size := LOOPHOLE( addr, RefHeader ).size;
    IF back = NIL THEN
      (* there is no previous node; the new node will be the first one
         on the free list *)
      d := addr;
      d.size := size;
      d.typecode := TcFree;
      d.nextFree := freelist;
      freelist := d
    ELSIF back + back.size = addr THEN
      (* merge this node with the previous *)
      d := back;
      INC( d.size, size )
      (* d.nextFree and d.typecode are already set up properly *)
    ELSE
      (* the previous node on the list is not adjacent *)
      d := addr;
      d.size := size;
      d.typecode := TcFree;
      d.nextFree := back.nextFree;
      back.nextFree := d
    END;
    (* check if next node is adjacent *)
    IF d.nextFree # NIL AND d + d.size = d.nextFree THEN
      (* merge this node with the next *)
      WITH next = d.nextFree DO
        INC( d.size, next.size );
        next := next.nextFree
      END
      (* d.typecode is already set up properly *)
    END
  END ReturnMemAux;

PROCEDURE ChangeTypecode( a: ADDRESS; tc: Typecode ) =
  (* REQUIRES inSystemCritical *)
  (* Change the typecode of the referent of 'a' to 'tc', and change the
     storage type accordingly *)
  BEGIN
    WITH h = LOOPHOLE( a - HeaderSize, RefHeader ) DO
      h.typecode := tc;
      IF tc < RT0u.tcAddress
        THEN h.gcStatus := GcStatus.NotMarked
        ELSE h.gcStatus := GcStatus.Untraced
      END
    END
  END ChangeTypecode;

(*-------------------------------------------------- low-level collection ---*)

CONST
  PtrBufferSize = 128;
  GcStackSize = PtrBufferSize * ADRSIZE(ADDRESS) +
                256 * ADRSIZE(Word.T);
  MapEnd = -1;           (* must agree with that defined in compiler/linker *)
  MapArray = -2;         (* must agree with that defined in compiler/linker *)
  MaxMapDepth = 5;
  MaxQSortDepth = 12;

VAR
  needMoreRecursion: BOOLEAN;

PROCEDURE Sort( VAR m: ARRAY [0..PtrBufferSize-1] OF ADDRESS; c: CARDINAL ) =
  (* sorts 'c' elements starting with 0 of 'm' *)
  BEGIN
    QSort( m, c, 0, MaxQSortDepth );
    ISort( m, c )
  END Sort;

PROCEDURE ISort( VAR m: ARRAY [0..PtrBufferSize-1] OF ADDRESS; c: CARDINAL ) =
  (* sorts, using Insertion Sort, 'c' elements starting with 0 of 'm' *)
  VAR a: ADDRESS;
      j: CARDINAL;
  BEGIN
    (* invariant (using the artificial i = c upon termination of the loop):
       SUBARRAY( m, 0, i ) is a sorted  *)
    FOR i := 1 TO c-1 DO
      a := m[i];  j := i;
      (* invariant:  (FORALL k : j < k <= i : a < m[k]) *)
      WHILE j # 0 AND a < m[j-1] DO
        m[j] := m[j-1];  DEC( j )
      END;
      (* invariant AND ( j=0 OR m[j-1] <= a )  ==>
         invariant AND (FORALL k : 0 <= k < j : m[k] <= a) *)
      IF j # i THEN m[j] := a END  (* j = i ==> j # 0 AND m[j] <= a *)
    END
  END ISort;

PROCEDURE QSort( VAR m: ARRAY [0..PtrBufferSize-1] OF ADDRESS;
                 c: CARDINAL; s: CARDINAL; depth: CARDINAL ) =
  (* May sort, using QuickSort, 'c' elements starting with 's' of 'm'.
     In any case, 'm' returns as a permutation of what it was passed in as. *)
  BEGIN
    WHILE c > 2 DO
      (* invoke the Dutch Flag program, using "<white" as red, ">white"
         as blue. *)
      VAR white := m[ s + (c DIV 2) ];
          w, k: CARDINAL := s;
          b: CARDINAL := s + c;
      BEGIN
        WHILE k # b DO
          IF      m[k] < white THEN  (* m[k] = red *)
            VAR t := m[k]; BEGIN m[k] := m[w];  m[w] := t END;
            INC( w );  INC( k )
          ELSIF   m[k] > white THEN  (* m[k] = blue *)
            DEC( b );
            VAR t := m[k]; BEGIN m[k] := m[b];  m[b] := t END
          ELSE                       (* m[k] = white *)
            INC( k )
          END
        END;
        <* ASSERT w # b *>
        IF w-s >= s+c-b THEN
          IF depth # 0 THEN QSort( m, s+c-b, b, depth-1 ) END;
          c := w-s
        ELSE
          IF depth # 0 THEN QSort( m, w-s, s, depth-1 ) END;
          c := s+c-b;  s := b
        END
      END
    END
  END QSort;

PROCEDURE Map( a: ADDRESS; p: UNTRACED REF INTEGER; depth: CARDINAL ):
    UNTRACED REF INTEGER =
  (* REQUIRES inSystemCritical *)
  (* 'p' is a pointer to a tracedOffsets encoding (ending with a
     MapEnd code) for the address 'a'.  (Note, 'a' need not necessarily
     be the pointer to the beginning of an object.)
     This procedure returns a pointer to the first code after the one
     looked at.
     'depth' indicates the number of levels of references that may be
     recursively marked. *)
  VAR c: INTEGER;
  BEGIN
    WHILE p^ # MapEnd DO
      c := p^;  INC( p, ADRSIZE(INTEGER));
      IF c >= 0 THEN
        WITH aa = LOOPHOLE( a+c, UNTRACED REF ADDRESS )^ DO
          IF aa # NIL THEN Mark( aa, depth ) END
        END
      ELSIF c = MapArray THEN
        VAR aa: ADDRESS := a + p^;
            n: CARDINAL := LOOPHOLE( p+ADRSIZE(INTEGER),
                                     UNTRACED REF INTEGER )^;
            s: CARDINAL := LOOPHOLE( p+2*ADRSIZE(INTEGER),
                                     UNTRACED REF INTEGER )^;
            pNext: UNTRACED REF INTEGER;
        BEGIN
          <* ASSERT n # 0 *>
          INC( p, 3*ADRSIZE(INTEGER));
          FOR i := 0 TO n-1 DO
            pNext := Map( aa + i*s, p, depth )
          END;
          p := pNext
        END
      ELSE
        <* ASSERT FALSE *>
      END
    END;
    RETURN p + ADRSIZE(INTEGER)
  END Map;

PROCEDURE Mark( a: ADDRESS; depth: CARDINAL ) =
  (* REQUIRES inSystemCritical *)
  (* REQUIRES 'a' is a pointer to a traced variable in the heap *)
  (* Mark the header of 'a' and recursively mark the headers of all
     variables to which 'a' contains a pointer.
     'depth' indicates the number of levels of references that may be
     recursively marked. *)
  TYPE LOTS = [0..9999];
  VAR h: RefHeader := a - HeaderSize;
  BEGIN
    <* ASSERT h.gcStatus # GcStatus.Untraced *>
    IF h.gcStatus # GcStatus.RecursivelyMarked THEN
      IF depth = 0 THEN
        h.gcStatus := GcStatus.Marked;
        needMoreRecursion := TRUE;
        RETURN
      END;
      h.gcStatus := GcStatus.RecursivelyMarked;
      VAR def: RT0.TypeDefinition := RT0u.types[ h.typecode ]; BEGIN
        IF def.nDimensions # 0 THEN

          (* open array *)
          (* ASSERT def.parent.typecode = TYPECODE( REFANY )  , that is: *)
          <* ASSERT def.parent.parent = NIL *> (* since 'a' is traced *)
          IF def.tracedOffsets # NIL THEN
            VAR n: CARDINAL := 1; BEGIN
              WITH s = LOOPHOLE( a+ADRSIZE(ADDRESS),
                                 UNTRACED REF ARRAY LOTS OF INTEGER )
              DO
                FOR i := 0 TO def.nDimensions-1 DO n := n * s[i] END
              END;

              WITH aa = a + def.dataSize, d = depth - 1 DO
                FOR i := 0 TO n-1 DO
                  EVAL Map( aa + i*def.elementSize, def.tracedOffsets, d )
                END
              END
            END
          END

        ELSIF def.remoteMethods = NIL OR
              LOOPHOLE( a, NETWORK ).pid = Processor.ID()
        THEN
          (* not a network object, or a local network object, i.e., not
             a remote network object *)
          WHILE def # NIL DO
            IF def.tracedOffsets # NIL THEN
              EVAL Map( a, def.tracedOffsets, depth-1 )
            END;
            def := def.parent
          END

        END
      END
    END
  END Mark;

PROCEDURE MarkThrough() =
  (* REQUIRES inSystemCritical *)
  (* call Mark on all nodes in the heap whose gcStatus is Marked *)
  VAR h: RefHeader;
  BEGIN
    LOOP
      needMoreRecursion := FALSE;
      h := MEMORY_Start;
      WHILE h < MEMORY_End DO
        IF h.typecode < RT0u.tcAddress AND h.gcStatus = GcStatus.Marked THEN
          Mark( h + HeaderSize, MaxMapDepth )
        END;
        INC( h, h.size )
      END;
      IF NOT needMoreRecursion THEN EXIT END
    END
  END MarkThrough;

PROCEDURE MarkFromStacks() =
  (* REQUIRES inSystemCritical *)
  (* REQUIRES the running thread is the garbage collector *)
  (* Marks (does not recursively mark) traced variables for which
     there exists a potential reference to in a stack.  A word
     on the stack is assumed to be a reference to a variable if
     it contains the value of any of the addresses occupied by
     the variable.  Since this procedure does not recursively
     mark (to conserve stack space, as this procedure puts a
     large array on its stack) the variables, procedure MarkThrough
     needs to be run after this procedure's completion. *)

  PROCEDURE Process() =
    (* REQUIRES inSystemCritical *)
    (* REQUIRES first 'c' elements of array 'm' to be sorted *)
    (* 'c' specified the number of elements in 'm' *)
    VAR addr: ADDRESS := NIL;
        h: RefHeader := MEMORY_Start;
    BEGIN
      FOR i := 0 TO c-1 DO
        IF m[i] # addr THEN
          addr := m[i];
          VAR p: RefHeader := h + h.size; BEGIN
            WHILE p <= addr DO h := p;  INC( p, p.size ) END
          END;
          <* ASSERT h <= addr AND addr < h + h.size *>
          IF h.typecode < RT0u.tcAddress AND h + HeaderSize <= addr THEN
            h.gcStatus := GcStatus.Marked
          END
        END
      END
    END Process;

  VAR resumeKey: RTStack.ResumeKey;
      low, high, regLow, regHigh, addr: UNTRACED REF Word.T;
      c: CARDINAL;  (* number of used elements in 'm' *)
      m: ARRAY [ 0..PtrBufferSize-1 ] OF ADDRESS;
  VAR (* CONST *)
      memStart: ADDRESS := MEMORY_Start + HeaderSize;
      memEnd: ADDRESS := MEMORY_End;
  BEGIN
    WHILE RTStack.GetBounds( resumeKey, low, high, regLow, regHigh ) DO
      c := 0;
      addr := low;
      LOOP
        WITH a = LOOPHOLE( addr, UNTRACED REF ADDRESS )^ DO
          IF memStart <= a AND a < memEnd THEN
            m[c] := a;  INC( c );
            IF c = NUMBER( m ) THEN
              Sort( m, c );  Process();
              c := 0
            END
          END
        END;
        IF addr = high THEN
          addr := regLow
        ELSIF addr = regHigh THEN
          EXIT
        ELSE
          addr := addr + ADRSIZE( Word.T )
        END
      END;
      IF c # 0 THEN
        Sort( m, c );  Process()
      END
    END
  END MarkFromStacks;

PROCEDURE MarkFromGlobals() =
  (* REQUIRES inSystemCritical *)
  (* marks all traced variables referenced by globals *)
  VAR pair: UNTRACED REF RT0.GlobalPair;
  BEGIN
    FOR i := 0 TO RT0u.nModules - 1 DO
      pair := RT0u.modules[i].globals;
      IF pair # NIL THEN
        WHILE pair.addr # NIL DO
          <* ASSERT pair.tracedOffsets # NIL *>
          EVAL Map( pair.addr, pair.tracedOffsets, 0 );
          INC( pair, ADRSIZE(RT0.GlobalPair))
        END
      END
    END
  END MarkFromGlobals;

PROCEDURE MarkFromNetworkObjects() =
  (* REQUIRES inSystemCritical *)
  (* mark all network objects with positive reference count *)
  VAR h: RefHeader := MEMORY_Start;
      networkBegin := RT0u.types[ TYPECODE( NETWORK ) ].typecode;
      networkEnd := RT0u.types[ TYPECODE( NETWORK ) ].lastSubTypeTC;
      pid := Processor.ID();
  BEGIN
    WHILE h < MEMORY_End DO
      IF networkBegin <= h.typecode AND h.typecode <= networkEnd THEN
        WITH net = LOOPHOLE( h + HeaderSize, NETWORK ) DO
          IF net.pid = pid AND net.refcount # 0 THEN
            h.gcStatus := GcStatus.Marked
          END
        END
      END;
      INC( h, h.size )
    END
  END MarkFromNetworkObjects; 

PROCEDURE RecycleGarbage(): BOOLEAN =
  (* REQUIRES inSystemCritical *)
  (* Recycles all nodes in the heap whose gcStatus is NotMarked, by
     putting them onto the free list.  Sets the gcStatus of all marked
     nodes back to NotMarked.  Returns TRUE if any memory was
     recycled, and FALSE otherwise. *)
  VAR h: RefHeader := MEMORY_Start;
      back: RefDescriptor := NIL; (* INVARIANT: back = NIL OR
                                         back is a node on the free list *)
      recycledAny: BOOLEAN := FALSE;
      networkBegin := RT0u.types[ TYPECODE( NETWORK ) ].typecode;
      networkEnd := RT0u.types[ TYPECODE( NETWORK ) ].lastSubTypeTC;
      pid := Processor.ID();
      returnMemory: BOOLEAN;
  BEGIN
    WHILE h < MEMORY_End DO
      IF h.typecode < RT0u.tcAddress THEN
        IF h.gcStatus = GcStatus.NotMarked THEN
          IF networkBegin <= h.typecode AND h.typecode <= networkEnd AND
             LOOPHOLE( h + HeaderSize, NETWORK ).pid # pid
          THEN
            VAR sur: IPC.Surrogate := h + HeaderSize; BEGIN
              ChangeTypecode( sur, TYPECODE( IPC.Surrogate ));
              Surrogate.Remove( sur.gid.pid, sur.gid.id );
              returnMemory := IPC.EnqueueSurrogate( sur )
            END
          ELSE
            returnMemory := TRUE
          END;
          IF returnMemory THEN
            VAR p: RefDescriptor; BEGIN
              IF back = NIL THEN p := freelist ELSE p := back.nextFree END;
              WHILE p # NIL AND p < h DO back := p;  p := p.nextFree END
            END;
            ReturnMemAux( h, back )
          END;
          recycledAny := TRUE
        ELSE
          <* ASSERT h.gcStatus = GcStatus.RecursivelyMarked *>
          h.gcStatus := GcStatus.NotMarked
        END
      END;
      (* Note, h.size on the next line may be different than it was before
         the above call to ReturnMemAux. *)
      INC( h, h.size )
    END;
    RETURN recycledAny
  END RecycleGarbage;

(*------------------------------------------------------------ collection ---*)

PROCEDURE Collect() =
  (* REQUIRES System.inSystemCritical *)
  (* This is the Garbage collector closure.  It is invoked by calling
     ThreadF.InvokeGarbageCollector().  *)
  BEGIN
    <* ASSERT Thread.Self() = ThreadF.gcThread AND
              System.InSystemCritical() *>
    LOOP
      INC( LOOPHOLE( 5000, UNTRACED REF INTEGER )^ );  (* for statistics *)
      (* ASSERT <FORALL h : h is a header of an allocated heap item :
                 h.gcStatus IN { Untraced, NotMarked }> *)
      MarkFromStacks();
      MarkFromNetworkObjects();
      MarkFromGlobals();
      (* ASSERT <FORALL h : h is a header of an allocated heap item :
                 h.gcStatus IN { Untraced, NotMarked, Marked }> *)
      MarkThrough();
      (* ASSERT <FORALL h : h is a header of an allocated heap item :
                 h.gcStatus IN { Untraced, NotMarked, RecursivelyMarked }> *)
      IF RecycleGarbage() THEN
        (* schedule all waiting threads *)
        ThreadF.Schedule( ThreadF.waitingForSpace );
        ThreadF.waitingForSpace := NIL
      END;
      INC( LOOPHOLE( 5001, UNTRACED REF INTEGER )^ );  (* for statistics *)
      ThreadF.YieldFromCollector()
    END
  END Collect;

(*------------------------------------------------------------ allocation ---*)

PROCEDURE GetMemory( size: CARDINAL; tc: Typecode ): ADDRESS =
  (* REQUIRES NOT System.inSystemCritical *)
  (* Returns the address of a memory block of size at least 'size'
     addressable units, and which is to be used as storage for a variable
     with typecode 'tc'. *)
  (* Always returns a non-NIL value.  If no memory is available, this
     procedure does not return. *)
  (* All procedures below should call this procedure rather than the
     lower-level GetMem, since it is this procedure that properly
     handles memory failures. *)
  VAR res: ADDRESS;
  BEGIN
    System.EnterSystemCritical();
    INC( LOOPHOLE( 4999, UNTRACED REF INTEGER )^ );  (* BUG *)
      res := GetMem( size, tc );
      IF res = NIL THEN
        IF ThreadF.gcThread # NIL THEN
          ThreadF.InvokeGarbageCollector();
          res := GetMem( size, tc )
          (* CODEWORK.  Consider suspending the calling thread
             here, but be careful about initializations, that is,
             checking ThreadF.gcThread. *)
        END;
        IF res = NIL THEN
          RTMisc.FatalError( RTMisc.Fault.OutOfMemory )
        END
      END;
    System.ExitSystemCritical();
    RETURN res
  END GetMemory;

PROCEDURE Allocate( def: RT0.TypeDefinition ): ADDRESS =
  (* REQUIRES NOT inSystemCritical *)
  VAR res: ADDRESS;
      tc: Typecode := def.typecode;
  BEGIN
    res := GetMemory( def.dataSize, tc );

    Cruntime.bzero( res, def.dataSize );
      
    IF def.defaultMethods # NIL THEN
      LOOPHOLE( res, UNTRACED REF ADDRESS )^ := def.defaultMethods
    END;

    WHILE def # NIL DO
      IF def.initProc # NIL THEN def.initProc( res ) END;
      def := def.parent
    END;

    WITH netDef = RT0u.types[ TYPECODE( NETWORK ) ] DO
      IF netDef.typecode <= tc AND tc <= netDef.lastSubTypeTC THEN
        LOOPHOLE( res, NETWORK ).pid := Processor.ID()
      END
    END;

    RETURN res
  END Allocate;

PROCEDURE AllocateOpenArray( def: RT0.TypeDefinition;
                             READONLY s: ARRAY OF INTEGER ): ADDRESS =
  (* REQUIRES NOT inSystemCritical *)
  VAR elemsChars: CARDINAL;
      res: ADDRESS;
  BEGIN
    WITH n = def.nDimensions DO <* ASSERT n # 0 AND n = NUMBER(s) *> END;
    VAR nbElems: CARDINAL := 1; BEGIN
      FOR i := 0 TO def.nDimensions - 1 DO
        IF s[i] < 0 THEN
          (* a programmer used a negative value as a parameter to NEW *)
          RTMisc.FatalError( RTMisc.Fault.NegativeArraySize )
        END;
        nbElems := s[i] * nbElems
      END;
      elemsChars := nbElems * def.elementSize
    END;

    res := GetMemory( def.dataSize + elemsChars, def.typecode );

    LOOPHOLE( res, UNTRACED REF ADDRESS )^ := res + def.dataSize;
 
    WITH base = res + ADRSIZE(ADDRESS) DO
      FOR i := 0 TO def.nDimensions - 1 DO
        LOOPHOLE( base + i * ADRSIZE(INTEGER), UNTRACED REF INTEGER )^ := s[i]
      END
    END;
    Cruntime.bzero( res + def.dataSize, elemsChars );

    IF def.initProc # NIL THEN def.initProc( res ) END;
    (* ASSERT def.parent.typecode = TYPECODE( REFANY ) OR
              def.parent.typecode = TYPECODE( ADDRESS )   , that is: *)
    <* ASSERT def.parent.parent = NIL *>

    RETURN res
  END AllocateOpenArray;

PROCEDURE AllocateSurrogate( def: RT0.TypeDefinition;
                             sur: ADDRESS (* IPC.Surrogate *) ): ADDRESS =
  (* REQUIRES inSystemCritical *)
  (* make 'sur' into a surrogate for a concrete network object with global ID
     ('sur.pid','sur.id') and whose type definition is specified by 'def' *)
  (* the 'sur' parameter should be passed in as:
     NEW( IPC.Surrogate, gid := IPC.GlobalID{ pid := pid, id := id } ) *)
  BEGIN
    <* ASSERT System.InSystemCritical() AND
       sur # NIL AND def.remoteMethods # NIL *>
    ChangeTypecode( sur, def.typecode );
    LOOPHOLE( sur, UNTRACED REF ADDRESS )^ := def.remoteMethods;
    RETURN sur
  END AllocateSurrogate;

PROCEDURE AllocateBindings( def: RT0.TypeDefinition;
                            destPid: INTEGER ): ADDRESS =
  (* REQUIRES NOT inSystemCritical *)
  (* only to be called on network object types *)
  (* do compiletime assert that ADRSIZE( IPC.Header ) is positive *)
  CONST HeaderSize = ADRSIZE( IPC.Header );
  VAR a: UNTRACED REF ARRAY OF Word.T := NIL;
      res: ADDRESS := NIL;
      pid := Processor.ID();
  BEGIN
    <* ASSERT def.remoteMethods # NIL *>
    IF destPid = pid THEN RETURN Allocate( def ) END;

    a := NEW( UNTRACED REF ARRAY OF Word.T, HeaderSize + def.dataSize );
    (* the array is initialized by all 0's *)

    a[ HeaderSize - 1 ] := LOOPHOLE( a, Word.T );
    res := ADR( a[ HeaderSize ] );

    <* ASSERT def.defaultMethods # NIL *>
    LOOPHOLE( res, UNTRACED REF ADDRESS )^ := def.defaultMethods;

    WHILE def # NIL DO
      IF def.initProc # NIL THEN def.initProc( res ) END;
      def := def.parent
    END;

    LOOPHOLE( res, NETWORK ).pid := pid;

    RETURN res
  END AllocateBindings;

(*------------------------------------------------------------- disposals ---*)

PROCEDURE DisposeTraced( VAR r: REFANY ) =
  BEGIN
    r := NIL;
  END DisposeTraced;

PROCEDURE DisposeUntraced( VAR a: ADDRESS ) =
  (* REQUIRES NOT inSystemCritical *)
  BEGIN
    IF a # NIL THEN
      System.EnterSystemCritical();
        ReturnMem( a );
        a := NIL;
      System.ExitSystemCritical()
    END
  END DisposeUntraced;

PROCEDURE BackdoorDisposeUntraced( VAR a: ADDRESS ) =
  (* REQUIRES inSystemCritical AND Thread.Self() # ThreadF.gcThread *)
  BEGIN
    <* ASSERT System.InSystemCritical() AND Thread.Self() # ThreadF.gcThread *>
    IF a # NIL THEN
      ReturnMem( a );
      a := NIL
    END
  END BackdoorDisposeUntraced;

(*------------------------------------------------------------- debugging ---*)

(***********************************************************************
PROCEDURE DumpHeap( detail: BOOLEAN := TRUE ) =
  CONST GcS = ARRAY GcStatus OF TEXT { "Untraced", "Not Marked",
                                       "Marked", "Recursively Marked" };
  VAR h: RefHeader := MEMORY_Start;
  BEGIN
    PutText( "\n-----  Heap  -----\n" );
    WHILE h < MEMORY_End DO
      PutText( "Address: " );  PutAddr( h );
      PutText( "   " );
      PutText( "Size: " );  PutInt( h.size );  PutText( "   " );
      IF h.typecode = TcFree THEN
        PutText( "FREE\n" )
      ELSE
        PutText( "Typecode: " );  PutInt( h.typecode );  PutText( "   " );
        PutText( "GcStatus: " );  PutText( GcS[ h.gcStatus ] );
        IF detail THEN
          <* ASSERT h.size MOD AddrPerAlign = 0 *>
          <* ASSERT h.size >= HeaderSize *>
          <* ASSERT h.size >= MinMemoryNodeSize *>
          FOR i := 0 TO ((h.size - HeaderSize) DIV ADRSIZE(Word.T)) - 1 DO
            IF i MOD 8 = 0 THEN PutText( "\n" ) END;
            PutText( "    " );
            PutInt( LOOPHOLE( h+HeaderSize+i*ADRSIZE(Word.T),
                              UNTRACED REF Word.T )^ )
          END
        END;
        PutText( "\n" )
      END;
      INC( h, h.size )
    END
  END DumpHeap;

PROCEDURE DumpFreeList() =
  VAR d: RefDescriptor := freelist;
  BEGIN
    PutText( "\n-----  Free list  -----\n" );
    WHILE d # NIL DO
      PutText( "Address: " );  PutAddr( d );
      PutText( "   " );
      PutText( "Size: " );  PutInt( d.size );
      IF d.typecode # TcFree THEN
        PutText( "   " );  PutText( "Typecode: " );  PutInt( d.typecode )
      END;
      PutText( "\n" );
      <* ASSERT d.size >= MinMemoryNodeSize *>
      <* ASSERT d.nextFree = NIL OR d < d.nextFree *>
      d := d.nextFree
    END
  END DumpFreeList;
***********************************************************************)

(*---------------------------------------------------------------------------*)

BEGIN
END RTHeap.