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;
IMPORT Cstdlib, RT0, RTHeap, RTHeapRep, RTMisc, RTOS, RTType;
IMPORT RuntimeError AS RTE, Word;
FROM RTType IMPORT Typecode;
FROM RTHeapRep IMPORT Header, RefHeader, AllocTraced, AllocUntraced, newPool;
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 x: REFANY; defn: RT0.TypeDefn; tc: INTEGER;
BEGIN
IF (ref = NIL) THEN RETURN NIL; END;
tc := TYPECODE (ref);
defn := RTType.Get (tc);
CASE defn.kind OF
| ORD (RT0.TypeKind.Ref), ORD (RT0.TypeKind.Obj) =>
x := NewTraced (tc);
| ORD (RT0.TypeKind.Array) =>
VAR nDims: INTEGER; shape: RTHeapRep.ArrayShape; BEGIN
RTHeapRep.UnsafeGetShape (ref, nDims, shape);
x := NewTracedArray (tc, SUBARRAY (shape^, 0, nDims));
END;
ELSE
x := NIL; (* force a crash *)
END;
(* finally, copy the data into the new object *)
RTMisc.Copy (RTHeap.GetDataAdr (ref), RTHeap.GetDataAdr (x),
RTHeap.GetDataSize (ref));
RETURN x;
END Clone;
--------------------------------------------------------------- RTHooks ---
PROCEDURE Allocate (defn: ADDRESS): REFANY =
VAR res := GetTraced(defn);
BEGIN
IF (res = NIL) THEN RAISE RTE.E (RTE.T.OutOfMemory); END;
RETURN res;
END Allocate;
PROCEDURE AllocateUntracedRef (defn: ADDRESS): ADDRESS =
VAR res := GetUntracedRef(defn);
BEGIN
IF (res = NIL) THEN RAISE RTE.E (RTE.T.OutOfMemory); END;
RETURN res;
END AllocateUntracedRef;
PROCEDURE AllocateUntracedObj (defn: ADDRESS): UNTRACED ROOT =
VAR res := GetUntracedObj(defn);
BEGIN
IF (res = NIL) THEN RAISE RTE.E (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 RAISE RTE.E (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 RAISE RTE.E (RTE.T.OutOfMemory); END;
RETURN res;
END AllocateUntracedOpenArray;
PROCEDURE DisposeUntracedRef (VAR a: ADDRESS) =
BEGIN
IF a # NIL THEN Cstdlib.free(a); a := NIL; END;
END DisposeUntracedRef;
PROCEDURE DisposeUntracedObj (VAR a: UNTRACED ROOT) =
VAR def: RT0.TypeDefn;
BEGIN
IF a # NIL THEN
def := RTType.Get (TYPECODE (a));
Cstdlib.free (a - MAX(BYTESIZE(Header), def.dataAlignment));
a := NIL;
END;
END DisposeUntracedObj;
-------------------------------------------------------------- internal ---
VAR
initCache: ARRAY [0 .. 4095] OF ADDRESS; (* initialized contents for
freshly allocated objects *)
PROCEDURE GetTraced (defn: ADDRESS): REFANY =
VAR
def : RT0.TypeDefn := defn;
tc : Typecode := def.typecode;
res : ADDRESS;
sz := BYTESIZE (Header) + def.dataSize;
BEGIN
IF (tc = 0) OR (def.traced = 0) OR (def.kind = ORD (TK.Array)) THEN
<*NOWARN*> EVAL VAL (-1, CARDINAL); (* force a range fault *)
END;
RTOS.LockHeap();
res := AllocTraced(def.dataSize, def.dataAlignment, newPool);
IF (res = NIL) THEN RTOS.UnlockHeap(); RETURN NIL; END;
BumpCnt (tc);
IF (tc <= LAST (initCache)) AND (initCache[tc] # NIL) THEN
RTMisc.Copy(initCache[tc], res - ADRSIZE(Header), sz);
ELSE
InitRef (res, def);
IF (def.dataSize <= BYTESIZE(def^)) AND (tc <= LAST (initCache)) THEN
VAR copy := AllocUntraced(sz); BEGIN
IF (copy # NIL) THEN
initCache[tc] := copy;
RTMisc.Copy(res - ADRSIZE(Header), copy, sz);
END;
END;
END;
END;
RTOS.UnlockHeap();
IF (callback # NIL) THEN callback (LOOPHOLE (res, REFANY)); END;
RETURN LOOPHOLE(res, REFANY);
END GetTraced;
PROCEDURE GetUntracedRef (defn: ADDRESS): ADDRESS =
VAR
def : RT0.TypeDefn := defn;
tc : Typecode := def.typecode;
res : ADDRESS;
BEGIN
IF (tc = 0) OR (def.traced # 0) OR (def.kind # ORD (TK.Ref)) THEN
<*NOWARN*> EVAL VAL (-1, CARDINAL); (* force a range fault *)
END;
res := AllocUntraced(def.dataSize);
IF (res = NIL) THEN RETURN NIL; END;
BumpCnt (tc);
RTMisc.Zero (res, def.dataSize);
IF def.initProc # NIL THEN def.initProc(res); END;
RETURN res;
END GetUntracedRef;
PROCEDURE GetUntracedObj (defn: ADDRESS): UNTRACED ROOT =
(* NOTE: result requires special treatment by DisposeUntracedObj *)
VAR
def : RT0.TypeDefn := defn;
hdrSize := MAX(BYTESIZE(Header), def.dataAlignment);
tc : Typecode := def.typecode;
res : ADDRESS;
BEGIN
IF (tc = 0) OR (def.traced # 0) OR (def.kind # ORD (TK.Obj)) THEN
<*NOWARN*> EVAL VAL (-1, CARDINAL); (* force a range fault *)
END;
res := AllocUntraced(hdrSize + def.dataSize);
IF (res = NIL) THEN RETURN NIL; END;
BumpCnt (tc);
res := res + hdrSize;
InitRef (res, def);
RETURN res;
END GetUntracedObj;
PROCEDURE InitRef (res: ADDRESS; def: RT0.TypeDefn) =
VAR hdr := LOOPHOLE(res - ADRSIZE(Header), RefHeader);
BEGIN
hdr^ := RT0.RefHeader {};
hdr.typecode := def.typecode;
RTMisc.Zero(res, def.dataSize);
IF (def.kind = ORD(TK.Obj)) THEN
VAR objdef := LOOPHOLE (def, RT0.ObjectTypeDefn); BEGIN
LOOPHOLE(res, UNTRACED REF ADDRESS)^ := objdef.defaultMethods;
WHILE objdef # NIL DO
IF objdef.common.initProc # NIL THEN objdef.common.initProc(res); END;
IF objdef.common.kind # ORD (TK.Obj) THEN EXIT; END;
objdef := LOOPHOLE (objdef.parent, RT0.ObjectTypeDefn);
END;
END;
ELSE
IF def.initProc # NIL THEN def.initProc(res); END;
END;
END InitRef;
TYPE
ArrayInfo = RECORD
def : RT0.ArrayTypeDefn;
alignment : INTEGER;
nDataBytes : INTEGER;
nBytes : INTEGER;
tc : Typecode;
END;
PROCEDURE GetOpenArray (defn: ADDRESS; READONLY s: Shape): REFANY =
VAR res: ADDRESS; info: ArrayInfo;
BEGIN
GetArrayInfo (defn, s, info, TRUE);
RTOS.LockHeap();
res := AllocTraced(info.nBytes, info.alignment, newPool);
IF (res = NIL) THEN RTOS.UnlockHeap(); RETURN NIL; END;
LOOPHOLE(res - ADRSIZE(Header), RefHeader)^ :=
Header{typecode := info.tc, forwarded := FALSE};
InitArray (res, s, info);
RTOS.UnlockHeap();
IF (callback # NIL) THEN callback (LOOPHOLE (res, REFANY)); END;
RETURN LOOPHOLE(res, REFANY);
END GetOpenArray;
PROCEDURE GetUntracedOpenArray (defn: ADDRESS; READONLY s: Shape): ADDRESS =
VAR res: ADDRESS; info: ArrayInfo;
BEGIN
GetArrayInfo (defn, s, info, FALSE);
res := AllocUntraced(info.nBytes);
IF (res = NIL) THEN RETURN NIL; END;
InitArray (res, s, info);
RETURN res;
END GetUntracedOpenArray;
PROCEDURE GetArrayInfo (def: RT0.TypeDefn; READONLY s: Shape;
VAR ai: ArrayInfo; traced: BOOLEAN) =
VAR n_elts := 1; c: CARDINAL;
BEGIN
ai.def := LOOPHOLE (def, RT0.ArrayTypeDefn);
ai.tc := def.typecode;
ai.alignment := def.dataAlignment;
IF (def.typecode = 0)
OR (def.traced # ORD (traced))
OR (def.kind # ORD (TK.Array))
OR (NUMBER(s) # ai.def.nDimensions) THEN
<*NOWARN*> EVAL VAL (-1, CARDINAL); (* force a range fault *)
END;
FOR i := 0 TO NUMBER(s) - 1 DO
c := s[i]; (* force a range check *)
n_elts := c * n_elts;
END;
ai.nDataBytes := ai.def.elementSize * n_elts;
ai.nBytes := RTMisc.Upper(def.dataSize + ai.nDataBytes, BYTESIZE(Header));
END GetArrayInfo;
PROCEDURE InitArray (res: ADDRESS; READONLY s: Shape; VAR info: ArrayInfo) =
VAR data_start := res + info.def.common.dataSize;
BEGIN
BumpSize (info.tc, info.nBytes);
LOOPHOLE(res, UNTRACED REF ADDRESS)^ := data_start;
FOR i := 0 TO NUMBER(s) - 1 DO
LOOPHOLE(res + ADRSIZE(ADDRESS) + i * ADRSIZE(INTEGER),
UNTRACED REF INTEGER)^ := s[i];
END;
RTMisc.Zero(data_start, info.nDataBytes);
IF info.def.common.initProc # NIL THEN info.def.common.initProc(res); END;
END InitArray;
---------------------------------------------------------- RTAllocCnts ---
PROCEDURE BumpCnt (tc: RT0.Typecode) =
BEGIN
IF (tc >= n_types) THEN ExpandCnts (tc); END;
WITH z = n_objects[tc] DO z := Word.Plus (z, 1) END;
END BumpCnt;
PROCEDURE BumpSize (tc: RT0.Typecode; size: INTEGER) =
BEGIN
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;
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 := Cstdlib.malloc (size);
BEGIN
IF (res = NIL) THEN RAISE RTE.E (RTE.T.OutOfMemory); END;
RTMisc.Zero (res, size);
RETURN res;
END Malloc;
BEGIN
END RTAllocator.