heap.inc 33 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by the Free Pascal development team.
  4. functions for heap management in the data segment
  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. {****************************************************************************}
  12. { Try to find the best matching block in general freelist }
  13. { define BESTMATCH}
  14. { DEBUG: Dump info when the heap needs to grow }
  15. { define DUMPGROW}
  16. const
  17. {$ifdef CPU64}
  18. blocksize = 32; { at least size of freerecord }
  19. blockshift = 5; { shr value for blocksize=2^blockshift}
  20. maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
  21. {$else}
  22. blocksize = 16; { at least size of freerecord }
  23. blockshift = 4; { shr value for blocksize=2^blockshift}
  24. maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
  25. {$endif}
  26. maxblockindex = maxblocksize div blocksize; { highest index in array of lists of memchunks }
  27. maxreusebigger = 8; { max reuse bigger tries }
  28. { common flags }
  29. fixedsizeflag = 1; { flag if the block is of fixed size }
  30. { memchunk var flags }
  31. usedflag = 2; { flag if the block is used or not }
  32. lastblockflag = 4; { flag if the block is the last in os chunk }
  33. firstblockflag = 8; { flag if the block is the first in os chunk }
  34. sizemask = not(blocksize-1);
  35. fixedsizemask = sizemask and $ffff;
  36. {****************************************************************************}
  37. {$ifdef DUMPGROW}
  38. {$define DUMPBLOCKS}
  39. {$endif}
  40. { Forward defines }
  41. procedure SysHeapMutexInit;forward;
  42. procedure SysHeapMutexDone;forward;
  43. procedure SysHeapMutexLock;forward;
  44. procedure SysHeapMutexUnlock;forward;
  45. { Memory manager }
  46. const
  47. MemoryManager: TMemoryManager = (
  48. NeedLock: true;
  49. GetMem: @SysGetMem;
  50. FreeMem: @SysFreeMem;
  51. FreeMemSize: @SysFreeMemSize;
  52. AllocMem: @SysAllocMem;
  53. ReAllocMem: @SysReAllocMem;
  54. MemSize: @SysMemSize;
  55. GetHeapStatus: @SysGetHeapStatus;
  56. GetFPCHeapStatus: @SysGetFPCHeapStatus;
  57. );
  58. MemoryMutexManager: TMemoryMutexManager = (
  59. MutexInit: @SysHeapMutexInit;
  60. MutexDone: @SysHeapMutexDone;
  61. MutexLock: @SysHeapMutexLock;
  62. MutexUnlock: @SysHeapMutexUnlock;
  63. );
  64. type
  65. poschunk = ^toschunk;
  66. { keep size of this record dividable by 16 }
  67. toschunk = record
  68. size,
  69. used,
  70. chunkindex : ptrint;
  71. next,
  72. prev : poschunk;
  73. {$ifdef CPU64}
  74. pad1 : array[0..0] of pointer;
  75. {$else CPU64}
  76. pad1 : array[0..2] of pointer;
  77. {$endif CPU64}
  78. end;
  79. { make sure size field is in the same position for every memchunk variant }
  80. pmemchunk_fixed = ^tmemchunk_fixed;
  81. tmemchunk_fixed = record
  82. poc : poschunk;
  83. size : ptrint;
  84. next_fixed,
  85. prev_fixed : pmemchunk_fixed;
  86. end;
  87. pmemchunk_var = ^tmemchunk_var;
  88. tmemchunk_var = record
  89. prevsize : ptrint;
  90. size : ptrint;
  91. next_var,
  92. prev_var : pmemchunk_var;
  93. end;
  94. { ``header'', ie. size of structure valid when chunk is in use }
  95. { should correspond to tmemchunk_var_hdr structure starting with the
  96. last field. Reason is that the overlap is starting from the end of the
  97. record.
  98. Alignment is 8 bytes for 32bit machines. This required
  99. for x86 MMX/SSE and for sparc Double values }
  100. tmemchunk_fixed_hdr = record
  101. poc : poschunk;
  102. size : ptrint;
  103. end;
  104. tmemchunk_var_hdr = record
  105. prevsize,
  106. size : ptrint;
  107. end;
  108. tfreelists = array[1..maxblockindex] of pmemchunk_fixed;
  109. pfreelists = ^tfreelists;
  110. var
  111. internal_status : TFPCHeapStatus;
  112. freelists_fixed : tfreelists;
  113. freelists_free_chunk : array[1..maxblockindex] of boolean;
  114. freelist_var : pmemchunk_var;
  115. freeoslist : poschunk;
  116. freeoslistcount : dword;
  117. {*****************************************************************************
  118. Memory Manager
  119. *****************************************************************************}
  120. procedure SetMemoryMutexManager(var MutexMgr: TMemoryMutexManager);
  121. begin
  122. { Release old mutexmanager, the default manager does nothing so
  123. calling this without initializing is safe }
  124. MemoryMutexManager.MutexDone;
  125. { Copy new mutexmanager }
  126. MemoryMutexManager := MutexMgr;
  127. { Init new mutexmanager }
  128. MemoryMutexManager.MutexInit;
  129. end;
  130. procedure GetMemoryManager(var MemMgr:TMemoryManager);
  131. begin
  132. if IsMultiThread and MemoryManager.NeedLock then
  133. begin
  134. try
  135. MemoryMutexManager.MutexLock;
  136. MemMgr := MemoryManager;
  137. finally
  138. MemoryMutexManager.MutexUnlock;
  139. end;
  140. end
  141. else
  142. begin
  143. MemMgr := MemoryManager;
  144. end;
  145. end;
  146. procedure SetMemoryManager(const MemMgr:TMemoryManager);
  147. begin
  148. if IsMultiThread and MemoryManager.NeedLock then
  149. begin
  150. try
  151. MemoryMutexManager.MutexLock;
  152. MemoryManager := MemMgr;
  153. finally
  154. MemoryMutexManager.MutexUnlock;
  155. end;
  156. end
  157. else
  158. begin
  159. MemoryManager := MemMgr;
  160. end;
  161. end;
  162. function IsMemoryManagerSet:Boolean;
  163. begin
  164. if IsMultiThread and MemoryManager.NeedLock then
  165. begin
  166. try
  167. MemoryMutexManager.MutexLock;
  168. IsMemoryManagerSet := (MemoryManager.GetMem<>@SysGetMem) or
  169. (MemoryManager.FreeMem<>@SysFreeMem);
  170. finally
  171. MemoryMutexManager.MutexUnlock;
  172. end;
  173. end
  174. else
  175. begin
  176. IsMemoryManagerSet := (MemoryManager.GetMem<>@SysGetMem) or
  177. (MemoryManager.FreeMem<>@SysFreeMem);
  178. end;
  179. end;
  180. procedure GetMem(Var p:pointer;Size:ptrint);
  181. begin
  182. if IsMultiThread and MemoryManager.NeedLock then
  183. begin
  184. try
  185. MemoryMutexManager.MutexLock;
  186. p := MemoryManager.GetMem(Size);
  187. finally
  188. MemoryMutexManager.MutexUnlock;
  189. end;
  190. end
  191. else
  192. begin
  193. p := MemoryManager.GetMem(Size);
  194. end;
  195. end;
  196. procedure GetMemory(Var p:pointer;Size:ptrint);
  197. begin
  198. GetMem(p,size);
  199. end;
  200. procedure FreeMem(p:pointer;Size:ptrint);
  201. begin
  202. if IsMultiThread and MemoryManager.NeedLock then
  203. begin
  204. try
  205. MemoryMutexManager.MutexLock;
  206. MemoryManager.FreeMemSize(p,Size);
  207. finally
  208. MemoryMutexManager.MutexUnlock;
  209. end;
  210. end
  211. else
  212. begin
  213. MemoryManager.FreeMemSize(p,Size);
  214. end;
  215. end;
  216. procedure FreeMemory(p:pointer;Size:ptrint);
  217. begin
  218. FreeMem(p,size);
  219. end;
  220. function GetHeapStatus:THeapStatus;
  221. begin
  222. if IsMultiThread and MemoryManager.NeedLock then
  223. begin
  224. try
  225. MemoryMutexManager.MutexLock;
  226. result:=MemoryManager.GetHeapStatus();
  227. finally
  228. MemoryMutexManager.MutexUnlock;
  229. end;
  230. end
  231. else
  232. begin
  233. result:=MemoryManager.GetHeapStatus();
  234. end;
  235. end;
  236. function GetFPCHeapStatus:TFPCHeapStatus;
  237. begin
  238. if IsMultiThread and MemoryManager.NeedLock then
  239. begin
  240. try
  241. MemoryMutexManager.MutexLock;
  242. result:=MemoryManager.GetFPCHeapStatus();
  243. finally
  244. MemoryMutexManager.MutexUnlock;
  245. end;
  246. end
  247. else
  248. begin
  249. Result:=MemoryManager.GetFPCHeapStatus();
  250. end;
  251. end;
  252. function MemSize(p:pointer):ptrint;
  253. begin
  254. if IsMultiThread and MemoryManager.NeedLock then
  255. begin
  256. try
  257. MemoryMutexManager.MutexLock;
  258. MemSize := MemoryManager.MemSize(p);
  259. finally
  260. MemoryMutexManager.MutexUnlock;
  261. end;
  262. end
  263. else
  264. begin
  265. MemSize := MemoryManager.MemSize(p);
  266. end;
  267. end;
  268. { Delphi style }
  269. function FreeMem(p:pointer):ptrint;[Public,Alias:'FPC_FREEMEM_X'];
  270. begin
  271. if IsMultiThread and MemoryManager.NeedLock then
  272. begin
  273. try
  274. MemoryMutexManager.MutexLock;
  275. Freemem := MemoryManager.FreeMem(p);
  276. finally
  277. MemoryMutexManager.MutexUnlock;
  278. end;
  279. end
  280. else
  281. begin
  282. Freemem := MemoryManager.FreeMem(p);
  283. end;
  284. end;
  285. function FreeMemory(p:pointer):ptrint;
  286. begin
  287. FreeMemory := FreeMem(p);
  288. end;
  289. function GetMem(size:ptrint):pointer;
  290. begin
  291. if IsMultiThread and MemoryManager.NeedLock then
  292. begin
  293. try
  294. MemoryMutexManager.MutexLock;
  295. GetMem := MemoryManager.GetMem(Size);
  296. finally
  297. MemoryMutexManager.MutexUnlock;
  298. end;
  299. end
  300. else
  301. begin
  302. GetMem := MemoryManager.GetMem(Size);
  303. end;
  304. end;
  305. function GetMemory(size:ptrint):pointer;
  306. begin
  307. GetMemory := Getmem(size);
  308. end;
  309. function AllocMem(Size:ptrint):pointer;
  310. begin
  311. if IsMultiThread and MemoryManager.NeedLock then
  312. begin
  313. try
  314. MemoryMutexManager.MutexLock;
  315. AllocMem := MemoryManager.AllocMem(size);
  316. finally
  317. MemoryMutexManager.MutexUnlock;
  318. end;
  319. end
  320. else
  321. begin
  322. AllocMem := MemoryManager.AllocMem(size);
  323. end;
  324. end;
  325. function ReAllocMem(var p:pointer;Size:ptrint):pointer;
  326. begin
  327. if IsMultiThread and MemoryManager.NeedLock then
  328. begin
  329. try
  330. MemoryMutexManager.MutexLock;
  331. ReAllocMem := MemoryManager.ReAllocMem(p,size);
  332. finally
  333. MemoryMutexManager.MutexUnlock;
  334. end;
  335. end
  336. else
  337. begin
  338. ReAllocMem := MemoryManager.ReAllocMem(p,size);
  339. end;
  340. end;
  341. function ReAllocMemory(var p:pointer;Size:ptrint):pointer;
  342. begin
  343. ReAllocMemory := ReAllocMem(p,size);
  344. end;
  345. { Needed for calls from Assembler }
  346. function fpc_getmem(size:ptrint):pointer;compilerproc;[public,alias:'FPC_GETMEM'];
  347. begin
  348. if IsMultiThread and MemoryManager.NeedLock then
  349. begin
  350. try
  351. MemoryMutexManager.MutexLock;
  352. fpc_GetMem := MemoryManager.GetMem(size);
  353. finally
  354. MemoryMutexManager.MutexUnlock;
  355. end;
  356. end
  357. else
  358. begin
  359. fpc_GetMem := MemoryManager.GetMem(size);
  360. end;
  361. end;
  362. procedure fpc_freemem(p:pointer);compilerproc;[public,alias:'FPC_FREEMEM'];
  363. begin
  364. if IsMultiThread and MemoryManager.NeedLock then
  365. begin
  366. try
  367. MemoryMutexManager.MutexLock;
  368. if p <> nil then
  369. MemoryManager.FreeMem(p);
  370. finally
  371. MemoryMutexManager.MutexUnlock;
  372. end;
  373. end
  374. else
  375. begin
  376. if p <> nil then
  377. MemoryManager.FreeMem(p);
  378. end;
  379. end;
  380. {*****************************************************************************
  381. GetHeapStatus
  382. *****************************************************************************}
  383. function SysGetFPCHeapStatus:TFPCHeapStatus;
  384. begin
  385. internal_status.CurrHeapFree:=internal_status.CurrHeapSize-internal_status.CurrHeapUsed;
  386. result:=internal_status;
  387. end;
  388. function SysGetHeapStatus :THeapStatus;
  389. begin
  390. internal_status.CurrHeapFree:=internal_status.CurrHeapSize-internal_status.CurrHeapUsed;
  391. result.TotalAllocated :=internal_status.CurrHeapUsed;
  392. result.TotalFree :=internal_status.CurrHeapFree;
  393. result.TotalAddrSpace :=0;
  394. result.TotalUncommitted :=0;
  395. result.TotalCommitted :=0;
  396. result.FreeSmall :=0;
  397. result.FreeBig :=0;
  398. result.Unused :=0;
  399. result.Overhead :=0;
  400. result.HeapErrorCode :=0;
  401. end;
  402. {$ifdef DUMPBLOCKS} // TODO
  403. procedure DumpBlocks;
  404. var
  405. s,i,j : ptrint;
  406. hpfixed : pmemchunk_fixed;
  407. hpvar : pmemchunk_var;
  408. begin
  409. { fixed freelist }
  410. for i := 1 to maxblockindex do
  411. begin
  412. hpfixed := freelists_fixed[i];
  413. j := 0;
  414. while assigned(hpfixed) do
  415. begin
  416. inc(j);
  417. hpfixed := hpfixed^.next_fixed;
  418. end;
  419. writeln('Block ',i*blocksize,': ',j);
  420. end;
  421. { var freelist }
  422. hpvar := freelist_var;
  423. j := 0;
  424. s := 0;
  425. while assigned(hpvar) do
  426. begin
  427. inc(j);
  428. if hpvar^.size>s then
  429. s := hpvar^.size;
  430. hpvar := hpvar^.next_var;
  431. end;
  432. writeln('Variable: ',j,' maxsize: ',s);
  433. end;
  434. {$endif}
  435. {*****************************************************************************
  436. List adding/removal
  437. *****************************************************************************}
  438. procedure append_to_list_var(pmc: pmemchunk_var);inline;
  439. begin
  440. pmc^.prev_var := nil;
  441. pmc^.next_var := freelist_var;
  442. if freelist_var<>nil then
  443. freelist_var^.prev_var := pmc;
  444. freelist_var := pmc;
  445. end;
  446. procedure remove_from_list_var(pmc: pmemchunk_var);inline;
  447. begin
  448. if assigned(pmc^.next_var) then
  449. pmc^.next_var^.prev_var := pmc^.prev_var;
  450. if assigned(pmc^.prev_var) then
  451. pmc^.prev_var^.next_var := pmc^.next_var
  452. else
  453. freelist_var := pmc^.next_var;
  454. end;
  455. procedure append_to_oslist(poc: poschunk);
  456. begin
  457. { decide whether to free block or add to list }
  458. {$ifdef HAS_SYSOSFREE}
  459. if (freeoslistcount >= MaxKeptOSChunks) or
  460. (poc^.size > growheapsize2) then
  461. begin
  462. dec(internal_status.currheapsize, poc^.size);
  463. SysOSFree(poc, poc^.size);
  464. end
  465. else
  466. begin
  467. {$endif}
  468. poc^.prev := nil;
  469. poc^.next := freeoslist;
  470. if freeoslist <> nil then
  471. freeoslist^.prev := poc;
  472. freeoslist := poc;
  473. inc(freeoslistcount);
  474. {$ifdef HAS_SYSOSFREE}
  475. end;
  476. {$endif}
  477. end;
  478. procedure remove_from_oslist(poc: poschunk);
  479. begin
  480. if assigned(poc^.next) then
  481. poc^.next^.prev := poc^.prev;
  482. if assigned(poc^.prev) then
  483. poc^.prev^.next := poc^.next
  484. else
  485. freeoslist := poc^.next;
  486. dec(freeoslistcount);
  487. end;
  488. procedure append_to_oslist_var(pmc: pmemchunk_var);
  489. var
  490. poc: poschunk;
  491. begin
  492. // block eligable for freeing
  493. poc := pointer(pmc)-sizeof(toschunk);
  494. remove_from_list_var(pmc);
  495. append_to_oslist(poc);
  496. end;
  497. procedure append_to_oslist_fixed(poc: poschunk);
  498. var
  499. pmc: pmemchunk_fixed;
  500. chunksize,
  501. chunkindex,
  502. i, count: ptrint;
  503. begin
  504. chunkindex:=poc^.chunkindex;
  505. chunksize:=chunkindex shl blockshift;
  506. pmc := pmemchunk_fixed(pointer(poc)+sizeof(toschunk));
  507. count := (poc^.size - sizeof(toschunk)) div chunksize;
  508. for i := 0 to count - 1 do
  509. begin
  510. if assigned(pmc^.next_fixed) then
  511. pmc^.next_fixed^.prev_fixed := pmc^.prev_fixed;
  512. if assigned(pmc^.prev_fixed) then
  513. pmc^.prev_fixed^.next_fixed := pmc^.next_fixed
  514. else
  515. freelists_fixed[chunkindex] := pmc^.next_fixed;
  516. pmc := pointer(pmc)+chunksize;
  517. end;
  518. append_to_oslist(poc);
  519. end;
  520. {*****************************************************************************
  521. Split block
  522. *****************************************************************************}
  523. procedure split_block(pcurr: pmemchunk_var; size: ptrint);
  524. var
  525. pcurr_tmp : pmemchunk_var;
  526. sizeleft: ptrint;
  527. begin
  528. sizeleft := (pcurr^.size and sizemask)-size;
  529. if sizeleft>=blocksize then
  530. begin
  531. pcurr_tmp := pmemchunk_var(pointer(pcurr)+size);
  532. { update prevsize of block to the right }
  533. if (pcurr^.size and lastblockflag) = 0 then
  534. pmemchunk_var(pointer(pcurr)+(pcurr^.size and sizemask))^.prevsize := sizeleft;
  535. { inherit the lastblockflag }
  536. pcurr_tmp^.size := sizeleft or (pcurr^.size and lastblockflag);
  537. pcurr_tmp^.prevsize := size;
  538. { the block we return is not the last one anymore (there's now a block after it) }
  539. { decrease size of block to new size }
  540. pcurr^.size := size or (pcurr^.size and (not sizemask and not lastblockflag));
  541. { insert the block in the freelist }
  542. append_to_list_var(pcurr_tmp);
  543. end;
  544. end;
  545. {*****************************************************************************
  546. Try concat freerecords
  547. *****************************************************************************}
  548. procedure concat_two_blocks(mc_left, mc_right: pmemchunk_var);
  549. var
  550. mc_tmp : pmemchunk_var;
  551. size_right : ptrint;
  552. begin
  553. // mc_right can't be a fixed size block
  554. if mc_right^.size and fixedsizeflag<>0 then
  555. HandleError(204);
  556. // left block free, concat with right-block
  557. size_right := mc_right^.size and sizemask;
  558. inc(mc_left^.size, size_right);
  559. // if right-block was last block, copy flag
  560. if (mc_right^.size and lastblockflag) <> 0 then
  561. begin
  562. mc_left^.size := mc_left^.size or lastblockflag;
  563. end
  564. else
  565. begin
  566. // there is a block to the right of the right-block, adjust it's prevsize
  567. mc_tmp := pmemchunk_var(pointer(mc_right)+size_right);
  568. mc_tmp^.prevsize := mc_left^.size and sizemask;
  569. end;
  570. // remove right-block from doubly linked list
  571. remove_from_list_var(mc_right);
  572. end;
  573. procedure try_concat_free_chunk_forward(mc: pmemchunk_var);
  574. var
  575. mc_tmp : pmemchunk_var;
  576. begin
  577. { try concat forward }
  578. if (mc^.size and lastblockflag) = 0 then
  579. begin
  580. mc_tmp := pmemchunk_var(pointer(mc)+(mc^.size and sizemask));
  581. if (mc_tmp^.size and usedflag) = 0 then
  582. begin
  583. // next block free: concat
  584. concat_two_blocks(mc, mc_tmp);
  585. end;
  586. end;
  587. end;
  588. function try_concat_free_chunk(mc: pmemchunk_var): pmemchunk_var;
  589. var
  590. mc_tmp : pmemchunk_var;
  591. begin
  592. try_concat_free_chunk_forward(mc);
  593. { try concat backward }
  594. if (mc^.size and firstblockflag) = 0 then
  595. begin
  596. mc_tmp := pmemchunk_var(pointer(mc)-mc^.prevsize);
  597. if (mc_tmp^.size and usedflag) = 0 then
  598. begin
  599. // prior block free: concat
  600. concat_two_blocks(mc_tmp, mc);
  601. mc := mc_tmp;
  602. end;
  603. end;
  604. result := mc;
  605. end;
  606. function check_concat_free_chunk_forward(mc: pmemchunk_var;reqsize:ptrint):boolean;
  607. var
  608. mc_tmp : pmemchunk_var;
  609. freesize : ptrint;
  610. begin
  611. check_concat_free_chunk_forward:=false;
  612. freesize:=0;
  613. mc_tmp:=mc;
  614. repeat
  615. inc(freesize,mc_tmp^.size and sizemask);
  616. if freesize>=reqsize then
  617. begin
  618. check_concat_free_chunk_forward:=true;
  619. exit;
  620. end;
  621. if (mc_tmp^.size and lastblockflag) <> 0 then
  622. break;
  623. mc_tmp := pmemchunk_var(pointer(mc_tmp)+(mc_tmp^.size and sizemask));
  624. if (mc_tmp^.size and usedflag) <> 0 then
  625. break;
  626. until false;
  627. end;
  628. {*****************************************************************************
  629. Grow Heap
  630. *****************************************************************************}
  631. function alloc_oschunk(chunkindex, size: ptrint):pointer;
  632. var
  633. pmcfirst,
  634. pmclast,
  635. pmc : pmemchunk_fixed;
  636. pmcv : pmemchunk_var;
  637. poc : poschunk;
  638. chunksize,
  639. minsize,
  640. maxsize,
  641. i, count : ptrint;
  642. begin
  643. result:=nil;
  644. chunksize:=chunkindex shl blockshift;
  645. { increase size by size needed for os block header }
  646. minsize := size + sizeof(toschunk);
  647. if chunkindex<>0 then
  648. maxsize := (chunksize * $ffff) + sizeof(toschunk)
  649. else
  650. maxsize := high(ptrint);
  651. { blocks available in freelist? }
  652. poc := freeoslist;
  653. while poc <> nil do
  654. begin
  655. if (poc^.size >= minsize) and
  656. (poc^.size <= maxsize) then
  657. begin
  658. size := poc^.size;
  659. remove_from_oslist(poc);
  660. break;
  661. end;
  662. poc := poc^.next;
  663. end;
  664. if poc = nil then
  665. begin
  666. {$ifdef DUMPGROW}
  667. writeln('growheap(',size,') allocating ',(size+sizeof(toschunk)+$ffff) and $ffff0000);
  668. DumpBlocks;
  669. {$endif}
  670. { allocate by 64K size }
  671. size := (size+sizeof(toschunk)+$ffff) and not $ffff;
  672. { allocate smaller blocks for fixed-size chunks }
  673. if chunksize<>0 then
  674. begin
  675. poc := SysOSAlloc(GrowHeapSizeSmall);
  676. if poc<>nil then
  677. size := GrowHeapSizeSmall;
  678. end
  679. { first try 256K (default) }
  680. else if size<=GrowHeapSize1 then
  681. begin
  682. poc := SysOSAlloc(GrowHeapSize1);
  683. if poc<>nil then
  684. size := GrowHeapSize1;
  685. end
  686. { second try 1024K (default) }
  687. else if size<=GrowHeapSize2 then
  688. begin
  689. poc := SysOSAlloc(GrowHeapSize2);
  690. if poc<>nil then
  691. size := GrowHeapSize2;
  692. end
  693. { else allocate the needed bytes }
  694. else
  695. poc := SysOSAlloc(size);
  696. { try again }
  697. if poc=nil then
  698. begin
  699. poc := SysOSAlloc(size);
  700. if (poc=nil) then
  701. begin
  702. if ReturnNilIfGrowHeapFails then
  703. exit
  704. else
  705. HandleError(203);
  706. end;
  707. end;
  708. { set the total new heap size }
  709. inc(internal_status.currheapsize,size);
  710. if internal_status.currheapsize>internal_status.maxheapsize then
  711. internal_status.maxheapsize:=internal_status.currheapsize;
  712. end;
  713. { initialize os-block }
  714. poc^.used := 0;
  715. poc^.size := size;
  716. poc^.chunkindex := chunkindex;
  717. { initialized oschunck for fixed chunks }
  718. if chunkindex<>0 then
  719. begin
  720. { chop os chunk in fixedsize parts,
  721. maximum of $ffff elements are allowed, otherwise
  722. there will be an overflow }
  723. count := (size-sizeof(toschunk)) div chunksize;
  724. if count>$ffff then
  725. HandleError(204);
  726. { Initialize linkedlist of chunks, the first chunk
  727. is pmemchunk_fixed(poc) and the last chunk will be in pmc at
  728. the end of the loop }
  729. pmcfirst := pmemchunk_fixed(pointer(poc)+sizeof(toschunk));
  730. pmc:=pmcfirst;
  731. for i:=1 to count do
  732. begin
  733. pmc^.poc:=poc;
  734. pmc^.size:=chunksize or fixedsizeflag;
  735. pmc^.prev_fixed := pointer(pmc)-chunksize;
  736. pmc^.next_fixed := pointer(pmc)+chunksize;
  737. pmc := pmemchunk_fixed(pointer(pmc)+chunksize);
  738. end;
  739. { undo last increase to get last chunk }
  740. pmclast := pmemchunk_fixed(pointer(pmc)-chunksize);
  741. { Add to freelist and fixup first and last chunk }
  742. pmclast^.next_fixed := freelists_fixed[chunkindex];
  743. if freelists_fixed[chunkindex]<>nil then
  744. freelists_fixed[chunkindex]^.prev_fixed := pmclast;
  745. freelists_fixed[chunkindex] := pmcfirst;
  746. pmemchunk_fixed(poc)^.prev_fixed:=nil;
  747. result:=pmcfirst;
  748. end
  749. else
  750. begin
  751. pmcv := pmemchunk_var(pointer(poc)+sizeof(toschunk));
  752. append_to_list_var(pmcv);
  753. pmcv^.size := ((size-sizeof(toschunk)) and sizemask) or (firstblockflag or lastblockflag);
  754. pmcv^.prevsize := 0;
  755. result:=pmcv;
  756. end;
  757. end;
  758. {*****************************************************************************
  759. SysGetMem
  760. *****************************************************************************}
  761. function SysGetMem_Fixed(size: ptrint): pointer;
  762. var
  763. pmc,hp : pmemchunk_fixed;
  764. poc : poschunk;
  765. chunkindex : ptrint;
  766. begin
  767. { try to find a block in one of the freelists per size }
  768. chunkindex := size shr blockshift;
  769. pmc := freelists_fixed[chunkindex];
  770. result:=nil;
  771. { no free blocks ? }
  772. if not assigned(pmc) then
  773. begin
  774. pmc:=alloc_oschunk(chunkindex, size);
  775. if not assigned(pmc) then
  776. exit;
  777. end;
  778. { get a pointer to the block we should return }
  779. result := pointer(pmc)+sizeof(tmemchunk_fixed_hdr);
  780. { update freelist }
  781. hp:=pmc^.next_fixed;
  782. poc := pmc^.poc;
  783. freelists_fixed[chunkindex] := hp;
  784. if assigned(hp) then
  785. hp^.prev_fixed := nil;
  786. if (poc^.used = 0) then
  787. freelists_free_chunk[chunkindex] := false;
  788. inc(poc^.used);
  789. { statistics }
  790. inc(internal_status.currheapused,size);
  791. if internal_status.currheapused>internal_status.maxheapused then
  792. internal_status.maxheapused:=internal_status.currheapused;
  793. end;
  794. function SysGetMem_Var(size: ptrint): pointer;
  795. var
  796. pcurr : pmemchunk_var;
  797. {$ifdef BESTMATCH}
  798. pbest : pmemchunk_var;
  799. {$endif}
  800. begin
  801. result:=nil;
  802. {$ifdef BESTMATCH}
  803. pbest := nil;
  804. {$endif}
  805. pcurr := freelist_var;
  806. while assigned(pcurr) do
  807. begin
  808. {$ifdef BESTMATCH}
  809. if pcurr^.size=size then
  810. begin
  811. break;
  812. end
  813. else
  814. begin
  815. if (pcurr^.size>size) then
  816. begin
  817. if (not assigned(pbest)) or
  818. (pcurr^.size<pbest^.size) then
  819. pbest := pcurr;
  820. end;
  821. end;
  822. {$else BESTMATCH}
  823. if pcurr^.size>=size then
  824. break;
  825. {$endif BESTMATCH}
  826. pcurr := pcurr^.next_var;
  827. end;
  828. {$ifdef BESTMATCH}
  829. if not assigned(pcurr) then
  830. pcurr := pbest;
  831. {$endif}
  832. if not assigned(pcurr) then
  833. begin
  834. // all os-chunks full, allocate a new one
  835. pcurr := alloc_oschunk(0, size);
  836. if not assigned(pcurr) then
  837. exit;
  838. end;
  839. { get pointer of the block we should return }
  840. result := pointer(pcurr)+sizeof(tmemchunk_var_hdr);
  841. { remove the current block from the freelist }
  842. remove_from_list_var(pcurr);
  843. { create the left over freelist block, if at least 16 bytes are free }
  844. split_block(pcurr, size);
  845. { flag block as used }
  846. pcurr^.size := pcurr^.size or usedflag;
  847. { statistics }
  848. inc(internal_status.currheapused,size);
  849. if internal_status.currheapused>internal_status.maxheapused then
  850. internal_status.maxheapused:=internal_status.currheapused;
  851. end;
  852. function SysGetMem(size : ptrint):pointer;
  853. begin
  854. { Something to allocate ? }
  855. if size<=0 then
  856. begin
  857. { give an error for < 0 }
  858. if size<0 then
  859. HandleError(204);
  860. { we always need to allocate something, using heapend is not possible,
  861. because heappend can be changed by growheap (PFV) }
  862. size := 1;
  863. end;
  864. { calc to multiple of 16 after adding the needed bytes for memchunk header }
  865. if size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr)) then
  866. begin
  867. size := (size+(sizeof(tmemchunk_fixed_hdr)+(blocksize-1))) and fixedsizemask;
  868. result := sysgetmem_fixed(size);
  869. end
  870. else
  871. begin
  872. size := (size+(sizeof(tmemchunk_var_hdr)+(blocksize-1))) and sizemask;
  873. result := sysgetmem_var(size);
  874. end;
  875. end;
  876. {*****************************************************************************
  877. SysFreeMem
  878. *****************************************************************************}
  879. function SysFreeMem_Fixed(pmc: pmemchunk_fixed): ptrint;
  880. var
  881. hp : pmemchunk_fixed;
  882. chunksize,
  883. chunkindex : ptrint;
  884. poc : poschunk;
  885. begin
  886. poc := pmc^.poc;
  887. chunkindex:=poc^.chunkindex;
  888. chunksize:=chunkindex shl blockshift;
  889. { statistics }
  890. dec(internal_status.currheapused,chunksize);
  891. hp:=freelists_fixed[chunkindex];
  892. { insert the block in it's freelist }
  893. pmc^.prev_fixed := nil;
  894. pmc^.next_fixed := hp;
  895. if assigned(hp) then
  896. hp^.prev_fixed := pmc;
  897. freelists_fixed[chunkindex] := pmc;
  898. dec(poc^.used);
  899. if poc^.used <= 0 then
  900. begin
  901. { decrease used blocks count }
  902. if poc^.used=-1 then
  903. HandleError(204);
  904. { osblock can be freed? }
  905. if freelists_free_chunk[chunkindex] then
  906. append_to_oslist_fixed(poc)
  907. else
  908. freelists_free_chunk[chunkindex] := true;
  909. end;
  910. result := chunksize;
  911. end;
  912. function SysFreeMem_Var(pcurr: pmemchunk_var): ptrint;
  913. var
  914. chunksize: ptrint;
  915. begin
  916. chunksize := pcurr^.size and sizemask;
  917. dec(internal_status.currheapused,chunksize);
  918. { insert the block in it's freelist }
  919. pcurr^.size := pcurr^.size and (not usedflag);
  920. append_to_list_var(pcurr);
  921. result := chunksize;
  922. pcurr := try_concat_free_chunk(pcurr);
  923. if (pcurr^.size and (firstblockflag or lastblockflag)) = (firstblockflag or lastblockflag) then
  924. append_to_oslist_var(pcurr);
  925. end;
  926. function SysFreeMem(p: pointer): ptrint;
  927. var
  928. hp : pmemchunk_fixed;
  929. begin
  930. if p=nil then
  931. begin
  932. result:=0;
  933. exit;
  934. end;
  935. hp:=pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr));
  936. { check if this is a fixed- or var-sized chunk }
  937. if (hp^.size and fixedsizeflag) = 0 then
  938. result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)))
  939. else
  940. result := sysfreemem_fixed(hp);
  941. end;
  942. {*****************************************************************************
  943. SysFreeMemSize
  944. *****************************************************************************}
  945. Function SysFreeMemSize(p: pointer; size: ptrint):ptrint;
  946. var
  947. hp : pmemchunk_fixed;
  948. begin
  949. SysFreeMemSize := 0;
  950. if p=nil then
  951. exit;
  952. if size<=0 then
  953. begin
  954. if size<0 then
  955. HandleError(204);
  956. exit;
  957. end;
  958. hp:=pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr));
  959. { check if this is a fixed- or var-sized chunk. We can't check the passed
  960. size parameter since the block can be resized (by reallocmem) to an
  961. optimized value that the user doesn't know }
  962. if (hp^.size and fixedsizeflag) = 0 then
  963. result := sysfreemem_var(pmemchunk_var(p-sizeof(tmemchunk_var_hdr)))
  964. else
  965. result := sysfreemem_fixed(hp);
  966. end;
  967. {*****************************************************************************
  968. SysMemSize
  969. *****************************************************************************}
  970. function SysMemSize(p: pointer): ptrint;
  971. begin
  972. result := pmemchunk_fixed(pointer(p)-sizeof(tmemchunk_fixed_hdr))^.size;
  973. if (result and fixedsizeflag) = 0 then
  974. begin
  975. result := SysMemSize and sizemask;
  976. dec(result, sizeof(tmemchunk_var_hdr));
  977. end
  978. else
  979. begin
  980. result := SysMemSize and fixedsizemask;
  981. dec(result, sizeof(tmemchunk_fixed_hdr));
  982. end;
  983. end;
  984. {*****************************************************************************
  985. SysAllocMem
  986. *****************************************************************************}
  987. function SysAllocMem(size: ptrint): pointer;
  988. begin
  989. result := MemoryManager.GetMem(size);
  990. if result<>nil then
  991. FillChar(result^,MemoryManager.MemSize(result),0);
  992. end;
  993. {*****************************************************************************
  994. SysResizeMem
  995. *****************************************************************************}
  996. function SysTryResizeMem(var p: pointer; size: ptrint): boolean;
  997. var
  998. chunksize,
  999. oldsize,
  1000. currsize : ptrint;
  1001. pcurr : pmemchunk_var;
  1002. begin
  1003. SysTryResizeMem := false;
  1004. { fix p to point to the heaprecord }
  1005. chunksize := pmemchunk_fixed(p-sizeof(tmemchunk_fixed_hdr))^.size;
  1006. { handle fixed memchuncks separate. Only allow resizes when the
  1007. new size fits in the same block }
  1008. if (chunksize and fixedsizeflag) <> 0 then
  1009. begin
  1010. currsize := chunksize and fixedsizemask;
  1011. { first check if the size fits in the fixed block range to prevent
  1012. "truncating" the size by the fixedsizemask }
  1013. if (size <= (maxblocksize - sizeof(tmemchunk_fixed_hdr))) and
  1014. ((size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and sizemask =currsize ) then
  1015. begin
  1016. systryresizemem:=true;
  1017. exit;
  1018. end;
  1019. { we need to allocate a new fixed or var memchunck }
  1020. exit;
  1021. end;
  1022. { var memchunck }
  1023. currsize := chunksize and sizemask;
  1024. size := (size+sizeof(tmemchunk_var_hdr)+(blocksize-1)) and sizemask;
  1025. { is the allocated block still correct? }
  1026. if (currsize>=size) and (size>(currsize-blocksize)) then
  1027. begin
  1028. SysTryResizeMem := true;
  1029. exit;
  1030. end;
  1031. { get pointer to block }
  1032. pcurr := pmemchunk_var(pointer(p)-sizeof(tmemchunk_var_hdr));
  1033. oldsize := currsize;
  1034. { do we need to allocate more memory ? }
  1035. if size>currsize then
  1036. begin
  1037. { the size is bigger than the previous size, we need to allocated more mem.
  1038. We first check if the blocks after the current block are free. If not then we
  1039. simply call getmem/freemem to get the new block }
  1040. if check_concat_free_chunk_forward(pcurr,size) then
  1041. repeat
  1042. concat_two_blocks(pcurr,pmemchunk_var(pointer(pcurr)+currsize));
  1043. currsize := pcurr^.size and sizemask;
  1044. until currsize>=size
  1045. else
  1046. exit;
  1047. end;
  1048. { is the size smaller then we can adjust the block to that size and insert
  1049. the other part into the freelist }
  1050. if currsize>size then
  1051. split_block(pcurr, size);
  1052. inc(internal_status.currheapused,size-oldsize);
  1053. SysTryResizeMem := true;
  1054. end;
  1055. {*****************************************************************************
  1056. SysResizeMem
  1057. *****************************************************************************}
  1058. function SysReAllocMem(var p: pointer; size: ptrint):pointer;
  1059. var
  1060. newsize,
  1061. oldsize,
  1062. minsize : ptrint;
  1063. p2 : pointer;
  1064. begin
  1065. { Free block? }
  1066. if size=0 then
  1067. begin
  1068. if p<>nil then
  1069. begin
  1070. MemoryManager.FreeMem(p);
  1071. p := nil;
  1072. end;
  1073. end
  1074. else
  1075. { Allocate a new block? }
  1076. if p=nil then
  1077. begin
  1078. p := MemoryManager.GetMem(size);
  1079. end
  1080. else
  1081. { Resize block }
  1082. if not SysTryResizeMem(p,size) then
  1083. begin
  1084. oldsize:=MemoryManager.MemSize(p);
  1085. { Grow with bigger steps to prevent the need for
  1086. multiple getmem/freemem calls for fixed blocks. It might cost a bit
  1087. of extra memory, but in most cases a reallocmem is done multiple times. }
  1088. if oldsize<maxblocksize then
  1089. begin
  1090. newsize:=oldsize*2+blocksize;
  1091. if size>newsize then
  1092. newsize:=size;
  1093. end
  1094. else
  1095. newsize:=size;
  1096. { calc size of data to move }
  1097. minsize:=oldsize;
  1098. if newsize < minsize then
  1099. minsize := newsize;
  1100. p2 := MemoryManager.GetMem(newsize);
  1101. if p2<>nil then
  1102. Move(p^,p2^,minsize);
  1103. MemoryManager.FreeMem(p);
  1104. p := p2;
  1105. end;
  1106. SysReAllocMem := p;
  1107. end;
  1108. {*****************************************************************************
  1109. MemoryMutexManager default hooks
  1110. *****************************************************************************}
  1111. procedure SysHeapMutexInit;
  1112. begin
  1113. { nothing todo }
  1114. end;
  1115. procedure SysHeapMutexDone;
  1116. begin
  1117. { nothing todo }
  1118. end;
  1119. procedure SysHeapMutexLock;
  1120. begin
  1121. { give an runtime error. the program is running multithreaded without
  1122. any heap protection. this will result in unpredictable errors so
  1123. stopping here with an error is more safe (PFV) }
  1124. runerror(244);
  1125. end;
  1126. procedure SysHeapMutexUnLock;
  1127. begin
  1128. { see SysHeapMutexLock for comment }
  1129. runerror(244);
  1130. end;
  1131. {*****************************************************************************
  1132. InitHeap
  1133. *****************************************************************************}
  1134. { This function will initialize the Heap manager and need to be called from
  1135. the initialization of the system unit }
  1136. procedure InitHeap;
  1137. begin
  1138. FillChar(freelists_fixed,sizeof(tfreelists),0);
  1139. FillChar(freelists_free_chunk,sizeof(freelists_free_chunk),0);
  1140. freelist_var := nil;
  1141. freeoslist := nil;
  1142. freeoslistcount := 0;
  1143. fillchar(internal_status,sizeof(internal_status),0);
  1144. end;