tinyheap.inc 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634
  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:{$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif}); 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. { This needs toi be fixed because
  129. HeapEnd and HeapSize are not updated correctly
  130. if p > HeapPtr then
  131. begin
  132. prev:=HeapPtr;
  133. HeapPtr:=p;
  134. end
  135. else }
  136. begin
  137. RegisterTinyHeapBlock(p,AllocSize);
  138. { Recursive call }
  139. SysGetMem:=SysGetMem(Size);
  140. exit;
  141. end;
  142. end
  143. else
  144. begin
  145. if ReturnNilIfGrowHeapFails then
  146. begin
  147. Result := nil;
  148. exit;
  149. end
  150. else
  151. HandleError(203);
  152. end;
  153. end;
  154. result := @PTinyHeapMemBlockSize(HeapPtr)[1];
  155. PTinyHeapMemBlockSize(HeapPtr)^ := size;
  156. HeapPtr := pointer(TTinyHeapPointerArithmeticType(HeapPtr)+AllocSize);
  157. if prev = nil then
  158. FreeList := HeapPtr
  159. else
  160. prev^.next := HeapPtr;
  161. end;
  162. {$ifdef DEBUG_TINY_HEAP}
  163. Writeln(HexStr(Result));
  164. {$endif DEBUG_TINY_HEAP}
  165. end;
  166. function TinyGetAlignedMem(Size, Alignment: ptruint): pointer;
  167. var
  168. mem: Pointer;
  169. memp: ptruint;
  170. begin
  171. if alignment <= sizeof(pointer) then
  172. result := GetMem(size)
  173. else
  174. begin
  175. mem := GetMem(Size+Alignment-1);
  176. memp := align(ptruint(mem), Alignment);
  177. InternalTinyFreeMem(mem, TTinyHeapPointerArithmeticType(memp)-TTinyHeapPointerArithmeticType(mem));
  178. result := pointer(memp);
  179. end;
  180. end;
  181. procedure InternalTinyFreeMem(Addr: Pointer; Size: PtrUInt);
  182. var
  183. p, prev: PTinyHeapBlock;
  184. begin
  185. p := FreeList;
  186. prev := nil;
  187. while (p<>HeapPtr) and (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(Addr)) do
  188. begin
  189. prev := p;
  190. p := p^.Next;
  191. end;
  192. { join with previous block? }
  193. if assigned(prev) and ((TTinyHeapPointerArithmeticType(prev)+DecodeTinyHeapFreeBlockSize(prev^.Size)) = TTinyHeapPointerArithmeticType(Addr)) then
  194. begin
  195. Addr:=prev;
  196. Size:=DecodeTinyHeapFreeBlockSize(prev^.size)+Size;
  197. end
  198. else
  199. if assigned(prev) then
  200. prev^.Next := Addr
  201. else
  202. FreeList := Addr;
  203. { join with next block? }
  204. if TTinyHeapPointerArithmeticType(p)=(TTinyHeapPointerArithmeticType(Addr)+Size) then
  205. begin
  206. if p=HeapPtr then
  207. HeapPtr:=Addr
  208. else
  209. begin
  210. PTinyHeapBlock(Addr)^.Next:=p^.Next;
  211. PTinyHeapBlock(Addr)^.Size:=EncodeTinyHeapFreeBlockSize(Size+DecodeTinyHeapFreeBlockSize(p^.Size));
  212. end;
  213. end
  214. else
  215. begin
  216. PTinyHeapBlock(Addr)^.Next:=p;
  217. PTinyHeapBlock(Addr)^.Size:=EncodeTinyHeapFreeBlockSize(Size);
  218. end;
  219. end;
  220. function SysFreeMem(p: Pointer): ptruint;
  221. var
  222. sz: ptruint;
  223. begin
  224. {$ifdef DEBUG_TINY_HEAP}
  225. Writeln('SysFreeMem(', HexStr(p), ')');
  226. {$endif DEBUG_TINY_HEAP}
  227. if p=nil then
  228. begin
  229. result:=0;
  230. exit;
  231. end;
  232. if (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(HeapOrg)) or
  233. (TTinyHeapPointerArithmeticType(p) >= TTinyHeapPointerArithmeticType(HeapPtr)) then
  234. HandleError(204);
  235. sz := Align(FindSize(p)+SizeOf(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
  236. InternalTinyFreeMem(@PTinyHeapMemBlockSize(p)[-1], sz);
  237. result := sz;
  238. end;
  239. function SysFreeMemSize(p: Pointer; Size: Ptruint): ptruint;
  240. begin
  241. result := SysFreeMem(p);
  242. end;
  243. function SysMemSize(p: pointer): ptruint;
  244. begin
  245. result := findsize(p);
  246. end;
  247. function SysTryResizeMem(var p: pointer; size: ptruint) : boolean;
  248. begin
  249. result := false;
  250. end;
  251. function SysAllocMem(size: ptruint): pointer;
  252. begin
  253. result := SysGetMem(size);
  254. if result<>nil then
  255. FillChar(result^,SysMemSize(result),0);
  256. end;
  257. function SysReAllocMem(var p: pointer; size: ptruint):pointer;
  258. var
  259. oldsize, OldAllocSize, NewAllocSize: ptruint;
  260. after_block, before_block, before_before_block: PTinyHeapBlock;
  261. after_block_size, before_block_size: PtrUInt;
  262. new_after_block: PTinyHeapBlock;
  263. begin
  264. {$ifdef DEBUG_TINY_HEAP}
  265. Write('SysReAllocMem(', HexStr(p), ',', size, ')=');
  266. {$endif DEBUG_TINY_HEAP}
  267. if size=0 then
  268. begin
  269. SysFreeMem(p);
  270. result := nil;
  271. p := nil;
  272. end
  273. else if p=nil then
  274. begin
  275. result := AllocMem(size);
  276. p := result;
  277. end
  278. else
  279. begin
  280. if (TTinyHeapPointerArithmeticType(p) < TTinyHeapPointerArithmeticType(HeapOrg)) or
  281. (TTinyHeapPointerArithmeticType(p) >= TTinyHeapPointerArithmeticType(HeapPtr)) then
  282. HandleError(204);
  283. oldsize := FindSize(p);
  284. OldAllocSize := align(oldsize+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
  285. NewAllocSize := align(size+sizeof(TTinyHeapMemBlockSize), TinyHeapAllocGranularity);
  286. if OldAllocSize = NewAllocSize then
  287. begin
  288. { old and new size are the same after alignment, so the memory block is already allocated }
  289. { we just need to update the size }
  290. PTinyHeapMemBlockSize(p)[-1] := size;
  291. if size > oldsize then
  292. FillChar((TTinyHeapPointerArithmeticType(p)+oldsize)^, size-oldsize, 0);
  293. end
  294. else if OldAllocSize > NewAllocSize then
  295. begin
  296. { we're decreasing the memory block size, so we can just free the remaining memory at the end }
  297. PTinyHeapMemBlockSize(p)[-1] := size;
  298. InternalTinyFreeMem(Pointer(TTinyHeapPointerArithmeticType(p)+(NewAllocSize-PtrUInt(SizeOf(TTinyHeapMemBlockSize)))), OldAllocSize-NewAllocSize);
  299. end
  300. else
  301. begin
  302. { we're increasing the memory block size. First, find if there are free memory blocks immediately
  303. before and after our memory block. }
  304. after_block := FreeList;
  305. before_block := nil;
  306. before_before_block := nil;
  307. while (after_block<>HeapPtr) and (TTinyHeapPointerArithmeticType(after_block) < TTinyHeapPointerArithmeticType(p)) do
  308. begin
  309. before_before_block := before_block;
  310. before_block := after_block;
  311. after_block := after_block^.Next;
  312. end;
  313. { is after_block immediately after our block? }
  314. if after_block=Pointer(TTinyHeapPointerArithmeticType(p)+(OldAllocSize-PtrUInt(SizeOf(TTinyHeapMemBlockSize)))) then
  315. begin
  316. if after_block = HeapPtr then
  317. after_block_size := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr))
  318. else
  319. after_block_size := DecodeTinyHeapFreeBlockSize(after_block^.size);
  320. end
  321. else
  322. after_block_size := 0;
  323. { is there enough room after the block? }
  324. if (OldAllocSize+after_block_size)>=NewAllocSize then
  325. begin
  326. if after_block = HeapPtr then
  327. begin
  328. HeapPtr:=Pointer(TTinyHeapPointerArithmeticType(HeapPtr)+(NewAllocSize-OldAllocSize));
  329. if assigned(before_block) then
  330. before_block^.Next := HeapPtr
  331. else
  332. FreeList := HeapPtr;
  333. end
  334. else
  335. begin
  336. if (NewAllocSize-OldAllocSize)=after_block_size then
  337. begin
  338. if assigned(before_block) then
  339. before_block^.Next := after_block^.Next
  340. else
  341. FreeList := after_block^.Next;
  342. end
  343. else
  344. begin
  345. new_after_block := PTinyHeapBlock(TTinyHeapPointerArithmeticType(after_block)+(NewAllocSize-OldAllocSize));
  346. new_after_block^.Next:=after_block^.Next;
  347. new_after_block^.Size:=EncodeTinyHeapFreeBlockSize(after_block_size-(NewAllocSize-OldAllocSize));
  348. if assigned(before_block) then
  349. before_block^.Next := new_after_block
  350. else
  351. FreeList := new_after_block;
  352. end;
  353. end;
  354. PTinyHeapMemBlockSize(p)[-1] := size;
  355. FillChar((TTinyHeapPointerArithmeticType(p)+oldsize)^, size-oldsize, 0);
  356. end
  357. else
  358. begin
  359. { is before_block immediately before our block? }
  360. if assigned(before_block) and (Pointer(TTinyHeapPointerArithmeticType(before_block)+DecodeTinyHeapFreeBlockSize(before_block^.Size))=Pointer(TTinyHeapPointerArithmeticType(p)-SizeOf(TTinyHeapMemBlockSize))) then
  361. before_block_size := DecodeTinyHeapFreeBlockSize(before_block^.Size)
  362. else
  363. before_block_size := 0;
  364. { if there's enough space, we can slide our current block back and reclaim before_block }
  365. if (before_block_size<NewAllocSize) and ((before_block_size+OldAllocSize+after_block_size)>=NewAllocSize) and
  366. { todo: implement this also for after_block_size>0 }
  367. (after_block_size>0) then
  368. begin
  369. if (before_block_size+OldAllocSize+after_block_size)=NewAllocSize then
  370. begin
  371. if after_block=HeapPtr then
  372. begin
  373. HeapPtr := HeapEnd;
  374. if assigned(before_before_block) then
  375. before_before_block^.Next := HeapPtr
  376. else
  377. FreeList := HeapPtr;
  378. end
  379. else
  380. if assigned(before_before_block) then
  381. before_before_block^.Next := after_block^.Next
  382. else
  383. FreeList := after_block^.Next;
  384. end;
  385. Result := Pointer(TTinyHeapPointerArithmeticType(before_block)+SizeOf(TTinyHeapMemBlockSize));
  386. Move(p^, Result^, oldsize);
  387. PTinyHeapMemBlockSize(before_block)^ := size;
  388. if (before_block_size+OldAllocSize+after_block_size)>NewAllocSize then
  389. begin
  390. new_after_block := PTinyHeapBlock(TTinyHeapPointerArithmeticType(before_block)+NewAllocSize);
  391. new_after_block^.Next:=after_block^.Next;
  392. new_after_block^.Size:=EncodeTinyHeapFreeBlockSize(before_block_size+after_block_size-(NewAllocSize-OldAllocSize));
  393. if assigned(before_before_block) then
  394. before_before_block^.Next := new_after_block
  395. else
  396. FreeList := new_after_block;
  397. end;
  398. FillChar((TTinyHeapPointerArithmeticType(Result)+oldsize)^, size-oldsize, 0);
  399. p := Result;
  400. end
  401. else
  402. begin
  403. result := AllocMem(size);
  404. if result <> nil then
  405. begin
  406. if oldsize > size then
  407. oldsize := size;
  408. move(pbyte(p)^, pbyte(result)^, oldsize);
  409. end;
  410. SysFreeMem(p);
  411. p := result;
  412. end;
  413. end;
  414. end;
  415. end;
  416. {$ifdef DEBUG_TINY_HEAP}
  417. Writeln(HexStr(result));
  418. {$endif DEBUG_TINY_HEAP}
  419. end;
  420. function MemAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
  421. var
  422. p: PTinyHeapBlock;
  423. begin
  424. MemAvail := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
  425. if MemAvail > 0 then
  426. Dec(MemAvail, SizeOf(TTinyHeapMemBlockSize));
  427. p := FreeList;
  428. while p <> HeapPtr do
  429. begin
  430. Inc(MemAvail, DecodeTinyHeapFreeBlockSize(p^.Size)-SizeOf(TTinyHeapMemBlockSize));
  431. p := p^.Next;
  432. end;
  433. end;
  434. function MaxAvail: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif};
  435. var
  436. p: PTinyHeapBlock;
  437. begin
  438. MaxAvail := PtrUInt(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
  439. p := FreeList;
  440. while p <> HeapPtr do
  441. begin
  442. if DecodeTinyHeapFreeBlockSize(p^.Size) > MaxAvail then
  443. MaxAvail := DecodeTinyHeapFreeBlockSize(p^.Size);
  444. p := p^.Next;
  445. end;
  446. if MaxAvail > 0 then
  447. Dec(MaxAvail, SizeOf(TTinyHeapMemBlockSize));
  448. end;
  449. procedure Mark(var p: Pointer);
  450. begin
  451. p := HeapPtr;
  452. end;
  453. procedure Release(var p: Pointer);
  454. begin
  455. HeapPtr := p;
  456. FreeList := p;
  457. end;
  458. procedure InternalTinyAlign(var AAddress: Pointer; ASize: PtrUInt);
  459. var
  460. alignment_inc: smallint;
  461. begin
  462. alignment_inc := TTinyHeapPointerArithmeticType(align(AAddress,TinyHeapAllocGranularity))-TTinyHeapPointerArithmeticType(AAddress);
  463. Inc(AAddress,alignment_inc);
  464. Dec(ASize,alignment_inc);
  465. Dec(ASize,ASize mod TinyHeapAllocGranularity);
  466. end;
  467. { Strongly simplified version of RegisterTinyHeapBlock, which can be used when
  468. the heap is only a single contiguous memory block. If you want to add
  469. multiple blocks to the heap, you should use RegisterTinyHeapBlock instead. }
  470. procedure RegisterTinyHeapBlock_Simple(AAddress: Pointer; ASize:{$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif});
  471. begin
  472. {$ifdef DEBUG_TINY_HEAP}
  473. Writeln('RegisterTinyHeapBlock_Simple(', HexStr(AAddress), ',', ASize, ')');
  474. {$endif DEBUG_TINY_HEAP}
  475. InternalTinyAlign(AAddress, ASize);
  476. HeapSize:=HeapSize + ASize;
  477. HeapOrg:=AAddress;
  478. HeapPtr:=AAddress;
  479. FreeList:=AAddress;
  480. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  481. end;
  482. { Strongly simplified version of RegisterTinyHeapBlock, which can be used when
  483. the heap is only a single contiguous memory block and the address and size
  484. are already aligned on a TinyHeapAllocGranularity boundary. }
  485. procedure RegisterTinyHeapBlock_Simple_Prealigned(AAddress: Pointer; ASize: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif});
  486. begin
  487. {$ifdef DEBUG_TINY_HEAP}
  488. Writeln('RegisterTinyHeapBlock_Simple_Prealigned(', HexStr(AAddress), ',', ASize, ')');
  489. {$endif DEBUG_TINY_HEAP}
  490. HeapOrg:=AAddress;
  491. HeapPtr:=AAddress;
  492. FreeList:=AAddress;
  493. HeapSize:=HeapSize + ASize;
  494. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  495. end;
  496. procedure RegisterTinyHeapBlock(AAddress: pointer; ASize: {$ifdef FPC_TINYHEAP_HUGE}LongInt{$else}PtrUInt{$endif});
  497. var
  498. alignment_inc: smallint;
  499. p: PTinyHeapBlock;
  500. begin
  501. {$ifdef DEBUG_TINY_HEAP}
  502. Writeln('RegisterTinyHeapBlock(', HexStr(AAddress), ',', ASize, ')');
  503. {$endif DEBUG_TINY_HEAP}
  504. InternalTinyAlign(AAddress, ASize);
  505. HeapSize:=HeapSize + ASize;
  506. if HeapOrg=nil then
  507. begin
  508. HeapOrg:=AAddress;
  509. HeapPtr:=AAddress;
  510. FreeList:=AAddress;
  511. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  512. end
  513. else
  514. begin
  515. if (TTinyHeapPointerArithmeticType(HeapOrg) > TTinyHeapPointerArithmeticType(AAddress)) then
  516. HeapOrg:=AAddress;
  517. if TTinyHeapPointerArithmeticType(AAddress) > TTinyHeapPointerArithmeticType(HeapEnd) then
  518. begin
  519. if TTinyHeapPointerArithmeticType(HeapPtr) = TTinyHeapPointerArithmeticType(HeapEnd) then
  520. begin
  521. if FreeList=HeapPtr then
  522. FreeList:=AAddress
  523. else
  524. begin
  525. p:=FreeList;
  526. while p^.Next<>HeapPtr do
  527. p:=p^.Next;
  528. PTinyHeapBlock(HeapPtr)^.Next:=AAddress;
  529. end;
  530. end
  531. else
  532. begin
  533. PTinyHeapBlock(HeapPtr)^.Size:=EncodeTinyHeapFreeBlockSize(TTinyHeapPointerArithmeticType(HeapEnd)-TTinyHeapPointerArithmeticType(HeapPtr));
  534. PTinyHeapBlock(HeapPtr)^.Next:=AAddress;
  535. end;
  536. HeapPtr:=AAddress;
  537. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize);
  538. end
  539. else if TTinyHeapPointerArithmeticType(AAddress) = TTinyHeapPointerArithmeticType(HeapEnd) then
  540. HeapEnd:=Pointer(TTinyHeapPointerArithmeticType(AAddress)+ASize)
  541. else
  542. InternalTinyFreeMem(AAddress, ASize);
  543. end;
  544. end;
  545. function SysGetFPCHeapStatus : TFPCHeapStatus;
  546. {
  547. TFPCHeapStatus = record
  548. MaxHeapSize,
  549. MaxHeapUsed,
  550. CurrHeapSize,
  551. CurrHeapUsed,
  552. CurrHeapFree : ptruint;
  553. end;
  554. }
  555. begin
  556. SysGetFPCHeapStatus.MaxHeapSize:=MaxAvail;
  557. { How can we compute this? }
  558. SysGetFPCHeapStatus.MaxHeapUsed:=0;
  559. SysGetFPCHeapStatus.CurrHeapFree:=MemAvail;
  560. SysGetFPCHeapStatus.CurrHeapUsed:=HeapSize-SysGetFPCHeapStatus.CurrHeapFree;
  561. SysGetFPCHeapStatus.CurrHeapSize:=HeapSize;
  562. end;
  563. function SysGetHeapStatus : THeapStatus;
  564. begin
  565. SysGetHeapStatus.TotalAddrSpace:= HeapSize;
  566. SysGetHeapStatus.TotalUncommitted:= 0;
  567. SysGetHeapStatus.TotalCommitted:= 0;
  568. SysGetHeapStatus.TotalAllocated:= HeapSize-MemAvail;
  569. SysGetHeapStatus.TotalFree:= MemAvail;
  570. SysGetHeapStatus.FreeSmall:= 0;
  571. SysGetHeapStatus.FreeBig:= 0;
  572. SysGetHeapStatus.Unused:= 0;
  573. SysGetHeapStatus.Overhead:= 0;
  574. SysGetHeapStatus.HeapErrorCode:= 0;
  575. end;
  576. procedure FinalizeHeap;
  577. begin
  578. end;