m3core/src/runtime/common/RTAllocator.m3


 Copyright (C) 1993, Digital Equipment Corporation         
 All rights reserved.                                      
 See the file COPYRIGHT for a full description.            
                                                           
  Portions Copyright 1996-2000, Critical Mass, Inc.        
 See file COPYRIGHT-CMASS for details.                     
                                                           
| Last modified on Thu May  4 14:02:27 PDT 1995 by kalsow  
|      modified on Wed Jun  2 15:00:17 PDT 1993 by muller  
|      modified on Wed Apr 21 13:14:37 PDT 1993 by mcjones 
|      modified on Wed Mar 10 11:01:47 PST 1993 by mjordan 
|      modified on Tue Mar  9 08:45:18 PST 1993 by jdd     

UNSAFE MODULE RTAllocator
EXPORTS RTAllocator, RTAllocCnts, RTHooks, RTHeapRep;

IMPORT Cstdlib, RT0, RTMisc, RTOS, RTType, Scheduler, RTThread;
IMPORT RuntimeError AS RTE, Word;
FROM RTType IMPORT Typecode;
In the following procedures, RTType.Get(tc) will fail if tc is not proper.

TYPE
  TK = RT0.TypeKind;
----------------------------------------------------------- RTAllocator ---

PROCEDURE NewTraced(tc: Typecode): REFANY
  RAISES {OutOfMemory} =
  VAR res := GetTraced(RTType.Get(tc));
  BEGIN
    IF (res = NIL) THEN RAISE OutOfMemory; END;
    RETURN res;
  END NewTraced;

PROCEDURE NewUntraced(tc: Typecode): ADDRESS
  RAISES {OutOfMemory} =
  VAR res := GetUntracedRef(RTType.Get(tc));
  BEGIN
    IF (res = NIL) THEN RAISE OutOfMemory; END;
    RETURN res;
  END NewUntraced;

PROCEDURE NewUntracedObject(tc: Typecode): UNTRACED ROOT
  RAISES {OutOfMemory} =
  VAR res := GetUntracedObj(RTType.Get(tc));
  BEGIN
    IF (res = NIL) THEN RAISE OutOfMemory; END;
    RETURN res;
  END NewUntracedObject;

PROCEDURE NewTracedArray(tc: Typecode; READONLY s: Shape): REFANY
  RAISES {OutOfMemory} =
  VAR res := GetOpenArray(RTType.Get(tc), s);
  BEGIN
    IF (res = NIL) THEN RAISE OutOfMemory; END;
    RETURN res;
  END NewTracedArray;

PROCEDURE NewUntracedArray(tc: Typecode; READONLY s: Shape): ADDRESS
  RAISES {OutOfMemory} =
  VAR res := GetUntracedOpenArray(RTType.Get(tc), s);
  BEGIN
    IF (res = NIL) THEN RAISE OutOfMemory; END;
    RETURN res;
  END NewUntracedArray;

PROCEDURE Clone (ref: REFANY): REFANY
  RAISES {OutOfMemory} =
  VAR
    hdr: RefHeader;  def: RT0.TypeDefn;  dataSize: CARDINAL;
    res: ADDRESS;
    thread := RTThread.MyHeapState();
  BEGIN
    IF (ref = NIL) THEN RETURN NIL; END;
    IF Word.And(LOOPHOLE(ref, Word.T), 1) # 0 THEN RETURN ref; END;

    hdr := LOOPHOLE(ref, ADDRESS) - ADRSIZE(Header);
    def := RTType.Get(hdr.typecode);
    dataSize := ReferentSize(hdr);

    INC(thread.inCritical);
    res := AllocTraced(dataSize, def.dataAlignment, thread^);
    IF res = NIL THEN DEC(thread.inCritical); RAISE OutOfMemory; END;
    RTMisc.Copy(LOOPHOLE(ref, ADDRESS), res, dataSize);
    IF def.kind = ORD (TK.Array) THEN
      (* open array: update the internal pointer *)
      LOOPHOLE(res, UNTRACED REF ADDRESS)^ := res + def.dataSize;
    END;
    DEC(thread.inCritical);

    IF countsOn THEN
      IF def.kind = ORD (TK.Array)
        THEN BumpSize(def.typecode, dataSize)
        ELSE BumpCnt (def.typecode);
      END;
    END;
    IF (callback # NIL) THEN callback (LOOPHOLE(res, REFANY)) END;
    RETURN LOOPHOLE(res, REFANY);
  END Clone;
--------------------------------------------------------------- RTHooks ---

PROCEDURE Allocate (defn: ADDRESS): REFANY =
  VAR res := GetTraced(defn);
  BEGIN
    IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END;
    RETURN res;
  END Allocate;

PROCEDURE AllocateTracedRef (defn: ADDRESS): REFANY =
  VAR res := GetTracedRef(defn);
  BEGIN
    IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END;
    RETURN res;
  END AllocateTracedRef;

PROCEDURE AllocateTracedObj (defn: ADDRESS): ROOT =
  VAR res := GetTracedObj(defn);
  BEGIN
    IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END;
    RETURN res;
  END AllocateTracedObj;

PROCEDURE AllocateUntracedRef (defn: ADDRESS): ADDRESS =
  VAR res := GetUntracedRef(defn);
  BEGIN
    IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END;
    RETURN res;
  END AllocateUntracedRef;

PROCEDURE AllocateUntracedObj (defn: ADDRESS): UNTRACED ROOT =
  VAR res := GetUntracedObj(defn);
  BEGIN
    IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END;
    RETURN res;
  END AllocateUntracedObj;

PROCEDURE AllocateOpenArray (defn: ADDRESS; READONLY s: Shape): REFANY =
  VAR res := GetOpenArray(defn, s);
  BEGIN
    IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END;
    RETURN res;
  END AllocateOpenArray;

PROCEDURE AllocateUntracedOpenArray (defn : ADDRESS;
                                     READONLY s: Shape): ADDRESS =
  VAR res := GetUntracedOpenArray(defn, s);
  BEGIN
    IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END;
    RETURN res;
  END AllocateUntracedOpenArray;

PROCEDURE DisposeUntracedRef (VAR a: ADDRESS) =
  BEGIN
    IF a # NIL THEN
      Scheduler.DisableSwitching();
      Cstdlib.free(a);
      a := NIL;
      Scheduler.EnableSwitching();
    END;
  END DisposeUntracedRef;

PROCEDURE DisposeUntracedObj (VAR a: UNTRACED ROOT) =
  VAR def: RT0.TypeDefn;
  BEGIN
    IF a # NIL THEN
      Scheduler.DisableSwitching();
      def := RTType.Get (TYPECODE (a));
      Cstdlib.free (a - MAX(BYTESIZE(Header), def.dataAlignment));
      a := NIL;
      Scheduler.EnableSwitching();
    END;
  END DisposeUntracedObj;
-------------------------------------------------------------- internal ---

PROCEDURE GetTraced (def: RT0.TypeDefn): REFANY =
  BEGIN
    CASE def.kind OF
    | ORD(TK.Ref) => RETURN GetTracedRef(def);
    | ORD(TK.Obj) => RETURN GetTracedObj(def);
    ELSE
      RTE.Raise(RTE.T.ValueOutOfRange);
    END;
    RETURN NIL;
  END GetTraced;

PROCEDURE GetTracedRef (def: RT0.TypeDefn): REFANY =
  VAR
    res: ADDRESS;
    thread := RTThread.MyHeapState();
  BEGIN
    IF def.typecode = 0 OR def.traced # 1 OR def.kind # ORD(TK.Ref) THEN
      RTE.Raise(RTE.T.ValueOutOfRange);
    END;

    INC(thread.inCritical);
    res := AllocTraced(def.dataSize, def.dataAlignment, thread^);
    IF res = NIL THEN DEC(thread.inCritical); RETURN NIL; END;
    LOOPHOLE(res - ADRSIZE(Header), RefHeader)^ :=
        Header{typecode := def.typecode, dirty := TRUE};
    IF def.initProc # NIL THEN def.initProc(res) END;
    DEC(thread.inCritical);

    IF countsOn THEN BumpCnt(def.typecode) END;
    IF (callback # NIL) THEN callback (LOOPHOLE(res, REFANY)) END;
    RETURN LOOPHOLE(res, REFANY);
  END GetTracedRef;

PROCEDURE GetTracedObj (def: RT0.TypeDefn): ROOT =
  VAR
    res: ADDRESS;
    thread := RTThread.MyHeapState();
  BEGIN
    IF def.typecode = 0 OR def.traced # 1 OR def.kind # ORD(TK.Obj) THEN
      RTE.Raise(RTE.T.ValueOutOfRange);
    END;

    INC(thread.inCritical);
    res := AllocTraced(def.dataSize, def.dataAlignment, thread^);
    IF res = NIL THEN DEC(thread.inCritical); RETURN NIL; END;
    LOOPHOLE(res - ADRSIZE(Header), RefHeader)^ :=
        Header{typecode := def.typecode, dirty := TRUE};
    InitObj (res, LOOPHOLE(def, RT0.ObjectTypeDefn));
    DEC(thread.inCritical);

    IF countsOn THEN BumpCnt(def.typecode) END;
    IF (callback # NIL) THEN callback (LOOPHOLE(res, REFANY)) END;
    RETURN LOOPHOLE(res, REFANY);
  END GetTracedObj;

PROCEDURE GetUntracedRef (def: RT0.TypeDefn): ADDRESS =
  VAR res : ADDRESS;
  BEGIN
    IF def.typecode = 0 OR def.traced # 0 OR def.kind # ORD(TK.Ref) THEN
      RTE.Raise(RTE.T.ValueOutOfRange);
    END;
    Scheduler.DisableSwitching();
    res := Cstdlib.calloc(1, def.dataSize);
    Scheduler.EnableSwitching();
    IF res = NIL THEN RETURN NIL END;
    IF def.initProc # NIL THEN def.initProc(res); END;
    IF countsOn THEN BumpCnt(def.typecode) END;
    RETURN res;
  END GetUntracedRef;

PROCEDURE GetUntracedObj (def: RT0.TypeDefn): UNTRACED ROOT =
  (* NOTE: result requires special treatment by DisposeUntracedObj *)
  VAR
    hdrSize := MAX(BYTESIZE(Header), def.dataAlignment);
    res     : ADDRESS;
  BEGIN
    IF def.typecode = 0 OR def.traced # 0 OR def.kind # ORD(TK.Obj) THEN
      RTE.Raise(RTE.T.ValueOutOfRange);
    END;
    Scheduler.DisableSwitching();
    res := Cstdlib.malloc(hdrSize + def.dataSize);
    Scheduler.EnableSwitching();
    IF res = NIL THEN RETURN NIL END;
    res := res + hdrSize;
    LOOPHOLE(res - ADRSIZE(Header), RefHeader)^ :=
        Header{typecode := def.typecode};
    InitObj (res, LOOPHOLE(def, RT0.ObjectTypeDefn));
    IF countsOn THEN BumpCnt (def.typecode) END;
    RETURN res;
  END GetUntracedObj;

PROCEDURE InitObj (res: ADDRESS;  def: RT0.ObjectTypeDefn) =
  BEGIN
    LOOPHOLE(res, UNTRACED REF ADDRESS)^ := def.defaultMethods;
    WHILE def # NIL DO
      IF def.common.initProc # NIL THEN def.common.initProc(res); END;
      IF def.common.kind # ORD (TK.Obj) THEN EXIT; END;
      def := LOOPHOLE (def.parent, RT0.ObjectTypeDefn);
    END;
  END InitObj;

PROCEDURE GetOpenArray (def: RT0.TypeDefn; READONLY s: Shape): REFANY =
  VAR
    res: ADDRESS;
    dataSize: CARDINAL;
    thread := RTThread.MyHeapState();
  BEGIN
    IF def.typecode = 0 OR def.traced # 1 OR def.kind # ORD(TK.Array) THEN
      RTE.Raise(RTE.T.ValueOutOfRange);
    END;
    dataSize := ArraySize(LOOPHOLE(def, RT0.ArrayTypeDefn), s);

    INC(thread.inCritical);
    res := AllocTraced(dataSize, def.dataAlignment, thread^);
    IF res = NIL THEN DEC(thread.inCritical); RETURN NIL; END;
    LOOPHOLE(res - ADRSIZE(Header), RefHeader)^ :=
        Header{typecode := def.typecode, dirty := TRUE};
    InitArray (res, LOOPHOLE(def, RT0.ArrayTypeDefn), s);
    DEC(thread.inCritical);

    IF countsOn THEN BumpSize (def.typecode, dataSize) END;
    IF (callback # NIL) THEN callback (LOOPHOLE(res, REFANY)) END;
    RETURN LOOPHOLE(res, REFANY);
  END GetOpenArray;

PROCEDURE GetUntracedOpenArray (def: RT0.TypeDefn; READONLY s: Shape): ADDRESS =
  VAR
    res : ADDRESS;
    dataSize: CARDINAL;
  BEGIN
    IF def.typecode = 0 OR def.traced # 0 OR def.kind # ORD(TK.Array) THEN
      RTE.Raise(RTE.T.ValueOutOfRange);
    END;
    dataSize := ArraySize(LOOPHOLE(def, RT0.ArrayTypeDefn), s);

    Scheduler.DisableSwitching();
    res := Cstdlib.calloc(1, dataSize);
    Scheduler.EnableSwitching();
    IF res = NIL THEN RETURN NIL END;
    InitArray (res, LOOPHOLE(def, RT0.ArrayTypeDefn), s);

    IF countsOn THEN BumpSize (def.typecode, dataSize) END;
    RETURN res;
  END GetUntracedOpenArray;

PROCEDURE InitArray (res: ADDRESS; def: RT0.ArrayTypeDefn; READONLY s: Shape) =
  BEGIN
    WITH data_start = res + def.common.dataSize DO
      LOOPHOLE(res, UNTRACED REF ADDRESS)^ := data_start;
    END;
    FOR i := 0 TO NUMBER(s) - 1 DO
      LOOPHOLE(res + ADRSIZE(ADDRESS) + i * ADRSIZE(INTEGER),
               UNTRACED REF INTEGER)^ := s[i];
    END;
    IF def.common.initProc # NIL THEN def.common.initProc(res) END;
  END InitArray;

PROCEDURE ArraySize (def: RT0.ArrayTypeDefn;  READONLY s: Shape): CARDINAL =
  VAR n_elts := 1;  c: CARDINAL;
  BEGIN
    FOR i := 0 TO NUMBER(s) - 1 DO
      c := s[i];  (* force a range check *)
      n_elts := c * n_elts;
    END;
    RETURN RTMisc.Upper(def.common.dataSize + def.elementSize * n_elts,
                        BYTESIZE(Header));
  END ArraySize;

PROCEDURE AllocTraced (dataSize, dataAlignment: CARDINAL;
                       VAR thread: ThreadState): ADDRESS =
  VAR
    res       := thread.pool.next + ADRSIZE(Header);
    cur_align := Word.And(LOOPHOLE(res, INTEGER), MaxAlignMask);
    alignment := align[cur_align, dataAlignment];
    nextPtr   := res + (alignment + dataSize);
  BEGIN
    IF nextPtr > thread.pool.limit THEN
      (* not enough space left in the pool, take the long route *)
      res := NIL;  nextPtr := NIL;  (* in case of GC... *)
      TRY
        <*ASSERT thread.inCritical > 0*>
        DEC(thread.inCritical);
        RTOS.LockHeap();
        (* make sure the collector gets a chance to keep up with NEW... *)
        CollectEnough();
        RETURN LongAlloc (dataSize, dataAlignment, thread.pool);
      FINALLY
        RTOS.UnlockHeap();
        INC(thread.inCritical);
      END;
    END;

    (* Align the referent *)
    IF alignment # 0 THEN
      InsertFiller(thread.pool.next, alignment);
      thread.pool.next := thread.pool.next + alignment;
      res := thread.pool.next + ADRSIZE(Header);
    END;

    thread.pool.next := nextPtr;
    RETURN res;
  END AllocTraced;
---------------------------------------------------------- RTAllocCnts ---

PROCEDURE BumpCnt (tc: RT0.Typecode) =
  BEGIN
    TRY
      RTOS.LockHeap();
      IF (tc >= n_types) THEN ExpandCnts (tc); END;
      WITH z = n_objects[tc] DO z := Word.Plus (z, 1) END;
    FINALLY
      RTOS.UnlockHeap();
    END;
  END BumpCnt;

PROCEDURE BumpSize (tc: RT0.Typecode;  size: INTEGER) =
  BEGIN
    TRY
      RTOS.LockHeap();
      IF (tc >= n_types) THEN ExpandCnts (tc); END;
      WITH z = n_objects[tc] DO z := Word.Plus (z, 1)    END;
      WITH z = n_bytes[tc]   DO z := Word.Plus (z, size) END;
    FINALLY
      RTOS.UnlockHeap();
    END;
  END BumpSize;

PROCEDURE ExpandCnts (tc: RT0.Typecode) =
  VAR
    goal      := MAX (tc, RTType.MaxTypecode ());
    new_cnt   : INTEGER := 512;
    new_mem   : INTEGER;
    new_cnts  : ADDRESS;
    new_sizes : ADDRESS;
    old_cnts  := n_objects;
    old_sizes := n_bytes;
  BEGIN
    IF (n_types > 0) THEN new_cnt := n_types; END;
    WHILE (new_cnt <= goal) DO INC (new_cnt, new_cnt); END;

    new_mem   := new_cnt * BYTESIZE (INTEGER);
    new_cnts  := Malloc (new_mem);
    new_sizes := Malloc (new_mem);

    IF (old_cnts # NIL) THEN
      RTMisc.Copy (old_cnts,  new_cnts,  n_types * BYTESIZE (INTEGER));
      RTMisc.Copy (old_sizes, new_sizes, n_types * BYTESIZE (INTEGER));
    END;

    n_objects := new_cnts;
    n_bytes   := new_sizes;
    n_types   := new_cnt;
    (* "n_types" is assigned last in case anyone is reading the arrays
       while we're updating them... *)

    IF (old_cnts # NIL) THEN
      Cstdlib.free (old_cnts);
      Cstdlib.free (old_sizes);
    END;
  END ExpandCnts;

PROCEDURE Malloc (size: INTEGER): ADDRESS =
  VAR res: ADDRESS;
  BEGIN
    Scheduler.DisableSwitching();
    res := Cstdlib.calloc(1, size);
    Scheduler.EnableSwitching();
    IF res = NIL THEN RTE.Raise(RTE.T.OutOfMemory) END;
    RETURN res;
  END Malloc;

BEGIN
END RTAllocator.

interface RTThread is in: