UNSAFE MODULEIn the following procedures,RTAllocator EXPORTSRTAllocator ,RTAllocCnts ,RTHooks ,RTHeapRep ; IMPORT Cstdlib, RT0, RTMisc, RTOS, RTType, Scheduler, RTThread; IMPORT RuntimeError AS RTE, Word; FROM RTType IMPORT Typecode;
RTType.Get(tc)
will fail if tc
is not
proper.
TYPE TK = RT0.TypeKind;----------------------------------------------------------- RTAllocator ---
PROCEDURE--------------------------------------------------------------- RTHooks ---NewTraced (tc: Typecode): REFANY RAISES {OutOfMemory} = VAR res := GetTraced(RTType.Get(tc)); BEGIN IF (res = NIL) THEN RAISE OutOfMemory; END; RETURN res; END NewTraced; PROCEDURENewUntraced (tc: Typecode): ADDRESS RAISES {OutOfMemory} = VAR res := GetUntracedRef(RTType.Get(tc)); BEGIN IF (res = NIL) THEN RAISE OutOfMemory; END; RETURN res; END NewUntraced; PROCEDURENewUntracedObject (tc: Typecode): UNTRACED ROOT RAISES {OutOfMemory} = VAR res := GetUntracedObj(RTType.Get(tc)); BEGIN IF (res = NIL) THEN RAISE OutOfMemory; END; RETURN res; END NewUntracedObject; PROCEDURENewTracedArray (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; PROCEDURENewUntracedArray (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; PROCEDUREClone (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;
PROCEDURE-------------------------------------------------------------- internal ---Allocate (defn: ADDRESS): REFANY = VAR res := GetTraced(defn); BEGIN IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END; RETURN res; END Allocate; PROCEDUREAllocateTracedRef (defn: ADDRESS): REFANY = VAR res := GetTracedRef(defn); BEGIN IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END; RETURN res; END AllocateTracedRef; PROCEDUREAllocateTracedObj (defn: ADDRESS): ROOT = VAR res := GetTracedObj(defn); BEGIN IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END; RETURN res; END AllocateTracedObj; PROCEDUREAllocateUntracedRef (defn: ADDRESS): ADDRESS = VAR res := GetUntracedRef(defn); BEGIN IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END; RETURN res; END AllocateUntracedRef; PROCEDUREAllocateUntracedObj (defn: ADDRESS): UNTRACED ROOT = VAR res := GetUntracedObj(defn); BEGIN IF (res = NIL) THEN RTE.Raise(RTE.T.OutOfMemory); END; RETURN res; END AllocateUntracedObj; PROCEDUREAllocateOpenArray (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; PROCEDUREAllocateUntracedOpenArray (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; PROCEDUREDisposeUntracedRef (VAR a: ADDRESS) = BEGIN IF a # NIL THEN Scheduler.DisableSwitching(); Cstdlib.free(a); a := NIL; Scheduler.EnableSwitching(); END; END DisposeUntracedRef; PROCEDUREDisposeUntracedObj (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;
PROCEDURE---------------------------------------------------------- RTAllocCnts ---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; PROCEDUREGetTracedRef (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; PROCEDUREGetTracedObj (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; PROCEDUREGetUntracedRef (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; PROCEDUREGetUntracedObj (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; PROCEDUREInitObj (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; PROCEDUREGetOpenArray (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; PROCEDUREGetUntracedOpenArray (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; PROCEDUREInitArray (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; PROCEDUREArraySize (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; PROCEDUREAllocTraced (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;
PROCEDUREBumpCnt (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; PROCEDUREBumpSize (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; PROCEDUREExpandCnts (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; PROCEDUREMalloc (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.