Coop.Heaps.Mod 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548
  1. MODULE Heaps; (** AUTHOR "pjm/Luc Bläser/U. Glavitsch (ug)"; PURPOSE "Heap management and garbage collector"; *)
  2. (*
  3. This module contains lots of low-level memory manipulations, which are best
  4. read together with the memory management data structure documentation.
  5. Garbage collector using a marking stack with overflow handling,
  6. References:
  7. Jones, Lins, Garbage Collection, Section 4.2, Algorithm 4.1
  8. Knuth, The Art of Computer Programming, Volume 1, Section 2.3.5, Algorithm C
  9. *)
  10. IMPORT SYSTEM, Trace, Machine;
  11. CONST
  12. Stats* = TRUE; (* maintain statistical counters *)
  13. AddressSize = SIZEOF(ADDRESS);
  14. BlockSize* = 32; (* power of two, <= 32 for RegisterCandidates *)
  15. ArrayAlignment = 8; (* first array element of ArrayBlock and first data element of SystemBlock must be aligned to 0 MOD ArrayAlignment *)
  16. BlockHeaderSize* = 2 * AddressSize;
  17. HeapBlockOffset* = - 2 * AddressSize;
  18. TypeDescOffset* = 0;
  19. ProtTypeBit* = 31; (** flags in TypeDesc, RoundUp(log2(MaxTags)) low bits reserved for extLevel *)
  20. FlagsOfs = AddressSize * 3; (* flags offset in TypeDesc *)
  21. ModOfs* = AddressSize * 4; (* moduleAdr offset in TypeDesc *)
  22. MinPtrOfs = -40000000H; (* sentinel offset for ptrOfs *)
  23. MethodEndMarker* = MinPtrOfs; (* marks the end of the method addresses, used in Info.ModuleDetails *)
  24. NilVal* = 0;
  25. NumPriorities* = 6;
  26. TYPE
  27. RootObject* = OBJECT (* ref. Linker0 *)
  28. VAR nextRoot: RootObject; (* for linking root objects during GC *)
  29. PROCEDURE FindRoots*; (** abstract *)
  30. BEGIN HALT(301) END FindRoots;
  31. END RootObject;
  32. ProcessLink* = OBJECT (RootObject)
  33. VAR next*, prev*: ProcessLink
  34. END ProcessLink;
  35. ProcessQueue* = RECORD
  36. head*, tail*: ProcessLink
  37. END;
  38. Finalizer* = PROCEDURE {DELEGATE} (obj: ANY);
  39. FinalizerNode* = POINTER TO RECORD
  40. objWeak* (*{UNTRACED}*): ANY; (* weak reference to checked object *)
  41. nextFin: FinalizerNode; (* in finalization list *)
  42. objStrong*: ANY; (* strong reference to object to be finalized *)
  43. finalizer* (*{UNTRACED}*) : Finalizer;(* finalizer, if any. Untraced for the case that a finalizer points to objWeak *)
  44. finalizerStrong: Finalizer; (* strong reference to the object that is referenced by the finalizer, if any *)
  45. END;
  46. HeapBlock* = POINTER TO HeapBlockDesc; (* base object of all heap blocks *)
  47. HeapBlockDesc* = RECORD
  48. mark: LONGINT;
  49. dataAdr-: ADDRESS;
  50. size-: SIZE;
  51. nextRealtime: HeapBlock;
  52. END;
  53. FreeBlock* = POINTER TO FreeBlockDesc;
  54. FreeBlockDesc* = RECORD (HeapBlockDesc)
  55. next: FreeBlock;
  56. END;
  57. SystemBlock* = POINTER TO SystemBlockDesc;
  58. SystemBlockDesc = RECORD (HeapBlockDesc)
  59. END;
  60. RecordBlock* = POINTER TO RecordBlockDesc;
  61. RecordBlockDesc = RECORD (HeapBlockDesc)
  62. END;
  63. ProtRecBlock* = POINTER TO ProtRecBlockDesc;
  64. ProtRecBlockDesc* = RECORD (RecordBlockDesc)
  65. count*: LONGINT;
  66. locked*: BOOLEAN;
  67. awaitingLock*, awaitingCond*: ProcessQueue;
  68. lockedBy*: ANY;
  69. lock*: ANY; (* used by Win32, unused for I386 *)
  70. waitingPriorities*: ARRAY NumPriorities OF LONGINT;
  71. END;
  72. ArrayBlock* = POINTER TO ArrayBlockDesc;
  73. ArrayBlockDesc = RECORD (HeapBlockDesc)
  74. END;
  75. StaticTypeBlock*= POINTER TO StaticTypeDesc;
  76. StaticTypeDesc = RECORD
  77. recSize: SIZE;
  78. pointerOffsets* {UNTRACED}: PointerOffsets;
  79. END;
  80. PointerOffsets = POINTER TO ARRAY OF SIZE;
  81. CONST
  82. MaxFreeLists = 14;
  83. FreeListBarrier = 7;
  84. TYPE
  85. FreeList= RECORD minSize: SIZE; first {UNTRACED}, last{UNTRACED}: FreeBlock END;
  86. FreeLists = ARRAY MaxFreeLists+1 OF FreeList;
  87. VAR
  88. GC*: PROCEDURE; (** activate the garbage collector *)
  89. realtimeList {UNTRACED}: HeapBlock; (* list of realtime objects - tracing does not harm but is unnecessary *)
  90. checkRoot: FinalizerNode; (* list of checked objects (contains weak references to the checked objects) *)
  91. finalizeRoot: FinalizerNode; (* objects scheduled for finalization (contains references to scheduled objects) *)
  92. freeBlockTag, systemBlockTag, recordBlockTag, protRecBlockTag, arrayBlockTag: ADDRESS; (* same values of type ADDRESS *)
  93. (** Statistics. Will only be maintained if Stats = TRUE *)
  94. (** Memory allocation statistics *)
  95. Nnew- : LONGINT; (** Number of times NewBlock has been called since system startup *)
  96. NnewBytes- : HUGEINT; (** Number of bytes allocated by NewBlock since system startup *)
  97. (** Garbage collection statistics *)
  98. Ngc- : LONGINT; (** Number of GC cycles since system startup *)
  99. (** Statistics considering the last GC cyle *)
  100. Nmark-, Nmarked-, NfinalizeAlive-, NfinalizeDead-: LONGINT;
  101. NgcCyclesMark-, NgcCyclesLastRun-, NgcCyclesMax-, NgcCyclesAllRuns- : HUGEINT;
  102. NgcSweeps-, NgcSweepTime-, NgcSweepMax-: HUGEINT;
  103. freeBlockFound-, freeBlockNotFound-: LONGINT;
  104. allocationLogger-: PROCEDURE(p: ANY);
  105. PROCEDURE Assign*(VAR dest: ADDRESS; src: ADDRESS);
  106. BEGIN
  107. dest := src;
  108. END Assign;
  109. (* for low level debugging of allocation -- beware: errors or traps in allocation logger can produce catastrophy - loggers may not allocate memory *)
  110. PROCEDURE SetAllocationLogger*(a: PROCEDURE (p:ANY));
  111. BEGIN
  112. allocationLogger := a
  113. END SetAllocationLogger;
  114. (** Mark - Mark an object and its decendents. Used by findRoots. *)
  115. PROCEDURE Mark* EXTERN "GarbageCollector.Mark" (p: ANY);
  116. (* CheckCandidates - Check which candidates could be pointers, and mark them. (exported for debugging only) *)
  117. PROCEDURE CheckCandidates*;
  118. END CheckCandidates;
  119. PROCEDURE CheckAssignment*(dest, src: ADDRESS);
  120. END CheckAssignment;
  121. (** Return the next scheduled finalizer or NIL if none available. Called by finalizer object in Kernel. *)
  122. PROCEDURE GetFinalizer* (): FinalizerNode;
  123. VAR n: FinalizerNode;
  124. BEGIN
  125. n := NIL;
  126. IF finalizeRoot # NIL THEN
  127. Machine.Acquire(Machine.Heaps);
  128. n := finalizeRoot; (* take one finalizer *)
  129. IF n # NIL THEN
  130. finalizeRoot := n.nextFin; n.nextFin := NIL;
  131. IF Stats THEN DEC(NfinalizeDead) END;
  132. END;
  133. Machine.Release(Machine.Heaps);
  134. END;
  135. RETURN n
  136. END GetFinalizer;
  137. (** Check finalizers registered in the specified module, which is about to be freed or shut down. Remove all finalizer procedures in this module from the finalizer lists so they won't be called any more. *)
  138. PROCEDURE CleanupModuleFinalizers*(codeAdr: ADDRESS; codeLen: SIZE; CONST name: ARRAY OF CHAR);
  139. VAR n, p, t: FinalizerNode; codeEnd: ADDRESS; N1, N2: LONGINT;
  140. BEGIN
  141. codeEnd := codeAdr + codeLen; N1 := 0; N2 := 0;
  142. Machine.Acquire(Machine.Heaps);
  143. n := checkRoot;
  144. WHILE n # NIL DO (* iterate over checked list *)
  145. t := n; n := n.nextFin;
  146. IF (codeAdr <= SYSTEM.VAL (ADDRESS, t.finalizer)) & (SYSTEM.VAL (ADDRESS, t.finalizer) <= codeEnd) THEN
  147. IF t = checkRoot THEN checkRoot := t.nextFin ELSE p.nextFin := t.nextFin END; (* remove from list *)
  148. IF Stats THEN DEC(NfinalizeAlive) END;
  149. INC(N1)
  150. ELSE
  151. p := t
  152. END
  153. END;
  154. (* also remove finalizers from list, so they won't be called *)
  155. n := finalizeRoot;
  156. WHILE n # NIL DO (* iterate over finalized list *)
  157. t := n; n := n.nextFin;
  158. IF (codeAdr <= SYSTEM.VAL (ADDRESS, t.finalizer)) & (SYSTEM.VAL (ADDRESS, t.finalizer) <= codeEnd) THEN
  159. IF t = finalizeRoot THEN finalizeRoot := t.nextFin ELSE p.nextFin := t.nextFin END; (* remove from list *)
  160. IF Stats THEN DEC(NfinalizeDead) END;
  161. INC(N2)
  162. ELSE
  163. p := t
  164. END
  165. END;
  166. Machine.Release(Machine.Heaps);
  167. IF (N1 # 0) OR (N2 # 0) THEN
  168. Machine.Acquire (Machine.TraceOutput);
  169. Trace.String(name); Trace.Char(" ");
  170. Trace.Int(N1, 1); Trace.String(" discarded finalizers, ");
  171. Trace.Int(N2, 1); Trace.StringLn (" pending finalizers");
  172. Machine.Release (Machine.TraceOutput);
  173. END
  174. END CleanupModuleFinalizers;
  175. PROCEDURE InvokeGC*;
  176. PROCEDURE Collect EXTERN "GarbageCollector.Collect";
  177. BEGIN Collect;
  178. END InvokeGC;
  179. PROCEDURE LazySweepGC*;
  180. VAR p {UNTRACED}: FreeBlock;
  181. BEGIN
  182. GC;
  183. END LazySweepGC;
  184. (* initialize a free heap block *)
  185. PROCEDURE InitFreeBlock(freeBlock: FreeBlock; mark: LONGINT; dataAdr: ADDRESS; size: SIZE);
  186. VAR freeBlockAdr: ADDRESS;
  187. BEGIN
  188. freeBlock.mark := mark;
  189. freeBlock.dataAdr := dataAdr;
  190. freeBlock.size := size;
  191. freeBlock.next := NIL;
  192. (* initialize heap block header *)
  193. freeBlockAdr := freeBlock;
  194. SYSTEM.PUT(freeBlockAdr + TypeDescOffset, freeBlockTag);
  195. SYSTEM.PUT(freeBlockAdr + HeapBlockOffset, NilVal)
  196. END InitFreeBlock;
  197. PROCEDURE NewBlock EXTERN "Runtime.New" (size: SIZE): ADDRESS;
  198. (** NewSys - Implementation of SYSTEM.NEW. *)
  199. PROCEDURE NewSys*(VAR p: ANY; size: SIZE; isRealtime: BOOLEAN);
  200. VAR blockSize, systemBlockSize: SIZE; systemBlockAdr, dataBlockAdr: ADDRESS;
  201. systemBlock {UNTRACED}: SystemBlock; pc: ADDRESS;
  202. BEGIN
  203. systemBlockSize := BlockHeaderSize + SIZEOF(SystemBlockDesc);
  204. INC(systemBlockSize, (-systemBlockSize) MOD ArrayAlignment); (* round up to multiple of ArrayAlignment to ensure alignment of first data element to 0 MOD ArrayAlignment *)
  205. blockSize := systemBlockSize + BlockHeaderSize + size;
  206. INC(blockSize, (-blockSize) MOD BlockSize); (* round up to multiple of BlockSize *)
  207. systemBlockAdr:= NewBlock(blockSize);
  208. IF systemBlockAdr # 0 THEN
  209. INC (systemBlockAdr, BlockHeaderSize);
  210. SYSTEM.PUT(systemBlockAdr + TypeDescOffset, systemBlockTag);
  211. SYSTEM.GET(SYSTEM.GetFramePointer()+SIZEOF(ADDRESS),pc);
  212. SYSTEM.PUT(systemBlockAdr + HeapBlockOffset,pc);
  213. dataBlockAdr := systemBlockAdr + systemBlockSize (* - BlockHeaderSize + BlockHeaderSize *);
  214. SYSTEM.PUT(dataBlockAdr + TypeDescOffset, NilVal); (* no type descriptor *)
  215. SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, systemBlockAdr);
  216. systemBlock := SYSTEM.VAL(SystemBlock, systemBlockAdr);
  217. systemBlock.dataAdr := dataBlockAdr;
  218. systemBlock.size := blockSize;
  219. IF isRealtime THEN
  220. systemBlock.nextRealtime := realtimeList;
  221. realtimeList := systemBlock
  222. ELSE
  223. systemBlock.nextRealtime := NIL
  224. END;
  225. p := SYSTEM.VAL(ANY, dataBlockAdr);
  226. (* clear could be done outside lock because SysBlks are not traced, but for conformity it is done inside the lock *)
  227. Machine.Fill32(dataBlockAdr, blockSize - systemBlockSize - BlockHeaderSize, 0); (* clear everything from dataBlockAdr until end of block *)
  228. ELSE
  229. p := NIL
  230. END;
  231. END NewSys;
  232. PROCEDURE SetPC2(p: ANY; pc: ADDRESS);
  233. VAR blockAdr: ADDRESS;
  234. BEGIN
  235. IF p # NIL THEN
  236. SYSTEM.GET(SYSTEM.VAL(ADDRESS, p)+HeapBlockOffset,blockAdr);
  237. SYSTEM.PUT(blockAdr+HeapBlockOffset, pc);
  238. END;
  239. END SetPC2;
  240. PROCEDURE SetPC-(p: ANY);
  241. END SetPC;
  242. (** NewRec - Implementation of NEW with a record. *)
  243. PROCEDURE NewRec*(VAR p: ANY; tag: ADDRESS; isRealtime: BOOLEAN);
  244. VAR flags: SET; size, blockSize: SIZE; typeInfoAdr, recordBlockAdr, dataBlockAdr : ADDRESS;
  245. recordBlock {UNTRACED}: RecordBlock; pc: ADDRESS;
  246. BEGIN
  247. SYSTEM.GET (tag - AddressSize, typeInfoAdr);
  248. SYSTEM.GET (typeInfoAdr + FlagsOfs, flags);
  249. IF ProtTypeBit IN flags THEN
  250. NewProtRec(p, tag, isRealtime);
  251. SYSTEM.GET(SYSTEM.GetFramePointer()+SIZEOF(ADDRESS), pc);
  252. SetPC2(p,pc);
  253. ELSE
  254. SYSTEM.GET(tag, size);
  255. (* the block size is the sum of the size of the RecordBlock and the DataBlock.
  256. Two extra fields per subblock contain the tag and the reference to the heap block *)
  257. blockSize := BlockHeaderSize + SIZEOF(RecordBlockDesc) + BlockHeaderSize + size;
  258. INC(blockSize, (-blockSize) MOD BlockSize); (* round up to multiple of BlockSize *)
  259. recordBlockAdr := NewBlock(blockSize);
  260. IF recordBlockAdr # 0 THEN
  261. INC (recordBlockAdr, BlockHeaderSize);
  262. SYSTEM.PUT(recordBlockAdr + TypeDescOffset, recordBlockTag);
  263. SYSTEM.GET(SYSTEM.GetFramePointer()+SIZEOF(ADDRESS),pc);
  264. SYSTEM.PUT(recordBlockAdr + HeapBlockOffset,pc);
  265. dataBlockAdr := recordBlockAdr + SIZEOF(RecordBlockDesc) + BlockHeaderSize;
  266. SYSTEM.PUT(dataBlockAdr + TypeDescOffset, tag);
  267. SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, recordBlockAdr);
  268. recordBlock := SYSTEM.VAL(RecordBlock, recordBlockAdr);
  269. (* recordBlock.next and recordBlock.prev already set to NIL by NewBlock *)
  270. recordBlock.dataAdr := dataBlockAdr;
  271. recordBlock.size := blockSize;
  272. IF isRealtime THEN
  273. recordBlock.nextRealtime := realtimeList;
  274. realtimeList := recordBlock
  275. ELSE
  276. recordBlock.nextRealtime := NIL
  277. END;
  278. p := SYSTEM.VAL(ANY, dataBlockAdr);
  279. (* clear must be done inside lock to ensure all traced pointer fields are initialized to NIL *)
  280. Machine.Fill32(dataBlockAdr, blockSize - SIZEOF(RecordBlockDesc) - 2 * BlockHeaderSize, 0); (* clear everything from dataBlockAdr until end of block *)
  281. ELSE
  282. p := NIL
  283. END;
  284. END;
  285. END NewRec;
  286. (** NewProtRec - Implementation of NEW with a protected record. *)
  287. PROCEDURE NewProtRec*(VAR p: ANY; tag: ADDRESS; isRealtime: BOOLEAN);
  288. VAR size, blockSize: SIZE; protRecBlockAdr, dataBlockAdr: ADDRESS;
  289. protRecBlock {UNTRACED}: ProtRecBlock; i: LONGINT; pc: ADDRESS;
  290. BEGIN
  291. SYSTEM.GET(tag, size);
  292. blockSize := BlockHeaderSize + SIZEOF(ProtRecBlockDesc) + BlockHeaderSize + size;
  293. INC(blockSize, (-blockSize) MOD BlockSize); (* round up to multiple of BlockSize *)
  294. protRecBlockAdr := NewBlock(blockSize);
  295. IF protRecBlockAdr # 0 THEN
  296. INC (protRecBlockAdr, BlockHeaderSize);
  297. SYSTEM.PUT(protRecBlockAdr + TypeDescOffset, protRecBlockTag);
  298. SYSTEM.GET(SYSTEM.GetFramePointer()+SIZEOF(ADDRESS),pc);
  299. SYSTEM.PUT(protRecBlockAdr + HeapBlockOffset,pc);
  300. dataBlockAdr := protRecBlockAdr + SIZEOF(ProtRecBlockDesc) + BlockHeaderSize;
  301. SYSTEM.PUT(dataBlockAdr + TypeDescOffset, tag);
  302. SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, protRecBlockAdr);
  303. protRecBlock := SYSTEM.VAL(ProtRecBlock, protRecBlockAdr);
  304. protRecBlock.dataAdr := dataBlockAdr;
  305. protRecBlock.size := blockSize;
  306. IF isRealtime THEN
  307. protRecBlock.nextRealtime := realtimeList;
  308. realtimeList := protRecBlock
  309. ELSE
  310. protRecBlock.nextRealtime := NIL
  311. END;
  312. protRecBlock.count := 0;
  313. protRecBlock.awaitingLock.head := NIL;
  314. protRecBlock.awaitingLock.tail := NIL;
  315. protRecBlock.awaitingCond.head := NIL;
  316. protRecBlock.awaitingCond.tail := NIL;
  317. protRecBlock.lockedBy := NIL;
  318. protRecBlock.lock := NIL;
  319. FOR i := 0 TO NumPriorities - 1 DO
  320. protRecBlock.waitingPriorities[i] := 0
  321. END;
  322. INC(protRecBlock.waitingPriorities[0]); (* set sentinel value: assume that idle process with priority 0 waits on this resource *)
  323. p := SYSTEM.VAL(ANY, dataBlockAdr);
  324. (* clear must be done inside lock to ensure all traced pointer fields are initialized to NIL *)
  325. Machine.Fill32(dataBlockAdr, blockSize - SIZEOF(ProtRecBlockDesc) - 2 * BlockHeaderSize, 0); (* clear everything from dataBlockAdr to end of block *)
  326. ELSE
  327. p := NIL
  328. END;
  329. END NewProtRec;
  330. (** NewArr - Implementation of NEW with an array containing pointers. *)
  331. PROCEDURE NewArr*(VAR p: ANY; elemTag: ADDRESS; numElems, numDims: SIZE; isRealtime: BOOLEAN);
  332. VAR arrayBlockAdr, dataBlockAdr: ADDRESS; arrayBlock {UNTRACED}: ArrayBlock;
  333. elemSize, arrSize, blockSize, arrayBlockSize, fillSize, size, ptrOfs, arrayDataOffset: SIZE;
  334. firstElem: ADDRESS; pc: ADDRESS;
  335. BEGIN
  336. SYSTEM.GET(elemTag, elemSize);
  337. arrSize := numElems * elemSize;
  338. IF arrSize = 0 THEN
  339. NewSys(p, numDims * AddressSize + 3 * AddressSize, isRealtime); (* no data, thus no specific alignment *)
  340. SYSTEM.GET(SYSTEM.GetFramePointer()+SIZEOF(ADDRESS), pc);
  341. SetPC2(p,pc);
  342. ELSE
  343. ASSERT(BlockHeaderSize MOD ArrayAlignment = 0);
  344. arrayDataOffset := numDims * AddressSize + 3 * AddressSize;
  345. INC(arrayDataOffset, (-arrayDataOffset) MOD ArrayAlignment); (* round up to multiple of ArrayAlignment to ensure that first array element is aligned at 0 MOD ArrayAlignment *)
  346. SYSTEM.GET(elemTag + AddressSize, ptrOfs);
  347. IF ptrOfs = MinPtrOfs - AddressSize THEN (* no pointers in element type *)
  348. size := arrayDataOffset + arrSize;
  349. NewSys(p, size, isRealtime);
  350. SYSTEM.GET(SYSTEM.GetFramePointer()+SIZEOF(ADDRESS), pc);
  351. SetPC2(p, pc);
  352. ELSE
  353. arrayBlockSize := BlockHeaderSize + SIZEOF(ArrayBlockDesc);
  354. INC(arrayBlockSize, (-arrayBlockSize) MOD ArrayAlignment); (* do. *)
  355. blockSize := arrayBlockSize + BlockHeaderSize + (arrayDataOffset + arrSize);
  356. INC(blockSize, (-blockSize) MOD BlockSize); (* round up to multiple of BlockSize *)
  357. arrayBlockAdr := NewBlock(blockSize);
  358. IF arrayBlockAdr # 0 THEN
  359. INC (arrayBlockAdr, BlockHeaderSize);
  360. SYSTEM.PUT(arrayBlockAdr + TypeDescOffset, arrayBlockTag);
  361. SYSTEM.GET(SYSTEM.GetFramePointer()+SIZEOF(ADDRESS),pc);
  362. SYSTEM.PUT(arrayBlockAdr + HeapBlockOffset,pc);
  363. dataBlockAdr := arrayBlockAdr + arrayBlockSize (* - BlockHeaderSize + BlockHeaderSize *);
  364. SYSTEM.PUT(dataBlockAdr + TypeDescOffset, elemTag);
  365. SYSTEM.PUT(dataBlockAdr + HeapBlockOffset, arrayBlockAdr);
  366. arrayBlock := SYSTEM.VAL(ArrayBlock, arrayBlockAdr);
  367. arrayBlock.dataAdr := dataBlockAdr;
  368. arrayBlock.size := blockSize;
  369. IF isRealtime THEN
  370. arrayBlock.nextRealtime := realtimeList;
  371. realtimeList := arrayBlock
  372. ELSE
  373. arrayBlock.nextRealtime := NIL
  374. END;
  375. (* clear data part of array here, since size parameter of Machine.Fill32 must be a multiple of 4. Some fields of the data part are filled below for GC. , *)
  376. fillSize := blockSize - arrayBlockSize - BlockHeaderSize;
  377. Machine.Fill32(dataBlockAdr, fillSize, 0); (* clear everything from dataBlockAdr until end of block *)
  378. firstElem := dataBlockAdr + arrayDataOffset;
  379. SYSTEM.PUT(dataBlockAdr, firstElem + arrSize - elemSize); (* lastElem *)
  380. SYSTEM.PUT(dataBlockAdr + AddressSize, NIL);
  381. SYSTEM.PUT(dataBlockAdr + 2 * AddressSize, firstElem); (* firstElem *)
  382. p := SYSTEM.VAL(ANY, dataBlockAdr);
  383. ELSE
  384. p := NIL
  385. END;
  386. END
  387. END
  388. END NewArr;
  389. PROCEDURE FillStaticType*(VAR staticTypeAddr: ADDRESS; startAddr, typeInfoAdr: ADDRESS; size, recSize: SIZE;
  390. numPtrs, numSlots: LONGINT);
  391. VAR p, offset: ADDRESS; staticTypeBlock {UNTRACED}: StaticTypeBlock;
  392. BEGIN
  393. Machine.Acquire(Machine.Heaps);
  394. Machine.Fill32(startAddr, size, 0); (* clear whole static type, size MOD AddressSize = 0 implicitly, see WriteType in PCOF.Mod *)
  395. SYSTEM.PUT(startAddr, MethodEndMarker); (* sentinel *)
  396. (* methods and tags filled in later *)
  397. offset := AddressSize * (numSlots + 1 + 1); (* #methods, max. no. of tags, method end marker (sentinel), pointer to type information*)
  398. p := startAddr + offset;
  399. SYSTEM.PUT(p + TypeDescOffset, typeInfoAdr); (* pointer to typeInfo *)
  400. staticTypeBlock := SYSTEM.VAL(StaticTypeBlock, p);
  401. staticTypeBlock.recSize := recSize;
  402. staticTypeAddr := p;
  403. (* create the pointer for the dynamic array of pointer offsets, the dynamic array of pointer offsets is stored in the static type
  404. descriptor, it has no header part *)
  405. INC(p, SIZEOF(StaticTypeDesc));
  406. IF p MOD (2 * AddressSize) # 0 THEN INC(p, AddressSize) END;
  407. SYSTEM.PUT(p + 3 * AddressSize, numPtrs); (* internal structure of dynamic array without pointers: the first 3 fields are unused *)
  408. staticTypeBlock.pointerOffsets := SYSTEM.VAL(PointerOffsets, p); (* the fourth field contains the dimension of the array *)
  409. (* pointer offsets filled in later *)
  410. Machine.Release(Machine.Heaps)
  411. END FillStaticType;
  412. PROCEDURE AddFinalizer*(obj: ANY; n: FinalizerNode);
  413. BEGIN
  414. n.objWeak := obj; n.objStrong := NIL; n.finalizerStrong := NIL;
  415. Machine.Acquire(Machine.Heaps);
  416. n.nextFin := checkRoot; checkRoot := n;
  417. IF Stats THEN INC(NfinalizeAlive) END;
  418. Machine.Release(Machine.Heaps)
  419. END AddFinalizer;
  420. (** Compute total heap size, free space and largest free block size in bytes. This is a slow operation. *)
  421. PROCEDURE GetHeapInfo*(VAR total, free, largest: SIZE);
  422. BEGIN
  423. total := 0; free := 0; largest := 0;
  424. END GetHeapInfo;
  425. PROCEDURE FullSweep-;
  426. (* Required for compatibility with ProcessInfo0.Mod *)
  427. END FullSweep;
  428. (* Init - Initialize the heap. *)
  429. PROCEDURE Init;
  430. BEGIN
  431. checkRoot := NIL; finalizeRoot := NIL; realtimeList := NIL;
  432. (* the Type desciptor is generated by the compiler, therefore the linker does not have ot patch anything any more *)
  433. freeBlockTag := SYSTEM.TYPECODE (FreeBlockDesc);
  434. systemBlockTag := SYSTEM.TYPECODE (SystemBlockDesc);
  435. recordBlockTag := SYSTEM.TYPECODE (RecordBlockDesc);
  436. protRecBlockTag := SYSTEM.TYPECODE (ProtRecBlockDesc);
  437. arrayBlockTag := SYSTEM.TYPECODE (ArrayBlockDesc);
  438. END Init;
  439. BEGIN
  440. Init;
  441. END Heaps.
  442. (*
  443. TraceHeap:
  444. 0 1 NR NEW record
  445. 1 2 NA/NV NEW array
  446. 2 4 NS SYSTEM.NEW
  447. 3 8 DR deallocate record #
  448. 4 16 DA deallocate array #
  449. 5 32 DS deallocate sysblk #
  450. 6 64 NT NewType
  451. 7 128
  452. 8 256 FB show free blocks #
  453. 9 512 DP deallocate protrec #
  454. 10 1024 finalizers
  455. 11 2048 live/dead #
  456. 12 4096 trace mark stack overflows #
  457. # influences timing
  458. *)
  459. (*
  460. 20.03.1998 pjm Started
  461. 17.08.1998 pjm FindRoots method
  462. 18.08.1998 pjm findPossibleRoots removed, use FindRoots method
  463. 09.10.1998 pjm NewRec with page alignment
  464. 21.01.1999 pjm Mark adapted for AosBuffers
  465. 26.01.1999 pjm Incorporated changes for new compiler
  466. 10.11.2000 pjm Finalizers
  467. 26.01.2001 pjm Removed trapReserve, reimplemented NewBlock
  468. 11.11.2004 lb Garbage collector with marking stack
  469. 19.06.2007 ug Garbage collector using meta data for stack inspection (cf. Objects)
  470. 11.07.2008 ug new heap data structures and adaption to GC
  471. *)