tinyheap.inc 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 2011 by the Free Pascal development team.
  4. Tiny heap manager for the i8086 near heap, embedded targets, etc.
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. { The heap, implemented here is TP7-compatible in the i8086 far data memory
  12. models. It's basically a linked list of free blocks, which are kept ordered by
  13. start address. The FreeList variable points to the start of the list. Each
  14. free block, except the last one, contains a TTinyHeapBlock structure, which
  15. holds the block size and a pointer to the next free block. The HeapPtr
  16. variable points to the last free block, indicating the end of the list. The
  17. last block is special in that it doesn't contain a TTinyHeapBlock structure.
  18. Instead its size is determined by the pointer difference (HeapEnd-HeapPtr).
  19. It *can* become zero sized, when all the memory inside of it is allocated, in
  20. which case, HeapPtr will become equal to HeapEnd. }
  21. {$ifdef FPC_TINYHEAP_HUGE}
  22. {$HugePointerArithmeticNormalization On}
  23. {$HugePointerComparisonNormalization On}
  24. {$endif FPC_TINYHEAP_HUGE}
  25. type
  26. { TTinyHeapMemBlockSize holds the size of an *allocated* memory block,
  27. and is written at position:
  28. memblockstart-sizeof(TTinyHeapMemBlockSize) }
  29. PTinyHeapMemBlockSize = ^TTinyHeapMemBlockSize; {$ifdef FPC_TINYHEAP_HUGE}huge;{$endif}
  30. TTinyHeapMemBlockSize = PtrUInt;
  31. { TTinyHeapFreeBlockSize holds the size of a *free* memory block, as a
  32. part of the TTinyHeapBlock structure }
  33. {$ifdef FPC_TINYHEAP_HUGE}
  34. TTinyHeapFreeBlockSize = record
  35. OfsSize: Word;
  36. SegSize: Word;
  37. end;
  38. {$else FPC_TINYHEAP_HUGE}
  39. TTinyHeapFreeBlockSize = PtrUInt;
  40. {$endif FPC_TINYHEAP_HUGE}
  41. TTinyHeapPointerArithmeticType = ^Byte; {$ifdef FPC_TINYHEAP_HUGE}huge;{$endif}
  42. PTinyHeapBlock = ^TTinyHeapBlock;
  43. TTinyHeapBlock = record
  44. Next: PTinyHeapBlock;
  45. Size: TTinyHeapFreeBlockSize;
  46. end;
  47. const
  48. TinyHeapMinBlock = sizeof(TTinyHeapBlock);
  49. TinyHeapAllocGranularity = sizeof(TTinyHeapBlock);
  50. procedure RegisterTinyHeapBlock(AAddress: pointer; ASize: ptruint); forward;
  51. function EncodeTinyHeapFreeBlockSize(Size: PtrUInt): TTinyHeapFreeBlockSize; inline;
  52. begin
  53. {$ifdef FPC_TINYHEAP_HUGE}
  54. EncodeTinyHeapFreeBlockSize.OfsSize := Size and 15;
  55. EncodeTinyHeapFreeBlockSize.SegSize := Size shr 4;
  56. {$else FPC_TINYHEAP_HUGE}
  57. EncodeTinyHeapFreeBlockSize := Size;
  58. {$endif FPC_TINYHEAP_HUGE}
  59. end;
  60. function DecodeTinyHeapFreeBlockSize(Size: TTinyHeapFreeBlockSize): PtrUInt; inline;
  61. begin
  62. {$ifdef FPC_TINYHEAP_HUGE}
  63. DecodeTinyHeapFreeBlockSize := (PtrUInt(Size.SegSize) shl 4) + Size.OfsSize;
  64. {$else FPC_TINYHEAP_HUGE}
  65. DecodeTinyHeapFreeBlockSize := Size;
  66. {$endif FPC_TINYHEAP_HUGE}
  67. end;
  68. procedure InternalTinyFreeMem(Addr: Pointer; Size: PtrUInt); forward;
  69. function FindSize(p: pointer): TTinyHeapMemBlockSize;
  70. begin
  71. FindSize := PTinyHeapMemBlockSize(p)[-1];
  72. end;
  73. function SysGetMem(Size: ptruint): pointer;
  74. var
  75. p, prev, p2: PTinyHeapBlock;
  76. AllocSize, RestSize: ptruint;
  77. begin
  78. {$ifdef DEBUG_TINY_HEAP}
  79. Write('SysGetMem(', Size, ')=');
  80. {$endif DEBUG_TINY_HEAP}
  81. AllocSize := align(size+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
  82. p := FreeList;
  83. prev := nil;
  84. while (p<>HeapPtr) and (DecodeTinyHeapFreeBlockSize(p^.Size) < AllocSize) do
  85. begin
  86. prev := p;
  87. p := p^.Next;
  88. end;
  89. if p<>HeapPtr then
  90. begin
  91. result := @PTinyHeapMemBlockSize(p)[1];
  92. if DecodeTinyHeapFreeBlockSize(p^.Size)-AllocSize >= TinyHeapMinBlock then
  93. RestSize := DecodeTinyHeapFreeBlockSize(p^.Size)-AllocSize
  94. else
  95. begin
  96. AllocSize := DecodeTinyHeapFreeBlockSize(p^.Size);
  97. RestSize := 0;
  98. end;
  99. if RestSize > 0 then
  100. begin
  101. p2 := pointer(TTinyHeapPointerArithmeticType(p)+AllocSize);
  102. p2^.Next := p^.Next;
  103. p2^.Size := EncodeTinyHeapFreeBlockSize(RestSize);
  104. if prev = nil then
  105. FreeList := p2
  106. else
  107. prev^.next := p2;
  108. end
  109. else
  110. begin
  111. if prev = nil then
  112. FreeList := p^.Next
  113. else
  114. prev^.next := p^.next;
  115. end;
  116. PTinyHeapMemBlockSize(p)^ := size;
  117. end
  118. else
  119. begin
  120. { p=HeapPtr }
  121. if PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr))<AllocSize then
  122. begin
  123. { align to 16 bytes }
  124. AllocSize:= (AllocSize + $f) and (not $f);
  125. p:=SysOSAlloc(AllocSize);
  126. if assigned(p) then
  127. begin
  128. if p > HeapPtr then
  129. begin
  130. prev:=HeapPtr;
  131. HeapPtr:=p;
  132. end
  133. else
  134. begin
  135. RegisterTinyHeapBlock(p,AllocSize);
  136. { Recursive call }
  137. SysGetMem:=SysGetMem(Size);
  138. exit;
  139. end;
  140. end
  141. else
  142. begin
  143. if ReturnNilIfGrowHeapFails then
  144. begin
  145. Result := nil;
  146. exit;
  147. end
  148. else
  149. HandleError(203);
  150. end;
  151. end;
  152. result := @PTinyHeapMemBlockSize(HeapPtr)[1];
  153. PTinyHeapMemBlockSize(HeapPtr)^ := size;
  154. HeapPtr := pointer(TTinyHeapPointerArithmeticType(HeapPtr)+AllocSize);
  155. if prev = nil then
  156. FreeList := HeapPtr
  157. else
  158. prev^.next := HeapPtr;
  159. end;
  160. {$ifdef DEBUG_TINY_HEAP}
  161. Writeln(HexStr(Result));
  162. {$endif DEBUG_TINY_HEAP}
  163. end;
  164. function TinyGetAlignedMem(Size, Alignment: ptruint): pointer;
  165. var
  166. mem: Pointer;
  167. memp: ptruint;
  168. begin
  169. if alignment <= sizeof(pointer) then
  170. result := GetMem(size)
  171. else
  172. begin
  173. mem := GetMem(Size+Alignment-1);
  174. memp := align(ptruint(mem), Alignment);
  175. InternalTinyFreeMem(mem, TTinyHeapPointerArithmeticType(memp)-TTinyHeapPointerArithmeticType(mem));
  176. result := pointer(memp);
  177. end;
  178. end;
  179. procedure InternalTinyFreeMem(Addr: Pointer; Size: PtrUInt);
  180. var
  181. p, prev: PTinyHeapBlock;
  182. begin
  183. p := FreeList;
  184. prev := nil;
  185. while (p<>HeapPtr) and (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(Addr)) do
  186. begin
  187. prev := p;
  188. p := p^.Next;
  189. end;
  190. { join with previous block? }
  191. if assigned(prev) and ((TTinyHeapPointerArithmeticType(prev)+DecodeTinyHeapFreeBlockSize(prev^.Size)) = TTinyHeapPointerArithmeticType(Addr)) then
  192. begin
  193. Addr:=prev;
  194. Size:=DecodeTinyHeapFreeBlockSize(prev^.size)+Size;
  195. end
  196. else
  197. if assigned(prev) then
  198. prev^.Next := Addr
  199. else
  200. FreeList := Addr;
  201. { join with next block? }
  202. if TTinyHeapPointerArithmeticType(p)=(TTinyHeapPointerArithmeticType(Addr)+Size) then
  203. begin
  204. if p=HeapPtr then
  205. HeapPtr:=Addr
  206. else
  207. begin
  208. PTinyHeapBlock(Addr)^.Next:=p^.Next;
  209. PTinyHeapBlock(Addr)^.Size:=EncodeTinyHeapFreeBlockSize(Size+DecodeTinyHeapFreeBlockSize(p^.Size));
  210. end;
  211. end
  212. else
  213. begin
  214. PTinyHeapBlock(Addr)^.Next:=p;
  215. PTinyHeapBlock(Addr)^.Size:=EncodeTinyHeapFreeBlockSize(Size);
  216. end;
  217. end;
  218. function SysFreeMem(p: Pointer): ptruint;
  219. var
  220. sz: ptruint;
  221. begin
  222. {$ifdef DEBUG_TINY_HEAP}
  223. Writeln('SysFreeMem(', HexStr(p), ')');
  224. {$endif DEBUG_TINY_HEAP}
  225. if p=nil then
  226. begin
  227. result:=0;
  228. exit;
  229. end;
  230. if (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(HeapOrg)) or
  231. (TTinyHeapPointerArithmeticType(p) >= TTinyHeapPointerArithmeticType(HeapPtr)) then
  232. HandleError(204);
  233. sz := Align(FindSize(p)+SizeOf(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
  234. InternalTinyFreeMem(@PTinyHeapMemBlockSize(p)[-1], sz);
  235. result := sz;
  236. end;
  237. function SysFreeMemSize(p: Pointer; Size: Ptruint): ptruint;
  238. begin
  239. result := SysFreeMem(p);
  240. end;
  241. function SysMemSize(p: pointer): ptruint;
  242. begin
  243. result := findsize(p);
  244. end;
  245. function SysTryResizeMem(var p: pointer; size: ptruint) : boolean;
  246. begin
  247. result := false;
  248. end;
  249. function SysAllocMem(size: ptruint): pointer;
  250. begin
  251. result := SysGetMem(size);
  252. if result<>nil then
  253. FillChar(result^,SysMemSize(result),0);
  254. end;
  255. function SysReAllocMem(var p: pointer; size: ptruint):pointer;
  256. var
  257. oldsize, OldAllocSize, NewAllocSize: ptruint;
  258. after_block, before_block, before_before_block: PTinyHeapBlock;
  259. after_block_size, before_block_size: PtrUInt;
  260. new_after_block: PTinyHeapBlock;
  261. begin
  262. {$ifdef DEBUG_TINY_HEAP}
  263. Write('SysReAllocMem(', HexStr(p), ',', size, ')=');
  264. {$endif DEBUG_TINY_HEAP}
  265. if size=0 then
  266. begin
  267. SysFreeMem(p);
  268. result := nil;
  269. p := nil;
  270. end
  271. else if p=nil then
  272. begin
  273. result := AllocMem(size);
  274. p := result;
  275. end
  276. else
  277. begin
  278. if (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(HeapOrg)) or
  279. (TTinyHeapPointerArithmeticType(p) >= TTinyHeapPointerArithmeticType(HeapPtr)) then
  280. HandleError(204);
  281. oldsize := FindSize(p);
  282. OldAllocSize := align(oldsize+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
  283. NewAllocSize := align(size+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
  284. if OldAllocSize = NewAllocSize then
  285. begin
  286. { old and new size are the same after alignment, so the memory block is already allocated }
  287. { we just need to update the size }
  288. PTinyHeapMemBlockSize(p)[-1] := size;
  289. if size > oldsize then
  290. FillChar((TTinyHeapPointerArithmeticType(p)+oldsize)^, size-oldsize, 0);
  291. end
  292. else if OldAllocSize > NewAllocSize then
  293. begin
  294. { we're decreasing the memory block size, so we can just free the remaining memory at the end }
  295. PTinyHeapMemBlockSize(p)[-1] := size;
  296. InternalTinyFreeMem(Pointer(TTinyHeapPointerArithmeticType(p)+(NewAllocSize-PtrUInt(SizeOf(TTinyHeapMemBlockSize)))), OldAllocSize-NewAllocSize);
  297. end
  298. else
  299. begin
  300. { we're increasing the memory block size. First, find if there are free memory blocks immediately
  301. before and after our memory block. }
  302. after_block := FreeList;
  303. before_block := nil;
  304. before_before_block := nil;
  305. while (after_block<>HeapPtr) and (TTinyHeapPointerArithmeticType(after_block) < TTinyHeapPointerArithmeticType(p)) do
  306. begin
  307. before_before_block := before_block;
  308. before_block := after_block;
  309. after_block := after_block^.Next;
  310. end;
  311. { is after_block immediately after our block? }
  312. if after_block=Pointer(TTinyHeapPointerArithmeticType(p)+(OldAllocSize-PtrUInt(SizeOf(TTinyHeapMemBlockSize)))) then
  313. begin
  314. if after_block = HeapPtr then
  315. after_block_size := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr))
  316. else
  317. after_block_size := DecodeTinyHeapFreeBlockSize(after_block^.size);
  318. end
  319. else
  320. after_block_size := 0;
  321. { is there enough room after the block? }
  322. if (OldAllocSize+after_block_size)>=NewAllocSize then
  323. begin
  324. if after_block = HeapPtr then
  325. begin
  326. HeapPtr:=Pointer(TTinyHeapPointerArithmeticType(HeapPtr)+(NewAllocSize-OldAllocSize));
  327. if assigned(before_block) then
  328. before_block^.Next := HeapPtr
  329. else
  330. FreeList := HeapPtr;
  331. end
  332. else
  333. begin
  334. if (NewAllocSize-OldAllocSize)=after_block_size then
  335. begin
  336. if assigned(before_block) then
  337. before_block^.Next := after_block^.Next
  338. else
  339. FreeList := after_block^.Next;
  340. end
  341. else
  342. begin
  343. new_after_block := PTinyHeapBlock(TTinyHeapPointerArithmeticType(after_block)+(NewAllocSize-OldAllocSize));
  344. new_after_block^.Next:=after_block^.Next;
  345. new_after_block^.Size:=EncodeTinyHeapFreeBlockSize(after_block_size-(NewAllocSize-OldAllocSize));
  346. if assigned(before_block) then
  347. before_block^.Next := new_after_block
  348. else
  349. FreeList := new_after_block;
  350. end;
  351. end;
  352. PTinyHeapMemBlockSize(p)[-1] := size;
  353. FillChar((TTinyHeapPointerArithmeticType(p)+oldsize)^, size-oldsize, 0);
  354. end
  355. else
  356. begin
  357. { is before_block immediately before our block? }
  358. if assigned(before_block) and (Pointer(TTinyHeapPointerArithmeticType(before_block)+DecodeTinyHeapFreeBlockSize(before_block^.Size))=Pointer(TTinyHeapPointerArithmeticType(p)-SizeOf(TTinyHeapMemBlockSize))) then
  359. before_block_size := DecodeTinyHeapFreeBlockSize(before_block^.Size)
  360. else
  361. before_block_size := 0;
  362. { if there's enough space, we can slide our current block back and reclaim before_block }
  363. if (before_block_size<NewAllocSize) and ((before_block_size+OldAllocSize+after_block_size)>=NewAllocSize) and
  364. { todo: implement this also for after_block_size>0 }
  365. (after_block_size>0) then
  366. begin
  367. if (before_block_size+OldAllocSize+after_block_size)=NewAllocSize then
  368. begin
  369. if after_block=HeapPtr then
  370. begin
  371. HeapPtr := HeapEnd;
  372. if assigned(before_before_block) then
  373. before_before_block^.Next := HeapPtr
  374. else
  375. FreeList := HeapPtr;
  376. end
  377. else
  378. if assigned(before_before_block) then
  379. before_before_block^.Next := after_block^.Next
  380. else
  381. FreeList := after_block^.Next;
  382. end;
  383. Result := Pointer(TTinyHeapPointerArithmeticType(before_block)+SizeOf(TTinyHeapMemBlockSize));
  384. Move(p^, Result^, oldsize);
  385. PTinyHeapMemBlockSize(before_block)^ := size;
  386. if (before_block_size+OldAllocSize+after_block_size)>NewAllocSize then
  387. begin
  388. new_after_block := PTinyHeapBlock(TTinyHeapPointerArithmeticType(before_block)+NewAllocSize);
  389. new_after_block^.Next:=after_block^.Next;
  390. new_after_block^.Size:=EncodeTinyHeapFreeBlockSize(before_block_size+after_block_size-(NewAllocSize-OldAllocSize));
  391. if assigned(before_before_block) then
  392. before_before_block^.Next := new_after_block
  393. else
  394. FreeList := new_after_block;
  395. end;
  396. FillChar((TTinyHeapPointerArithmeticType(Result)+oldsize)^, size-oldsize, 0);
  397. p := Result;
  398. end
  399. else
  400. begin
  401. result := AllocMem(size);
  402. if result <> nil then
  403. begin
  404. if oldsize > size then
  405. oldsize := size;
  406. move(pbyte(p)^, pbyte(result)^, oldsize);
  407. end;
  408. SysFreeMem(p);
  409. p := result;
  410. end;
  411. end;
  412. end;
  413. end;
  414. {$ifdef DEBUG_TINY_HEAP}
  415. Writeln(HexStr(result));
  416. {$endif DEBUG_TINY_HEAP}
  417. end;
  418. function MemAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
  419. var
  420. p: PTinyHeapBlock;
  421. begin
  422. MemAvail := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
  423. if MemAvail > 0 then
  424. Dec(MemAvail, SizeOf(TTinyHeapMemBlockSize));
  425. p := FreeList;
  426. while p <> HeapPtr do
  427. begin
  428. Inc(MemAvail, DecodeTinyHeapFreeBlockSize(p^.Size)-SizeOf(TTinyHeapMemBlockSize));
  429. p := p^.Next;
  430. end;
  431. end;
  432. function MaxAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
  433. var
  434. p: PTinyHeapBlock;
  435. begin
  436. MaxAvail := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
  437. p := FreeList;
  438. while p <> HeapPtr do
  439. begin
  440. if DecodeTinyHeapFreeBlockSize(p^.Size) > MaxAvail then
  441. MaxAvail := DecodeTinyHeapFreeBlockSize(p^.Size);
  442. p := p^.Next;
  443. end;
  444. if MaxAvail > 0 then
  445. Dec(MaxAvail, SizeOf(TTinyHeapMemBlockSize));
  446. end;
  447. procedure Mark(var p: Pointer);
  448. begin
  449. p := HeapPtr;
  450. end;
  451. procedure Release(var p: Pointer);
  452. begin
  453. HeapPtr := p;
  454. FreeList := p;
  455. end;
  456. procedure InternalTinyAlign(var AAddress: Pointer; ASize: PtrUInt);
  457. var
  458. alignment_inc: smallint;
  459. begin
  460. alignment_inc := TTinyHeapPointerArithmeticType(align(AAddress,TinyHeapAllocGranularity))-TTinyHeapPointerArithmeticType(AAddress);
  461. Inc(AAddress,alignment_inc);
  462. Dec(ASize,alignment_inc);
  463. Dec(ASize,ASize mod TinyHeapAllocGranularity);
  464. end;
  465. { Strongly simplified version of RegisterTinyHeapBlock, which can be used when
  466. the heap is only a single contiguous memory block. If you want to add
  467. multiple blocks to the heap, you should use RegisterTinyHeapBlock instead. }
  468. procedure RegisterTinyHeapBlock_Simple(AAddress: Pointer; ASize: PtrUInt);
  469. begin
  470. {$ifdef DEBUG_TINY_HEAP}
  471. Writeln('RegisterTinyHeapBlock_Simple(', HexStr(AAddress), ',', ASize, ')');
  472. {$endif DEBUG_TINY_HEAP}
  473. InternalTinyAlign(AAddress, ASize);
  474. HeapSize:=HeapSize + ASize;
  475. HeapOrg:=AAddress;
  476. HeapPtr:=AAddress;
  477. FreeList:=AAddress;
  478. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  479. end;
  480. { Strongly simplified version of RegisterTinyHeapBlock, which can be used when
  481. the heap is only a single contiguous memory block and the address and size
  482. are already aligned on a TinyHeapAllocGranularity boundary. }
  483. procedure RegisterTinyHeapBlock_Simple_Prealigned(AAddress: Pointer; ASize: PtrUInt);
  484. begin
  485. {$ifdef DEBUG_TINY_HEAP}
  486. Writeln('RegisterTinyHeapBlock_Simple_Prealigned(', HexStr(AAddress), ',', ASize, ')');
  487. {$endif DEBUG_TINY_HEAP}
  488. HeapOrg:=AAddress;
  489. HeapPtr:=AAddress;
  490. FreeList:=AAddress;
  491. HeapSize:=HeapSize + ASize;
  492. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  493. end;
  494. procedure RegisterTinyHeapBlock(AAddress: pointer; ASize: ptruint);
  495. var
  496. alignment_inc: smallint;
  497. p: PTinyHeapBlock;
  498. begin
  499. {$ifdef DEBUG_TINY_HEAP}
  500. Writeln('RegisterTinyHeapBlock(', HexStr(AAddress), ',', ASize, ')');
  501. {$endif DEBUG_TINY_HEAP}
  502. InternalTinyAlign(AAddress, ASize);
  503. HeapSize:=HeapSize + ASize;
  504. if HeapOrg=nil then
  505. begin
  506. HeapOrg:=AAddress;
  507. HeapPtr:=AAddress;
  508. FreeList:=AAddress;
  509. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  510. end
  511. else
  512. begin
  513. if (TTinyHeapPointerArithmeticType(HeapOrg) > TTinyHeapPointerArithmeticType(AAddress)) then
  514. HeapOrg:=AAddress;
  515. if TTinyHeapPointerArithmeticType(AAddress) > TTinyHeapPointerArithmeticType(HeapEnd) then
  516. begin
  517. if TTinyHeapPointerArithmeticType(HeapPtr) = TTinyHeapPointerArithmeticType(HeapEnd) then
  518. begin
  519. if FreeList=HeapPtr then
  520. FreeList:=AAddress
  521. else
  522. begin
  523. p:=FreeList;
  524. while p^.Next<>HeapPtr do
  525. p:=p^.Next;
  526. PTinyHeapBlock(HeapPtr)^.Next:=AAddress;
  527. end;
  528. end
  529. else
  530. begin
  531. PTinyHeapBlock(HeapPtr)^.Size:=EncodeTinyHeapFreeBlockSize(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
  532. PTinyHeapBlock(HeapPtr)^.Next:=AAddress;
  533. end;
  534. HeapPtr:=AAddress;
  535. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  536. end
  537. else if TTinyHeapPointerArithmeticType(AAddress) = TTinyHeapPointerArithmeticType(HeapEnd) then
  538. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize)
  539. else
  540. InternalTinyFreeMem(AAddress, ASize);
  541. end;
  542. end;
  543. function SysGetFPCHeapStatus : TFPCHeapStatus;
  544. {
  545. TFPCHeapStatus = record
  546. MaxHeapSize,
  547. MaxHeapUsed,
  548. CurrHeapSize,
  549. CurrHeapUsed,
  550. CurrHeapFree : ptruint;
  551. end;
  552. }
  553. begin
  554. SysGetFPCHeapStatus.MaxHeapSize:=MaxAvail;
  555. { How can we compute this? }
  556. SysGetFPCHeapStatus.MaxHeapUsed:=0;
  557. SysGetFPCHeapStatus.CurrHeapFree:=MemAvail;
  558. SysGetFPCHeapStatus.CurrHeapUsed:=HeapSize-SysGetFPCHeapStatus.CurrHeapFree;
  559. SysGetFPCHeapStatus.CurrHeapSize:=HeapSize;
  560. end;
  561. function SysGetHeapStatus : THeapStatus;
  562. begin
  563. SysGetHeapStatus.TotalAddrSpace:= HeapSize;
  564. SysGetHeapStatus.TotalUncommitted:= 0;
  565. SysGetHeapStatus.TotalCommitted:= 0;
  566. SysGetHeapStatus.TotalAllocated:= HeapSize-MemAvail;
  567. SysGetHeapStatus.TotalFree:= MemAvail;
  568. SysGetHeapStatus.FreeSmall:= 0;
  569. SysGetHeapStatus.FreeBig:= 0;
  570. SysGetHeapStatus.Unused:= 0;
  571. SysGetHeapStatus.Overhead:= 0;
  572. SysGetHeapStatus.HeapErrorCode:= 0;
  573. end;
  574. procedure FinalizeHeap;
  575. begin
  576. end;