heap.inc 70 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866
  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. { Do not use standard memory manager }
  13. { $define HAS_MEMORYMANAGER}
  14. { Memory manager }
  15. const
  16. MemoryManager: TMemoryManager = (
  17. NeedLock: false; // Obsolete
  18. GetMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysGetMem{$else}nil{$endif};
  19. FreeMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysFreeMem{$else}nil{$endif};
  20. FreeMemSize: {$ifndef FPC_NO_DEFAULT_HEAP}@SysFreeMemSize{$else}nil{$endif};
  21. AllocMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysAllocMem{$else}nil{$endif};
  22. ReAllocMem: {$ifndef FPC_NO_DEFAULT_HEAP}@SysReAllocMem{$else}nil{$endif};
  23. MemSize: {$ifndef FPC_NO_DEFAULT_HEAP}@SysMemSize{$else}nil{$endif};
  24. InitThread: nil;
  25. DoneThread: nil;
  26. RelocateHeap: nil;
  27. GetHeapStatus: {$ifndef FPC_NO_DEFAULT_HEAP}@SysGetHeapStatus{$else}nil{$endif};
  28. GetFPCHeapStatus: {$ifndef FPC_NO_DEFAULT_HEAP}@SysGetFPCHeapStatus{$else}nil{$endif};
  29. ); {$ifdef FPC_NO_DEFAULT_HEAP} public name 'FPC_SYSTEM_MEMORYMANAGER'; {$endif}
  30. {*****************************************************************************
  31. Memory Manager
  32. *****************************************************************************}
  33. procedure GetMemoryManager(var MemMgr:TMemoryManager);
  34. begin
  35. MemMgr := MemoryManager;
  36. end;
  37. procedure SetMemoryManager(const MemMgr:TMemoryManager);
  38. begin
  39. MemoryManager := MemMgr;
  40. end;
  41. function IsMemoryManagerSet:Boolean;
  42. begin
  43. {$if defined(HAS_MEMORYMANAGER) or defined(FPC_NO_DEFAULT_HEAP)}
  44. Result:=false;
  45. {$else not FPC_NO_DEFAULT_HEAP}
  46. IsMemoryManagerSet := (MemoryManager.GetMem<>@SysGetMem)
  47. or (MemoryManager.FreeMem<>@SysFreeMem);
  48. {$endif HAS_MEMORYMANAGER or FPC_NO_DEFAULT_HEAP}
  49. end;
  50. {$ifdef FPC_HAS_FEATURE_HEAP}
  51. procedure GetMem(Out p:pointer;Size:ptruint);
  52. begin
  53. p := MemoryManager.GetMem(Size);
  54. end;
  55. procedure GetMemory(Out p:pointer;Size:ptruint);
  56. begin
  57. GetMem(p,size);
  58. end;
  59. procedure FreeMem(p:pointer;Size:ptruint);
  60. begin
  61. MemoryManager.FreeMemSize(p,Size);
  62. end;
  63. procedure FreeMemory(p:pointer;Size:ptruint);
  64. begin
  65. FreeMem(p,size);
  66. end;
  67. function GetHeapStatus:THeapStatus;
  68. begin
  69. Result:=MemoryManager.GetHeapStatus();
  70. end;
  71. function GetFPCHeapStatus:TFPCHeapStatus;
  72. begin
  73. Result:=MemoryManager.GetFPCHeapStatus();
  74. end;
  75. function MemSize(p:pointer):ptruint;
  76. begin
  77. MemSize := MemoryManager.MemSize(p);
  78. end;
  79. { Delphi style }
  80. function FreeMem(p:pointer):ptruint;
  81. begin
  82. FreeMem := MemoryManager.FreeMem(p);
  83. end;
  84. function FreeMemory(p:pointer):ptruint; cdecl;
  85. begin
  86. FreeMemory := FreeMem(p);
  87. end;
  88. function GetMem(size:ptruint):pointer;
  89. begin
  90. GetMem := MemoryManager.GetMem(Size);
  91. end;
  92. function GetMemory(size:ptruint):pointer; cdecl;
  93. begin
  94. GetMemory := GetMem(size);
  95. end;
  96. function AllocMem(Size:ptruint):pointer;
  97. begin
  98. AllocMem := MemoryManager.AllocMem(size);
  99. end;
  100. function ReAllocMem(var p:pointer;Size:ptruint):pointer;
  101. begin
  102. ReAllocMem := MemoryManager.ReAllocMem(p,size);
  103. end;
  104. function ReAllocMemory(p:pointer;Size:ptruint):pointer; cdecl;
  105. begin
  106. ReAllocMemory := ReAllocMem(p,size);
  107. end;
  108. { Needed for calls from Assembler }
  109. function fpc_getmem(size:ptruint):pointer;compilerproc;[public,alias:'FPC_GETMEM'];
  110. begin
  111. fpc_GetMem := MemoryManager.GetMem(size);
  112. end;
  113. procedure fpc_freemem(p:pointer);compilerproc;[public,alias:'FPC_FREEMEM'];
  114. begin
  115. MemoryManager.FreeMem(p);
  116. end;
  117. {$ifndef HAS_MEMORYMANAGER}
  118. type
  119. {
  120. We use 'fixed' size chunks for small allocations,
  121. os chunks with variable sized blocks for bigger allocations,
  122. and (almost) directly use os chunks for huge allocations.
  123. * a block is an area allocated by user
  124. * a chunk is a block plus our bookkeeping
  125. * an os chunk is a collection of chunks
  126. Memory layout:
  127. fixed: < CommonHeader > [ ... user data ... ]
  128. variable: [ VarHeader < CommonHeader > ] [ ... user data ... ]
  129. huge: HugeChunk < CommonHeader > [ ... user data ... ]
  130. When all chunks in an os chunk are free, we keep a few around
  131. but otherwise it will be freed to the OS.
  132. }
  133. {$ifdef ENDIAN_LITTLE}
  134. {$define HEAP_INC_USE_SETS} { Potentially better codegen than “or 1 shl” etc. (at least on x86). Can be adapted for big endian, too, but I have no such platform to test. }
  135. {$endif ENDIAN_LITTLE}
  136. HeapInc = object
  137. const
  138. { Alignment requirement for blocks. All fixed sizes (among other things) are assumed to be divisible. }
  139. Alignment = 2 * sizeof(pointer);
  140. { Fixed chunk sizes are:
  141. ┌──── step = 16 ────┐┌─── step = 32 ────┐┌──── step = 48 ───┐┌ step 64 ┐
  142. 16, 32, 48, 64, 80, 96, 128, 160, 192, 224, 272, 320, 368, 416, 480, 544
  143. #0 #1 #2 #3 #4 #5 #6 #7 #8 #9 #10 #11 #12 #13 #14 #15 }
  144. MinFixedHeaderAndPayload = 16;
  145. MaxFixedHeaderAndPayload = 544;
  146. FixedSizesCount = 16;
  147. FixedSizes: array[0 .. FixedSizesCount - 1] of uint16 = (16, 32, 48, 64, 80, 96, 128, 160, 192, 224, 272, 320, 368, 416, 480, 544);
  148. SizeMinus1Div16ToIndex: array[0 .. (MaxFixedHeaderAndPayload - 1) div 16] of uint8 =
  149. { 16, 32, 48, 64, 80, 96, 112, 128, 144, 160, 176, 192, 208, 224, 240, 256, 272, 288, 304, 320, 336, 352, 368, 384, 400, 416, 432, 448, 464, 480, 496, 512, 528, 544 }
  150. ( 0, 1, 2, 3, 4, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 10, 11, 11, 11, 12, 12, 12, 13, 13, 13, 14, 14, 14, 14, 15, 15, 15, 15);
  151. class function SizeMinus1ToIndex(sizeMinus1: SizeUint): SizeUint; static; inline; { sizeMinus1 + 1 ≤ MaxFixedHeaderAndPayload }
  152. class function IndexToSize(sizeIndex: SizeUint): SizeUint; static; inline;
  153. const
  154. OSChunkVarSizeQuant = 64 * 1024;
  155. FixedArenaSizeQuant = 4 * 1024;
  156. MinFixedArenaSize = 8 * 1024;
  157. MaxFixedArenaSize = 64 * 1024;
  158. MaxKeptFixedArenas = 4;
  159. { Adjustable part ends here~ }
  160. const
  161. SizeIndexBits = 1 + trunc(ln(FixedSizesCount - 1) / ln(2));
  162. SizeIndexMask = 1 shl SizeIndexBits - 1;
  163. FixedBitPos = {$if SizeIndexBits >= 4} SizeIndexBits {$else} 4 {$endif}; { Variable chunks use 4 low bits for used / last / prev. free / fixed arena. }
  164. FixedFlag = 1 shl FixedBitPos;
  165. FixedArenaOffsetShift = {$if FixedBitPos + 1 >= 5} FixedBitPos + 1 {$else} 5 {$endif}; { VarSizeQuant is expected to be 2^5. }
  166. UsedFlag = 1 shl 0;
  167. LastFlag = 1 shl 1;
  168. PrevIsFreeFlag = 1 shl 2;
  169. FixedArenaFlag = 1 shl 3;
  170. VarSizeQuant = 1 shl FixedArenaOffsetShift; {$if VarSizeQuant <> 32} {$error Should in principle work but explanations below assume exactly 32. :)} {$endif}
  171. VarSizeMask = uint32(-VarSizeQuant);
  172. HugeHeader = 0; { Special header value for huge chunks. FixedFlag must be 0, and the value must be impossible for a variable chunk. 0 turns out to be suitable. :) }
  173. { Variable chunk sizes, not counting extra MaxFixedHeaderAndPayload added to each of these:
  174. 32 sizes in the range +1 .. 1 024 (2^10) rounded up to the multiple of 32 = 2^ 5, + 0, max = 1 024 = %100 0000 0000
  175. 32 sizes in the range +1 .. 2 048 (2^11) rounded up to the multiple of 64 = 2^ 6, + 1024, max = 3 072 = %1100 0000 0000
  176. 32 sizes in the range +1 .. 4 096 (2^12) rounded up to the multiple of 128 = 2^ 7, + 1024 + 2048, max = 7 168 = %1 1100 0000 0000
  177. 32 sizes in the range +1 .. 8 192 (2^13) rounded up to the multiple of 256 = 2^ 8, + 2^10 + .. + 2^12, max = 15 360 = %11 1100 0000 0000
  178. 32 sizes in the range +1 .. 16 384 (2^14) rounded up to the multiple of 512 = 2^ 9, + 2^10 + .. + 2^13, max = 31 744 = %111 1100 0000 0000
  179. 32 sizes in the range +1 .. 32 768 (2^15) rounded up to the multiple of 1 024 = 2^10, + 2^10 + .. + 2^14, max = 64 512 = %1111 1100 0000 0000
  180. 32 sizes in the range +1 .. 65 536 (2^16) rounded up to the multiple of 2 048 = 2^11, + 2^10 + .. + 2^15, max = 130 048 = %1 1111 1100 0000 0000
  181. 32 sizes in the range +1 .. 131 072 (2^17) rounded up to the multiple of 4 096 = 2^12, + 2^10 + .. + 2^16, max = 261 120 = %11 1111 1100 0000 0000
  182. 32 sizes in the range +1 .. 262 144 (2^18) rounded up to the multiple of 8 192 = 2^13, + 2^10 + .. + 2^17, max = 523 264 = %111 1111 1100 0000 0000
  183. 32 sizes in the range +1 .. 524 288 (2^19) rounded up to the multiple of 16 384 = 2^14, + 2^10 + .. + 2^18, max = 1 047 552 = %1111 1111 1100 0000 0000 }
  184. FirstVarRangeP2 = 10;
  185. FirstVarStepP2 = FixedArenaOffsetShift; {$if FirstVarStepP2 <> 5} {$error :|} {$endif}
  186. VarSizeClassesCount = 10;
  187. VarSizesPerClass = 32;
  188. VarSizesCount = VarSizeClassesCount * VarSizesPerClass;
  189. L0BinSize = 32;
  190. { Minimum size of the chunk that can be added to varFree.
  191. Medium chunks can be smaller than this, all the way down to MinAnyVarHeaderAndPayload defined later in terms of things it must fit;
  192. they aren’t visible for varFree searches but are visible for merging with freed neighbors. }
  193. MinSearchableVarHeaderAndPayload = (MaxFixedHeaderAndPayload + 1 shl FirstVarStepP2 + VarSizeQuant - 1) and -VarSizeQuant;
  194. MaxVarHeaderAndPayload = (MaxFixedHeaderAndPayload + (1 shl VarSizeClassesCount - 1) shl FirstVarRangeP2) and -VarSizeQuant; {$if MaxVarHeaderAndPayload <> MaxFixedHeaderAndPayload + 1047552} {$error does not match the explanation above :D} {$endif}
  195. class function VarSizeToBinIndex(size: SizeUint; roundUp: boolean): SizeUint; static;
  196. class function BinIndexToVarSize(binIndex: SizeUint): SizeUint; static; inline;
  197. type
  198. { Common header of any memory chunk, residing immediately to the left of the ~payload~ (block).
  199. Fixed chunk header, assuming SizeIndexBits = 4:
  200. h[0:3] = size index (= h and SizeIndexMask)
  201. h[4] = 1 (h and FixedFlag <> 0)
  202. h[5:31] — offset in the FixedArena (= h shr FixedArenaOffsetShift)
  203. Variable chunk header, assuming SizeIndexBits = 4:
  204. h[0] = used flag (h and UsedFlag <> 0)
  205. h[1] = last flag (h and LastFlag <> 0)
  206. h[2] = previous is free flag (h and PrevIsFreeFlag <> 0)
  207. h[3] = fixed arena flag (h and FixedArenaFlag <> 0)
  208. h[4] = 0 (h and FixedFlag = 0)
  209. h[5:31] = size, rounded up to 32 (VarSizeQuant), shr 5; in other words, size = h and VarSizeMask.
  210. Huge chunk header:
  211. h[4] = 0 (h and FixedFlag = 0)
  212. h[0:31] = HugeHeader }
  213. pCommonHeader = ^CommonHeader;
  214. CommonHeader = record
  215. h: uint32;
  216. end;
  217. pThreadState = ^ThreadState;
  218. { Chunk that has been freed. Reuses the now-uninteresting payload, so payload must always fit its size.
  219. Used for fixed freelists and cross-thread to-free queue. }
  220. pFreeChunk = ^FreeChunk;
  221. FreeChunk = record
  222. next: pFreeChunk;
  223. end;
  224. OSChunkBase = object { Shared between OSChunk and HugeChunk. }
  225. size: SizeUint; { Full size asked from SysOSAlloc. }
  226. end;
  227. pOSChunk = ^OSChunk;
  228. OSChunk = object(OSChunkBase) { Common header for all OS chunks. }
  229. prev, next: pointer; { pOSChunk, but used for different subtypes. }
  230. end;
  231. pFreeOSChunk = ^FreeOSChunk;
  232. FreeOSChunk = object(OSChunk)
  233. end;
  234. {$ifndef HAS_SYSOSFREE}
  235. FreeOSChunkList = object
  236. first, last: pFreeOSChunk;
  237. function Get(minSize, maxSize: SizeUint): pOSChunk;
  238. end;
  239. {$endif not HAS_SYSOSFREE}
  240. pFixedArena = ^FixedArena;
  241. FixedArena = record
  242. { Allocated with AllocVar(isArena := true), so has VarHeader to the left.
  243. Data starts at FixedArenaDataOffset and spans for “maxSize” (virtual value, does not exist directly) bytes, of which:
  244. — first “formattedSize” are either allocated (“used”; counted in usedSizeMinus1) or in the freelist (firstFreeChunk; size = “formattedSize” - (usedSizeMinus1 + 1)),
  245. — the rest “maxSize” - “formattedSize” are yet unallocated space.
  246. This design, together with tracking free chunks per FixedArena rather than per fixed size, trivializes reusing the fixed arenas.
  247. Chopping all available space at once would get rid of the “unallocated space” entity, but is a lot of potentially wasted work:
  248. https://gitlab.com/freepascal.org/fpc/source/-/issues/40447.
  249. Values are multiples of the chunk size instead of counts (could be chunksUsed, chunksFormatted, chunksMax) to save on multiplications.
  250. Moreover, instead of “maxSize” from the explanation above, almostFullThreshold is used, which is such a value that the chunk is full if usedSizeMinus1 - chunk size >= almostFullThreshold.
  251. maxSize = RoundUp(almostFullThreshold + chunk size + 1, chunk size).
  252. Reasons are, calculating almostFullThreshold does not require division, and it is more convenient (in terms of code generation) for AllocFixed / FreeFixed.
  253. “formattedSize” is a virtual value, too; it equals to usedSizeMinus1 + 1 + <total size of the freelist> and is used only when said freelist is empty, so is in practice int32(usedSizeMinus1) + 1 (see AllocFixed). }
  254. firstFreeChunk: pFreeChunk;
  255. usedSizeMinus1, almostFullThreshold: uint32;
  256. prev, next: pFixedArena;
  257. end;
  258. pVarOSChunk = ^VarOSChunk;
  259. VarOSChunk = object(OSChunk)
  260. {$ifdef FPC_HAS_FEATURE_THREADING}
  261. threadState: pThreadState; { Protected with gs.lock. Nil if orphaned. }
  262. {$endif}
  263. end;
  264. pVarHeader = ^VarHeader;
  265. VarHeader = record
  266. { Negative offset from the end of this VarHeader to owning VarOSChunk, friendlier to x86 LEA instruction than the more obvious positive variant.
  267. Truly required only under FPC_HAS_FEATURE_THREADING and could be removed otherwise, bringing the variable header size to the same 4 bytes as fixed headers,
  268. but this would require some redesign (reintroducing FirstFlag removed in https://gitlab.com/freepascal.org/fpc/source/-/merge_requests/1027
  269. or some other way to detect the first chunk) and does not matter enough to bother.
  270. Moreover, accessing VarOSChunk could have been useful beyond multithreading, it just so happens it isn’t. }
  271. ofsToOs: int32;
  272. { Assumed to indeed match chunk’s CommonHeader, i.e. that there is no padding after this field.
  273. Otherwise must be accessed as pCommonHeader(pointer(varHdr) + (VarHeaderSize - CommonHeaderSize))^ :D. }
  274. ch: CommonHeader;
  275. end;
  276. { Reuses the payload of variable chunks whose ch.h and UsedFlag = 0, so variable chunk payload must always fit its size. }
  277. pFreeVarChunk = ^FreeVarChunk;
  278. FreeVarChunk = record
  279. prev, next: pFreeVarChunk;
  280. binIndex: uint32;
  281. end;
  282. { Placed at the end of the free variable chunks that have occupied chunks to the right, thus immediately to the left of such an occupied chunk. }
  283. pFreeVarTail = ^FreeVarTail;
  284. FreeVarTail = record
  285. size: uint32;
  286. end;
  287. pHugeChunk = ^HugeChunk;
  288. HugeChunk = object(OSChunkBase)
  289. end;
  290. NonZeroDWord = 1 .. High(uint32); { MAYBE IT WILL WORK ONE DAY (https://gitlab.com/freepascal.org/fpc/source/-/issues/41179). }
  291. {$ifdef HEAP_INC_USE_SETS}
  292. Set32 = set of 0 .. 31;
  293. {$endif HEAP_INC_USE_SETS}
  294. VarFreeMap = object
  295. { Two-level bitfield that allows to search for minimal-size fits (up to the quantization) using up to two “Bsf”s.
  296. Bit 1 in L1 means that the corresponding cell of L0 is non-0.
  297. Bit 1 in L0 means that the corresponding cell of bins is non-nil. }
  298. L1: uint32;
  299. L0: array[0 .. (VarSizesCount + L0BinSize - 1) div L0BinSize - 1] of uint32;
  300. bins: array[0 .. VarSizesCount - 1] of pFreeVarChunk;
  301. procedure Add(c: pFreeVarChunk; binIndex: SizeUint);
  302. procedure Remove(c: pFreeVarChunk);
  303. function Find(binIndex: SizeUint): pFreeVarChunk;
  304. end;
  305. ThreadState = object
  306. emptyArenas: pFixedArena; { Empty fixed arenas to be reused instead of slower AllocVar. Singly linked list, “prev”s are garbage. }
  307. nEmptyArenas: SizeUint; { # of items in emptyArenas. }
  308. {$ifdef HAS_SYSOSFREE}
  309. freeOS1: pFreeOSChunk; { Just one cached empty OS chunk so that borderline (free + alloc) × N scenarios don’t lead to N OS allocations. }
  310. {$else HAS_SYSOSFREE}
  311. freeOS: FreeOSChunkList; { Completely empty OS chunks. }
  312. {$endif HAS_SYSOSFREE}
  313. {$ifdef FPC_HAS_FEATURE_THREADING}
  314. toFree: pFreeChunk; { Free requests from other threads, atomic. }
  315. {$endif}
  316. used, maxUsed, allocated, maxAllocated: SizeUint; { “maxUsed” and “maxAllocated” include gs.hugeUsed; “used” and “allocated” don’t. }
  317. varOS: pVarOSChunk;
  318. { Fixed arenas with at least 1 free chunk (including unformatted space), but not completely empty.
  319. Fixed arenas that become completely empty are moved to emptyArenas, completely full are... not present in any list. }
  320. partialArenas: array[0 .. FixedSizesCount - 1] of pFixedArena;
  321. { Only to calculate preferable new fixed arena sizes...
  322. (Updated infrequently, as opposed to possible “usedPerArena”. When a new arena is required, all existing arenas of its size are full.) }
  323. allocatedByFullArenas: array[0 .. FixedSizesCount - 1] of uint32; { SizeUint is not obligatory, overflow is tolerable. }
  324. varFree: VarFreeMap;
  325. {$ifdef DEBUG_HEAP_INC}
  326. procedure Dump(var f: text);
  327. {$endif}
  328. function ChooseFixedArenaSize(sizeIndex: SizeUint): SizeUint;
  329. function AllocFixed(size: SizeUint): pointer; {$ifndef DEBUG_HEAP_INC} inline; {$endif}
  330. function FreeFixed(p: pointer): SizeUint; {$ifndef DEBUG_HEAP_INC} inline; {$endif}
  331. function GetOSChunk(minSize, maxSize: SizeUint): pOSChunk; {$if defined(HAS_SYSOSFREE) or not defined(FPC_HAS_FEATURE_THREADING)} inline; {$endif}
  332. function AllocateOSChunk(minSize, maxSize: SizeUint): pOSChunk;
  333. function AllocVar(size: SizeUint; isArena: boolean): pointer;
  334. function FreeVar(p: pointer): SizeUint;
  335. function TryResizeVar(p: pointer; size: SizeUint): pointer;
  336. class function AddToHugeUsed(delta: SizeInt): SizeUint; static;
  337. function AllocHuge(size: SizeUint): pointer;
  338. function FreeHuge(p: pointer): SizeUint;
  339. function TryResizeHuge(p: pointer; size: SizeUint): pointer;
  340. procedure UpdateMaxStats(hugeUsed: SizeUint);
  341. {$ifdef FPC_HAS_FEATURE_THREADING}
  342. procedure PushToFree(p: pFreeChunk);
  343. procedure FlushToFree;
  344. procedure Orphan;
  345. procedure AdoptArena(arena: pFixedArena);
  346. procedure AdoptVarOwner(p: pointer); { Adopts the OS chunk that contains p. Must be performed under gs.lock. }
  347. {$ifndef FPC_SECTION_THREADVARS}
  348. procedure FixupSelfPtr;
  349. {$endif ndef FPC_SECTION_THREADVARS}
  350. {$endif FPC_HAS_FEATURE_THREADING}
  351. end;
  352. GlobalState = record
  353. hugeUsed: SizeUint; { Same as non-existing “hugeAllocated” as huge chunks don’t have free space.
  354. Atomic, but can be read unprotected if unreliability is tolerable.
  355. Huge chunks don’t have thread affinity, so are tracked here. Presently, this value is added to all memory statistics.
  356. Not a good idea and makes multithreaded statistics a strange and unreliable mix, but alternatives are even worse. }
  357. {$ifdef FPC_HAS_FEATURE_THREADING}
  358. lock: TRTLCriticalSection;
  359. lockUse: int32;
  360. { Like ThreadState.varFree but over orphaned OS chunks. Protected by gs.lock. }
  361. varFree: VarFreeMap;
  362. {$ifndef HAS_SYSOSFREE}
  363. freeOS: FreeOSChunkList;
  364. {$endif not HAS_SYSOSFREE}
  365. {$endif FPC_HAS_FEATURE_THREADING}
  366. end;
  367. class function AllocFailed: pointer; static;
  368. class var
  369. gs: GlobalState;
  370. {$ifdef FPC_HAS_FEATURE_THREADING}
  371. class threadvar
  372. {$endif FPC_HAS_FEATURE_THREADING}
  373. thisTs: ThreadState;
  374. const
  375. CommonHeaderSize = sizeof(CommonHeader);
  376. {$if MinFixedHeaderAndPayload < CommonHeaderSize + sizeof(FreeChunk)} {$error MinFixedHeaderAndPayload does not fit CommonHeader + FreeChunk.} {$endif}
  377. FixedArenaDataOffset = (sizeof(FixedArena) + CommonHeaderSize + Alignment - 1) and -Alignment - CommonHeaderSize;
  378. VarHeaderSize = sizeof(VarHeader);
  379. FreeVarTailSize = sizeof(FreeVarTail);
  380. VarOSChunkDataOffset = (sizeof(VarOSChunk) + VarHeaderSize + Alignment - 1) and -Alignment - VarHeaderSize;
  381. HugeChunkDataOffset = (sizeof(HugeChunk) + CommonHeaderSize + Alignment - 1) and -Alignment - CommonHeaderSize;
  382. MinAnyVarHeaderAndPayload = (sizeof(VarHeader) + sizeof(FreeVarChunk) + sizeof(FreeVarTail) + VarSizeQuant - 1) and -VarSizeQuant;
  383. end;
  384. class function HeapInc.SizeMinus1ToIndex(sizeMinus1: SizeUint): SizeUint;
  385. begin
  386. result := SizeMinus1Div16ToIndex[sizeMinus1 div 16];
  387. end;
  388. class function HeapInc.IndexToSize(sizeIndex: SizeUint): SizeUint;
  389. begin
  390. result := FixedSizes[sizeIndex];
  391. end;
  392. class function HeapInc.VarSizeToBinIndex(size: SizeUint; roundUp: boolean): SizeUint;
  393. var
  394. maxv, binClassIndex: SizeUint;
  395. begin
  396. if size >= MaxVarHeaderAndPayload then { Large sizes go to the last bin, assuming searches never search for more than MaxVarHeaderAndPayload. }
  397. exit(VarSizeClassesCount * VarSizesPerClass - 1);
  398. dec(size, MaxFixedHeaderAndPayload);
  399. binClassIndex := SizeUint(BsrDWord(NonZeroDWord(size)) - FirstVarRangeP2);
  400. if SizeInt(binClassIndex) < 0 then binClassIndex := 0;
  401. maxv := (SizeUint(2) shl binClassIndex - 1) shl FirstVarRangeP2;
  402. if size <= maxv then
  403. begin
  404. maxv := maxv shr 1; { Turn into “minv” to be subtracted from size. If size > maxv, “minv” is maxv. :) }
  405. maxv := maxv and SizeUint(-SizeInt(1 shl FirstVarRangeP2));
  406. dec(SizeInt(binClassIndex)); { Compensate inc(binClassIndex) below, so in the end, it is increased if size > maxv. All of this prevents having an “else” branch with its extra jump. }
  407. end;
  408. dec(size, maxv);
  409. inc(SizeInt(binClassIndex));
  410. result := binClassIndex * VarSizesPerClass + SizeUint(size - 1) shr (FirstVarStepP2 + binClassIndex);
  411. if not roundUp and (size and SizeUint(SizeUint(1) shl (FirstVarStepP2 + binClassIndex) - 1) <> 0) then
  412. dec(result);
  413. end;
  414. class function HeapInc.BinIndexToVarSize(binIndex: SizeUint): SizeUint;
  415. begin
  416. result := binIndex div VarSizesPerClass;
  417. result := MaxFixedHeaderAndPayload + (SizeUint(1) shl result - 1) shl FirstVarRangeP2 + (1 + binIndex mod VarSizesPerClass) shl (FirstVarStepP2 + result);
  418. end;
  419. {$ifndef HAS_SYSOSFREE}
  420. function HeapInc.FreeOSChunkList.Get(minSize, maxSize: SizeUint): pOSChunk;
  421. var
  422. prev, next: pFreeOSChunk;
  423. begin
  424. result := first;
  425. while Assigned(result) and not ((result^.size >= minSize) and (result^.size <= maxSize)) do
  426. result := result^.next;
  427. if not Assigned(result) then
  428. exit;
  429. prev := result^.prev;
  430. next := result^.next;
  431. if Assigned(prev) then
  432. prev^.next := next
  433. else
  434. first := next;
  435. if Assigned(next) then
  436. next^.prev := prev
  437. else
  438. last := prev;
  439. end;
  440. {$endif not HAS_SYSOSFREE}
  441. procedure HeapInc.VarFreeMap.Add(c: pFreeVarChunk; binIndex: SizeUint);
  442. var
  443. next: pFreeVarChunk;
  444. iL0: SizeUint;
  445. vL0 {$ifdef HEAP_INC_USE_SETS}, vL1 {$endif}: uint32;
  446. begin
  447. next := bins[binIndex];
  448. c^.prev := nil;
  449. c^.next := next;
  450. c^.binIndex := binIndex;
  451. bins[binIndex] := c;
  452. if Assigned(next) then
  453. next^.prev := c
  454. else
  455. begin
  456. iL0 := binIndex div L0BinSize;
  457. vL0 := L0[iL0];
  458. {$ifdef HEAP_INC_USE_SETS}
  459. if vL0 = 0 then
  460. begin
  461. vL1 := L1;
  462. Include(Set32(vL1), iL0);
  463. L1 := vL1;
  464. end;
  465. Include(Set32(vL0), binIndex mod L0BinSize);
  466. L0[iL0] := vL0;
  467. {$else}
  468. if vL0 = 0 then
  469. L1 := L1 or uint32(1) shl iL0;
  470. L0[iL0] := vL0 or uint32(1) shl (binIndex mod L0BinSize);
  471. {$endif}
  472. end;
  473. end;
  474. procedure HeapInc.VarFreeMap.Remove(c: pFreeVarChunk);
  475. var
  476. prev, next: pFreeVarChunk;
  477. binIndex, iL0: SizeUint;
  478. v: uint32;
  479. begin
  480. prev := c^.prev;
  481. next := c^.next;
  482. if Assigned(next) then
  483. next^.prev := prev;
  484. if Assigned(prev) then
  485. prev^.next := next
  486. else
  487. begin
  488. binIndex := c^.binIndex;
  489. bins[binIndex] := next;
  490. if not Assigned(next) then
  491. begin
  492. iL0 := binIndex div L0BinSize;
  493. {$ifdef HEAP_INC_USE_SETS}
  494. v := L0[iL0];
  495. Exclude(Set32(v), binIndex mod L0BinSize);
  496. L0[iL0] := v;
  497. if v = 0 then
  498. begin
  499. v := L1;
  500. Exclude(Set32(v), iL0);
  501. L1 := v;
  502. end;
  503. {$else}
  504. v := L0[iL0] xor (uint32(1) shl (binIndex mod L0BinSize));
  505. L0[iL0] := v;
  506. if v = 0 then
  507. L1 := L1 xor (uint32(1) shl iL0);
  508. {$endif}
  509. end;
  510. end;
  511. end;
  512. function HeapInc.VarFreeMap.Find(binIndex: SizeUint): pFreeVarChunk;
  513. var
  514. mask: uint32;
  515. begin
  516. result := bins[binIndex];
  517. if Assigned(result) then
  518. exit;
  519. mask := L0[binIndex div L0BinSize] shr (binIndex mod L0BinSize); { Logically should be “1 + binIndex mod L0BinSize” but the bit that represents the binIndex-th bin is 0 anyway. }
  520. if mask <> 0 then
  521. exit(bins[binIndex + BsfDWord(NonZeroDWord(mask))]);
  522. mask := L1 and (SizeUint(-2) shl (binIndex div L0BinSize));
  523. if mask <> 0 then
  524. begin
  525. binIndex := BsfDWord(NonZeroDWord(mask)); { Index at L0. }
  526. result := bins[binIndex * L0BinSize + BsfDWord(NonZeroDWord(L0[binIndex]))];
  527. end;
  528. end;
  529. {$ifdef DEBUG_HEAP_INC}
  530. procedure HeapInc.ThreadState.Dump(var f: text);
  531. var
  532. i: SizeInt;
  533. fix: pFixedArena;
  534. fr: pFreeOSChunk;
  535. {$ifdef FPC_HAS_FEATURE_THREADING}
  536. tf: pFreeChunk;
  537. {$endif}
  538. vf: pFreeVarChunk;
  539. vOs: pVarOSChunk;
  540. p: pointer;
  541. needLE, anything: boolean;
  542. procedure MaybeLE;
  543. begin
  544. if needLE then
  545. writeln(f);
  546. needLE := false;
  547. end;
  548. procedure DumpVarFree(const varFree: VarFreeMap; const name: string);
  549. var
  550. i: SizeInt;
  551. begin
  552. if varFree.L1 = 0 then
  553. exit;
  554. MaybeLE;
  555. write(f, name, LineEnding, 'L1:');
  556. for i := 0 to VarSizesCount div L0BinSize - 1 do
  557. if varFree.L1 shr i and 1 <> 0 then
  558. begin
  559. write(f, ' #', i, ' ', BinIndexToVarSize(i * L0BinSize), '-');
  560. if i = VarSizesCount div L0BinSize - 1 then
  561. write(f, 'inf')
  562. else
  563. write(f, BinIndexToVarSize((i + 1) * L0BinSize) - 1);
  564. end;
  565. writeln(f);
  566. write(f, 'L0 (bins):');
  567. for i := 0 to VarSizesCount - 1 do
  568. begin
  569. if varFree.L0[SizeUint(i) div L0BinSize] shr (SizeUint(i) mod L0BinSize) and 1 <> 0 then
  570. begin
  571. write(f, ' #', i, ' ', BinIndexToVarSize(i), '-');
  572. if i = VarSizesCount - 1 then
  573. write(f, 'inf')
  574. else
  575. write(f, BinIndexToVarSize(i + 1) - 1);
  576. end;
  577. if Assigned(varFree.bins[i]) then
  578. begin
  579. write(f, ' (');
  580. vf := varFree.bins[i];
  581. repeat
  582. if Assigned(vf^.prev) then write(f, ' ');
  583. write(f, HexStr(PtrUint(vf), 1 + BsrQWord(PtrUint(vf)) div 4), ':', pVarHeader(vf)[-1].ch.h and VarSizeMask);
  584. vf := vf^.next;
  585. until not Assigned(vf);
  586. write(f, ')');
  587. end;
  588. end;
  589. writeln(f);
  590. needLE := true;
  591. end;
  592. begin
  593. writeln(f, 'used = ', used, ', allocated = ', allocated, ', hugeUsed = ', gs.hugeUsed, ', maxUsed = ', maxUsed, ', maxAllocated = ', maxAllocated);
  594. needLE := true;
  595. anything := false;
  596. for i := 0 to FixedSizesCount - 1 do
  597. begin
  598. if not Assigned(partialArenas[i]) and (allocatedByFullArenas[i] = 0) then
  599. continue;
  600. MaybeLE;
  601. anything := true;
  602. write(f, 'Size #', i, ' (', IndexToSize(i), '):');
  603. if allocatedByFullArenas[i] <> 0 then
  604. write(f, ' allocatedByFullArenas = ', allocatedByFullArenas[i]);
  605. if Assigned(partialArenas[i]) then
  606. begin
  607. writeln(f);
  608. fix := partialArenas[i];
  609. repeat
  610. writeln(f, 'arena size = ', pVarHeader(fix)[-1].ch.h and VarSizeMask - VarHeaderSize - FixedArenaDataOffset, ', usedSizeMinus1 = ', fix^.usedSizeMinus1, ', almostFullThreshold = ', fix^.almostFullThreshold);
  611. fix := fix^.next;
  612. until not Assigned(fix);
  613. end
  614. else if allocatedByFullArenas[i] <> 0 then
  615. writeln(f);
  616. end;
  617. needLE := needLE or anything;
  618. if nEmptyArenas <> 0 then
  619. begin
  620. MaybeLE;
  621. writeln(f, 'nEmptyArenas = ', nEmptyArenas);
  622. needLE := true;
  623. end;
  624. vOs := varOS;
  625. while Assigned(vOs) do
  626. begin
  627. MaybeLE;
  628. writeln(f, 'Var OS chunk, size ', vOs^.size);
  629. p := pointer(vOs) + (VarOSChunkDataOffset + VarHeaderSize);
  630. repeat
  631. write(f, HexStr(p), ': size = ', pVarHeader(p - VarHeaderSize)^.ch.h and VarSizeMask, ', ofsToOs = ', pVarHeader(p - VarHeaderSize)^.ofsToOs);
  632. if pVarHeader(p - VarHeaderSize)^.ch.h and UsedFlag <> 0 then
  633. write(f, ', used')
  634. else
  635. begin
  636. write(f, ', f r e e');
  637. if pVarHeader(p - VarHeaderSize)^.ch.h and LastFlag = 0 then
  638. write(f, ' (tail ', pFreeVarTail(p + pVarHeader(p - VarHeaderSize)^.ch.h - VarHeaderSize - FreeVarTailSize)^.size, ')');
  639. end;
  640. if pVarHeader(p - VarHeaderSize)^.ch.h and LastFlag <> 0 then
  641. write(f, ', last');
  642. if pVarHeader(p - VarHeaderSize)^.ch.h and PrevIsFreeFlag <> 0 then
  643. write(f, ', prev. is free');
  644. if pVarHeader(p - VarHeaderSize)^.ch.h and FixedArenaFlag <> 0 then
  645. write(f, ', fixed arena');
  646. writeln(f);
  647. if pVarHeader(p - VarHeaderSize)^.ch.h and LastFlag <> 0 then
  648. break;
  649. p := p + pVarHeader(p - VarHeaderSize)^.ch.h and VarSizeMask;
  650. until false;
  651. needLE := true;
  652. vOs := vOs^.next;
  653. end;
  654. fr := {$ifdef HAS_SYSOSFREE} freeOS1 {$else} freeOS.first {$endif};
  655. if Assigned(fr) then
  656. begin
  657. MaybeLE;
  658. repeat
  659. writeln(f, 'Free OS: ', HexStr(fr), ', size = ', fr^.size);
  660. {$ifndef HAS_SYSOSFREE} fr := fr^.next; {$endif}
  661. until {$ifdef HAS_SYSOSFREE} true {$else} not Assigned(fr) {$endif};
  662. needLE := true;
  663. end;
  664. DumpVarFree(varFree, 'varFree');
  665. {$ifdef FPC_HAS_FEATURE_THREADING}
  666. DumpVarFree(gs.varFree, 'Orphaned varFree');
  667. tf := toFree;
  668. if Assigned(tf) then
  669. begin
  670. MaybeLE;
  671. write(f, 'To-free:');
  672. repeat
  673. if pCommonHeader(pointer(tf) - CommonHeaderSize)^.h and FixedFlag <> 0 then
  674. write(f, ' f ', CommonHeaderSize + SysMemSize(tf))
  675. else
  676. write(f, ' v ', VarHeaderSize + SysMemSize(tf));
  677. tf := tf^.next;
  678. until not Assigned(tf);
  679. writeln(f);
  680. end;
  681. {$endif FPC_HAS_FEATURE_THREADING}
  682. end;
  683. {$endif DEBUG_HEAP_INC}
  684. function HeapInc.ThreadState.ChooseFixedArenaSize(sizeIndex: SizeUint): SizeUint;
  685. begin
  686. result := (allocatedByFullArenas[sizeIndex] div 8 + (FixedArenaSizeQuant - 1)) and SizeUint(-FixedArenaSizeQuant); { 12.5% of memory allocated by the size. }
  687. if result < MinFixedArenaSize then
  688. result := MinFixedArenaSize;
  689. if result > MaxFixedArenaSize then
  690. result := MaxFixedArenaSize;
  691. dec(result, result shr (FirstVarRangeP2 - FirstVarStepP2)); { Prettier fit into OS chunks. }
  692. end;
  693. function HeapInc.ThreadState.AllocFixed(size: SizeUint): pointer;
  694. var
  695. sizeIndex, sizeUp, statv: SizeUint;
  696. usedSizeMinus1: int32;
  697. arena, nextArena: pFixedArena;
  698. begin
  699. sizeIndex := SizeMinus1ToIndex(size + (CommonHeaderSize - 1));
  700. arena := partialArenas[sizeIndex];
  701. if not Assigned(arena) then
  702. begin
  703. {$ifdef FPC_HAS_FEATURE_THREADING}
  704. if Assigned(toFree) then
  705. begin
  706. FlushToFree;
  707. arena := partialArenas[sizeIndex];
  708. end;
  709. if not Assigned(arena) then
  710. {$endif FPC_HAS_FEATURE_THREADING}
  711. begin
  712. arena := emptyArenas;
  713. if Assigned(arena) then
  714. begin
  715. emptyArenas := arena^.next;
  716. dec(nEmptyArenas);
  717. end else
  718. begin
  719. arena := AllocVar(ChooseFixedArenaSize(sizeIndex), true);
  720. if not Assigned(arena) then
  721. exit(nil);
  722. { Size index of the first chunk in the arena is used to determine if it can be reused. Set a purposely mismatching value for freshly allocated arena. }
  723. pCommonHeader(pointer(arena) + FixedArenaDataOffset)^.h := uint32(not sizeIndex);
  724. end;
  725. if pCommonHeader(pointer(arena) + FixedArenaDataOffset)^.h and SizeIndexMask = sizeIndex then
  726. { Lucky! Just don’t reset the chunk and use its old freelist. }
  727. else
  728. begin
  729. arena^.firstFreeChunk := nil;
  730. arena^.usedSizeMinus1 := uint32(-1);
  731. arena^.almostFullThreshold := pVarHeader(arena)[-1].ch.h and VarSizeMask - 2 * IndexToSize(sizeIndex) - (VarHeaderSize + FixedArenaDataOffset); { available space - 2 * chunk size. }
  732. end;
  733. { Add arena to partialArenas[sizeIndex]. }
  734. nextArena := partialArenas[sizeIndex];
  735. arena^.prev := nil;
  736. arena^.next := nextArena;
  737. if Assigned(nextArena) then
  738. nextArena^.prev := arena;
  739. partialArenas[sizeIndex] := arena;
  740. end;
  741. end;
  742. sizeUp := IndexToSize(sizeIndex); { Not reusing the “size” variable saved a register at the time of writing this comment. }
  743. statv := used + sizeUp;
  744. used := statv;
  745. inc(statv, gs.hugeUsed);
  746. if statv > maxUsed then
  747. maxUsed := statv;
  748. { arena from partialArenas has either free chunk or free unformatted space for a new chunk. }
  749. usedSizeMinus1 := int32(arena^.usedSizeMinus1);
  750. result := arena^.firstFreeChunk;
  751. if not Assigned(result) then
  752. begin
  753. { Freelist is empty, so “formattedSize” = usedSizeMinus1 + 1. This “+ 1” is folded into constants. }
  754. result := pointer(arena) + (FixedArenaDataOffset + CommonHeaderSize + 1) + usedSizeMinus1;
  755. pCommonHeader(result - CommonHeadersize)^.h := uint32(int32(sizeIndex) + int32(usedSizeMinus1 shl FixedArenaOffsetShift) +
  756. (FixedFlag + (FixedArenaDataOffset + CommonHeaderSize + 1) shl FixedArenaOffsetShift) { ← const });
  757. end else
  758. arena^.firstFreeChunk := pFreeChunk(result)^.next;
  759. arena^.usedSizeMinus1 := uint32(usedSizeMinus1 + int32(sizeUp));
  760. if usedSizeMinus1 >= int32(arena^.almostFullThreshold) then { Uses usedSizeMinus1 value before adding sizeUp, as assumed by almostFullThreshold. }
  761. begin
  762. inc(allocatedByFullArenas[sizeIndex], pVarHeader(arena)[-1].ch.h and VarSizeMask);
  763. { Remove arena from partialArenas[sizeIndex]. (It was first.) }
  764. nextArena := arena^.next;
  765. partialArenas[sizeIndex] := nextArena;
  766. if Assigned(nextArena) then
  767. nextArena^.prev := nil;
  768. end;
  769. end;
  770. function HeapInc.ThreadState.FreeFixed(p: pointer): SizeUint;
  771. var
  772. sizeIndex: SizeUint;
  773. usedSizeMinus1: int32;
  774. arena, prevArena, nextArena: pFixedArena;
  775. {$ifdef FPC_HAS_FEATURE_THREADING}
  776. ts: pThreadState;
  777. {$endif FPC_HAS_FEATURE_THREADING}
  778. begin
  779. arena := p - pCommonHeader(p - CommonHeaderSize)^.h shr FixedArenaOffsetShift;
  780. {$ifdef FPC_HAS_FEATURE_THREADING}
  781. { This can be checked without blocking; <arena>.threadState can only change from one value not equal to @self to another value not equal to @self. }
  782. if pVarOSChunk(pointer(arena) + pVarHeader(arena)[-1].ofsToOs)^.threadState <> @self then
  783. begin
  784. EnterCriticalSection(gs.lock);
  785. ts := pVarOSChunk(pointer(arena) + pVarHeader(arena)[-1].ofsToOs)^.threadState;
  786. if Assigned(ts) then
  787. begin
  788. { Despite atomic Push lock must be held as otherwise target thread might end and destroy its threadState.
  789. However, target thread won’t block to free p, so PushToFree instantly invalidates p. }
  790. result := IndexToSize(pCommonHeader(p - CommonHeaderSize)^.h and SizeIndexMask) - CommonHeaderSize;
  791. ts^.PushToFree(p);
  792. LeaveCriticalSection(gs.lock);
  793. exit;
  794. end;
  795. AdoptVarOwner(arena); { ...And continue! }
  796. LeaveCriticalSection(gs.lock);
  797. end;
  798. {$endif FPC_HAS_FEATURE_THREADING}
  799. pFreeChunk(p)^.next := arena^.firstFreeChunk;
  800. arena^.firstFreeChunk := p;
  801. sizeIndex := pCommonHeader(p - CommonHeaderSize)^.h and SizeIndexMask;
  802. result := IndexToSize(sizeIndex);
  803. dec(used, result);
  804. usedSizeMinus1 := int32(arena^.usedSizeMinus1) - int32(result);
  805. arena^.usedSizeMinus1 := uint32(usedSizeMinus1);
  806. dec(result, CommonHeaderSize);
  807. { “(usedSizeMinus1 = -1) or (usedSizeMinus1 >= arena^.almostFullThreshold)” as 1 comparison. }
  808. if uint32(usedSizeMinus1) >= arena^.almostFullThreshold then
  809. if usedSizeMinus1 <> -1 then
  810. begin
  811. dec(allocatedByFullArenas[sizeIndex], pVarHeader(arena)[-1].ch.h and VarSizeMask);
  812. { Add arena to partialArenas[sizeIndex]. }
  813. nextArena := partialArenas[sizeIndex];
  814. arena^.next := nextArena;
  815. if Assigned(nextArena) then
  816. nextArena^.prev := arena;
  817. partialArenas[sizeIndex] := arena;
  818. end else
  819. begin
  820. { Remove arena from partialArenas[sizeIndex], add to emptyArenas (maybe). }
  821. prevArena := arena^.prev;
  822. nextArena := arena^.next;
  823. if Assigned(prevArena) then
  824. prevArena^.next := nextArena
  825. else
  826. partialArenas[sizeIndex] := nextArena;
  827. if Assigned(nextArena) then
  828. nextArena^.prev := prevArena;
  829. if nEmptyArenas < MaxKeptFixedArenas then
  830. begin
  831. arena^.next := emptyArenas;
  832. emptyArenas := arena;
  833. inc(nEmptyArenas);
  834. end else
  835. FreeVar(arena);
  836. end;
  837. end;
  838. function HeapInc.ThreadState.GetOSChunk(minSize, maxSize: SizeUint): pOSChunk;
  839. {$if defined(FPC_HAS_FEATURE_THREADING) and not defined(HAS_SYSOSFREE)}
  840. var
  841. statv: SizeUint;
  842. {$endif FPC_HAS_FEATURE_THREADING and not HAS_SYSOSFREE}
  843. begin
  844. {$ifdef HAS_SYSOSFREE}
  845. result := freeOS1;
  846. if Assigned(result) then
  847. if (result^.size >= minSize) and (result^.size <= maxSize) then
  848. freeOS1 := nil
  849. else
  850. result := nil;
  851. {$else HAS_SYSOSFREE}
  852. result := freeOS.Get(minSize, maxSize);
  853. {$ifdef FPC_HAS_FEATURE_THREADING}
  854. if not Assigned(result) and Assigned(gs.freeOS.first) then { Racing precheck. }
  855. begin
  856. EnterCriticalSection(gs.lock);
  857. result := gs.freeOS.Get(minSize, maxSize);
  858. LeaveCriticalSection(gs.lock);
  859. if Assigned(result) then
  860. begin
  861. statv := allocated + result^.size;
  862. allocated := statv;
  863. inc(statv, gs.hugeUsed);
  864. if statv > maxAllocated then
  865. maxAllocated := statv;
  866. end;
  867. end;
  868. {$endif FPC_HAS_FEATURE_THREADING}
  869. {$endif HAS_SYSOSFREE}
  870. end;
  871. function HeapInc.ThreadState.AllocateOSChunk(minSize, maxSize: SizeUint): pOSChunk;
  872. var
  873. query, statv: SizeUint;
  874. begin
  875. query := used div 16 + minSize div 2; { Base: 6.25% of the memory used, so if GrowHeapSize2 = 1 Mb, 1 Mb OS allocations start at 16 Mb used. }
  876. if query > maxSize then { Limit by maxSize (usually GrowHeapSize2). }
  877. query := maxSize;
  878. if query < minSize then { But of course allocate at least the amount requested. Also triggers if maxSize was wrong (smaller than minSize). }
  879. query := minSize;
  880. query := (query + (OSChunkVarSizeQuant - 1)) and SizeUint(-OSChunkVarSizeQuant); { Quantize. }
  881. result := SysOSAlloc(query);
  882. if not Assigned(result) and (query > minSize) then
  883. begin
  884. query := minSize;
  885. result := SysOSAlloc(query);
  886. end;
  887. if not Assigned(result) then
  888. exit(AllocFailed);
  889. result^.size := query;
  890. statv := allocated + query;
  891. allocated := statv;
  892. inc(statv, gs.hugeUsed);
  893. if statv > maxAllocated then
  894. maxAllocated := statv;
  895. end;
  896. function HeapInc.ThreadState.AllocVar(size: SizeUint; isArena: boolean): pointer;
  897. var
  898. fv: pFreeVarChunk;
  899. osChunk, osNext: pVarOSChunk;
  900. binIndex, vSizeFlags, statv: SizeUint;
  901. begin
  902. {$ifdef FPC_HAS_FEATURE_THREADING}
  903. if Assigned(toFree) then
  904. FlushToFree;
  905. {$endif}
  906. { Search varFree for (roughly) smallest chunk ≥ size. }
  907. binIndex := VarSizeToBinIndex(size + VarHeaderSize, true);
  908. { Round the size up to the bin size.
  909. Can do without that, but not doing that will often mean the inability to reuse the hole because varFree rounds up for searches and down for additions. }
  910. size := BinIndexToVarSize(binIndex);
  911. fv := varFree.Find(binIndex);
  912. if not Assigned(fv) then
  913. begin
  914. { Find either other fv or other osChunk that can fit the requested size. }
  915. osChunk := pVarOSChunk(GetOSChunk(VarOSChunkDataOffset + size, GrowHeapSize2));
  916. if not Assigned(osChunk) then
  917. begin
  918. {$ifdef FPC_HAS_FEATURE_THREADING}
  919. { Preliminary search without blocking, assuming varFree.Find doesn’t do anything that can go wrong. }
  920. fv := gs.varFree.Find(binIndex);
  921. if Assigned(fv) then
  922. begin
  923. EnterCriticalSection(gs.lock);
  924. fv := gs.varFree.Find(binIndex); { True search. }
  925. if Assigned(fv) then
  926. AdoptVarOwner(fv); { Moves fv to own varFree. }
  927. LeaveCriticalSection(gs.lock);
  928. end;
  929. if not Assigned(fv) then
  930. {$endif FPC_HAS_FEATURE_THREADING}
  931. begin
  932. osChunk := pVarOSChunk(AllocateOSChunk(VarOSChunkDataOffset + size, GrowHeapSize2));
  933. if not Assigned(osChunk) then
  934. exit(nil);
  935. end;
  936. end;
  937. end;
  938. if not Assigned(fv) then
  939. begin
  940. {$ifdef FPC_HAS_FEATURE_THREADING}
  941. osChunk^.threadState := @self;
  942. {$endif}
  943. { Add osChunk to varOS. }
  944. osNext := varOS;
  945. osChunk^.prev := nil;
  946. osChunk^.next := osNext;
  947. if Assigned(osNext) then
  948. osNext^.prev := osChunk;
  949. varOS := osChunk;
  950. { Format new free var chunk spanning the entire osChunk. FreeVarTail is not required. }
  951. fv := pointer(osChunk) + (VarOSChunkDataOffset + VarHeaderSize);
  952. pVarHeader(pointer(fv) - VarHeaderSize)^.ofsToOs := -(VarOSChunkDataOffset + VarHeaderSize);
  953. pVarHeader(pointer(fv) - VarHeaderSize)^.ch.h := (uint32(osChunk^.size) - VarOSChunkDataOffset) and VarSizeMask + LastFlag;
  954. end else
  955. varFree.Remove(fv);
  956. { Result will be allocated at the beginning of fv; maybe format the remainder and add it back to varFree. }
  957. result := fv;
  958. vSizeFlags := pVarHeader(fv)[-1].ch.h - size; { Inherits LastFlag. }
  959. { Allow leaving a non-searchable tail if non-last.
  960. “vSizeFlags >= MinAnyVarHeaderAndPayload” if non-last, “vSizeFlags >= MinSearchableVarHeaderAndPayload” if last. }
  961. if vSizeFlags >= MinAnyVarHeaderAndPayload + (MinSearchableVarHeaderAndPayload - MinAnyVarHeaderAndPayload) div LastFlag * (vSizeFlags and LastFlag) then
  962. begin
  963. pVarHeader(result - VarHeaderSize)^.ch.h := uint32(size) + UsedFlag;
  964. inc(pointer(fv), size); { result = allocated block, fv = remainder. }
  965. pVarHeader(pointer(fv) - VarHeaderSize)^.ofsToOs := pVarHeader(result - VarHeaderSize)^.ofsToOs - int32(size);
  966. pVarHeader(pointer(fv) - VarHeaderSize)^.ch.h := vSizeFlags;
  967. { Chunk to the right retains its PrevFreeFlag. }
  968. if vSizeFlags and LastFlag = 0 then
  969. pFreeVarTail(pointer(fv) + vSizeFlags - VarHeaderSize - FreeVarTailSize)^.size := vSizeFlags;
  970. if vSizeFlags >= MinSearchableVarHeaderAndPayload then
  971. varFree.Add(fv, VarSizeToBinIndex(vSizeFlags, false)); { Rounding down, so not masking is ok. }
  972. end else
  973. begin
  974. { Use the entire chunk. }
  975. inc(vSizeFlags, size);
  976. pVarHeader(result - VarHeaderSize)^.ch.h := uint32(vSizeFlags) + UsedFlag;
  977. if vSizeFlags and LastFlag = 0 then
  978. dec(pVarHeader(pointer(fv) + vSizeFlags - VarHeaderSize)^.ch.h, PrevIsFreeFlag);
  979. size := vSizeFlags and VarSizeMask;
  980. end;
  981. if isArena then
  982. inc(pVarHeader(result)[-1].ch.h, FixedArenaFlag) { Arenas aren’t counted in “used” directly. }
  983. else
  984. begin
  985. statv := used + size;
  986. used := statv;
  987. inc(statv, gs.hugeUsed);
  988. if statv > maxUsed then
  989. maxUsed := statv;
  990. end;
  991. end;
  992. function HeapInc.ThreadState.FreeVar(p: pointer): SizeUint;
  993. var
  994. p2: pointer;
  995. fSizeFlags, hPrev, hNext: SizeUint;
  996. osChunk, osPrev, osNext: pVarOSChunk;
  997. {$ifdef FPC_HAS_FEATURE_THREADING}
  998. ts: pThreadState;
  999. {$endif FPC_HAS_FEATURE_THREADING}
  1000. {$ifndef HAS_SYSOSFREE}
  1001. freeOsNext: pFreeOSChunk;
  1002. fOs: ^FreeOSChunkList;
  1003. {$endif not HAS_SYSOSFREE}
  1004. begin
  1005. {$ifdef FPC_HAS_FEATURE_THREADING}
  1006. if pVarOSChunk(p + pVarHeader(p - VarHeaderSize)^.ofsToOs)^.threadState <> @self then
  1007. begin
  1008. EnterCriticalSection(gs.lock);
  1009. ts := pVarOSChunk(p + pVarHeader(p - VarHeaderSize)^.ofsToOs)^.threadState;
  1010. if Assigned(ts) then
  1011. begin
  1012. { Despite atomic Push lock must be held as otherwise target thread might end and destroy its threadState.
  1013. However, target thread won’t block to free p, so PushToFree instantly invalidates p. }
  1014. result := pVarHeader(p - VarHeaderSize)^.ch.h and VarSizeMask - VarHeaderSize;
  1015. ts^.PushToFree(p);
  1016. LeaveCriticalSection(gs.lock);
  1017. exit;
  1018. end;
  1019. AdoptVarOwner(p); { ...And continue! }
  1020. LeaveCriticalSection(gs.lock);
  1021. end;
  1022. {$endif FPC_HAS_FEATURE_THREADING}
  1023. fSizeFlags := pVarHeader(p - VarHeaderSize)^.ch.h;
  1024. result := fSizeFlags and VarSizeMask;
  1025. if fSizeFlags and FixedArenaFlag = 0 then
  1026. dec(used, result)
  1027. else
  1028. dec(fSizeFlags, FixedArenaFlag);
  1029. { If next/prev are free, remove them from varFree and merge with f — (f)uture (f)ree chunk that starts at p and has fSizeFlags. }
  1030. if fSizeFlags and LastFlag = 0 then
  1031. begin
  1032. p2 := p + result;
  1033. hNext := pVarHeader(p2 - VarHeaderSize)^.ch.h;
  1034. if uint32(hNext) and UsedFlag = 0 then
  1035. begin
  1036. inc(fSizeFlags, hNext); { Inherit LastFlag, other p2 flags must be 0. }
  1037. if hNext >= MinSearchableVarHeaderAndPayload then { Logically “hNext and VarSizeMask”. }
  1038. varFree.Remove(p2);
  1039. { Chunk to the right retains its PrevFreeFlag. }
  1040. end;
  1041. end;
  1042. if fSizeFlags and PrevIsFreeFlag <> 0 then
  1043. begin
  1044. dec(fSizeFlags, PrevIsFreeFlag);
  1045. p2 := p - pFreeVarTail(p - VarHeaderSize - FreeVarTailSize)^.size;
  1046. hPrev := pVarHeader(p2 - VarHeaderSize)^.ch.h;
  1047. if uint32(hPrev) and UsedFlag = 0 then
  1048. begin
  1049. p := p2;
  1050. inc(fSizeFlags, hPrev); { All p2 flags must be 0. }
  1051. if hPrev >= MinSearchableVarHeaderAndPayload then { Logically “hPrev and VarSizeMask”. }
  1052. varFree.Remove(p2);
  1053. end;
  1054. end;
  1055. { Turn p into a free chunk and add it back to varFree...
  1056. unless it spans the entire OS chunk, in which case instead move the chunk from varOS to freeOS1 / freeOS. }
  1057. if (fSizeFlags and LastFlag = 0) or (pVarHeader(p - VarHeaderSize)^.ofsToOs <> -(VarOSChunkDataOffset + VarHeaderSize)) then
  1058. begin
  1059. dec(fSizeFlags, UsedFlag);
  1060. pVarHeader(p - VarHeaderSize)^.ch.h := fSizeFlags;
  1061. varFree.Add(p, VarSizeToBinIndex(fSizeFlags, false));
  1062. if fSizeFlags and LastFlag = 0 then
  1063. begin
  1064. pVarHeader(p + fSizeFlags - VarHeaderSize)^.ch.h := pVarHeader(p + fSizeFlags - VarHeaderSize)^.ch.h or PrevIsFreeFlag; { Could have it already. }
  1065. pFreeVarTail(p + fSizeFlags - VarHeaderSize - FreeVarTailSize)^.size := fSizeFlags;
  1066. end;
  1067. end else
  1068. begin
  1069. osChunk := p - (VarOSChunkDataOffset + VarHeaderSize);
  1070. { Remove osChunk from varOS. }
  1071. osPrev := osChunk^.prev;
  1072. osNext := osChunk^.next;
  1073. if Assigned(osPrev) then
  1074. osPrev^.next := osNext
  1075. else
  1076. varOS := osNext;
  1077. if Assigned(osNext) then
  1078. osNext^.prev := osPrev;
  1079. {$ifdef HAS_SYSOSFREE}
  1080. { Move to freeOS1, discarding old freeOS1. }
  1081. if Assigned(freeOS1) then
  1082. begin
  1083. dec(allocated, freeOS1^.size);
  1084. SysOSFree(freeOS1, freeOS1^.size);
  1085. end;
  1086. freeOS1 := pFreeOSChunk(osChunk);
  1087. {$else HAS_SYSOSFREE}
  1088. fOs := @freeOS;
  1089. { Share if huge. }
  1090. {$ifdef FPC_HAS_FEATURE_THREADING}
  1091. if osChunk^.size > GrowHeapSize2 then
  1092. begin
  1093. fOs := @gs.freeOS;
  1094. EnterCriticalSection(gs.lock);
  1095. end;
  1096. {$endif FPC_HAS_FEATURE_THREADING}
  1097. { Add to fOs. }
  1098. freeOsNext := fOs^.first;
  1099. osChunk^.prev := nil;
  1100. osChunk^.next := freeOsNext;
  1101. if Assigned(freeOsNext) then
  1102. freeOsNext^.prev := osChunk
  1103. else
  1104. fOs^.last := pFreeOSChunk(osChunk);
  1105. fOs^.first := pFreeOSChunk(osChunk);
  1106. {$ifdef FPC_HAS_FEATURE_THREADING}
  1107. if fOs <> @freeOS then
  1108. begin
  1109. dec(allocated, osChunk^.size); { gs.freeOS aren’t counted anywhere, for now. }
  1110. LeaveCriticalSection(gs.lock);
  1111. end;
  1112. {$endif FPC_HAS_FEATURE_THREADING}
  1113. {$endif HAS_SYSOSFREE}
  1114. end;
  1115. dec(result, VarHeaderSize);
  1116. end;
  1117. function HeapInc.ThreadState.TryResizeVar(p: pointer; size: SizeUint): pointer;
  1118. var
  1119. fp, p2: pointer;
  1120. oldpsize, fSizeFlags, growby, statv: SizeUint;
  1121. begin
  1122. if (size <= MaxFixedHeaderAndPayload - CommonHeaderSize)
  1123. or (size > GrowHeapSize2) { Not strictly necessary but rejects clearly wrong values early so adding headers to the size doesn’t overflow. }
  1124. {$ifdef FPC_HAS_FEATURE_THREADING}
  1125. or (pVarOSChunk(p + pVarHeader(p - VarHeaderSize)^.ofsToOs)^.threadState <> @self)
  1126. {$endif}
  1127. then
  1128. exit(nil);
  1129. { Round the size up, but only if supported by VarSizeToBinIndex: chunks can be reallocated to the sizes larger than MaxVarHeaderAndPayload. }
  1130. if size <= MaxVarHeaderAndPayload - VarHeaderSize then
  1131. size := BinIndexToVarSize(VarSizeToBinIndex(size + VarHeaderSize, true))
  1132. else
  1133. size := (size + (VarHeaderSize + VarSizeQuant - 1)) and SizeUint(-VarSizeQuant); { Just do the strictly necessary quantization... }
  1134. result := p; { From now on use result instead of p (saves a register). }
  1135. oldpsize := pVarHeader(result - VarHeaderSize)^.ch.h and VarSizeMask;
  1136. p2 := result + oldpsize;
  1137. { (f)uture (f)ree chunk starting at p + size and having fSizeFlags will be created at the end, must exit before that if not required. }
  1138. if size <= oldpsize then
  1139. begin
  1140. { Shrink. Maybe. }
  1141. fSizeFlags := oldpsize - size;
  1142. if (pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag <> 0) or (pVarHeader(p2 - VarHeaderSize)^.ch.h and UsedFlag <> 0) then
  1143. begin
  1144. { No empty chunk to the right: create free chunk following the same logic as in AllocVar regarding the non-searchable tail, otherwise report success but change nothing. }
  1145. if fSizeFlags < MinAnyVarHeaderAndPayload + (MinSearchableVarHeaderAndPayload - MinAnyVarHeaderAndPayload) div LastFlag * (pVarHeader(result)[-1].ch.h and LastFlag) then
  1146. exit;
  1147. dec(used, fSizeFlags);
  1148. inc(fSizeFlags, pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag);
  1149. dec(pVarHeader(result - VarHeaderSize)^.ch.h, fSizeFlags);
  1150. end else
  1151. begin
  1152. if fSizeFlags = 0 then { Exit early if going to be a no-op. Branch above does the same with a broader check. }
  1153. exit;
  1154. dec(used, fSizeFlags);
  1155. { Has empty chunk to the right: extend with freed space. }
  1156. dec(pVarHeader(result - VarHeaderSize)^.ch.h, fSizeFlags);
  1157. inc(fSizeFlags, pVarHeader(p2 - VarHeaderSize)^.ch.h);
  1158. if pVarHeader(p2)[-1].ch.h >= MinSearchableVarHeaderAndPayload then
  1159. varFree.Remove(p2);
  1160. end;
  1161. end
  1162. { Grow if there is free space. Note this can result in a chunk larger than e.g. SysGetMem allows (GrowHeapSize div 2 or so). That’s okay as it saves a Move. }
  1163. else if (pVarHeader(result - VarHeaderSize)^.ch.h and LastFlag = 0) and (pVarHeader(p2 - VarHeaderSize)^.ch.h and UsedFlag = 0) and
  1164. (pVarHeader(p2)[-1].ch.h >= SizeUint(size - oldpsize)) { Can check without “and VarSizeMask”, will remain ≥ anyway. }
  1165. then
  1166. begin
  1167. fSizeFlags := pVarHeader(p2)[-1].ch.h - (size - oldpsize); { Inherits LastFlag, other flags are 0. }
  1168. if fSizeFlags < MinAnyVarHeaderAndPayload + (MinSearchableVarHeaderAndPayload - MinAnyVarHeaderAndPayload) div LastFlag * (fSizeFlags and LastFlag) then
  1169. fSizeFlags := fSizeFlags and LastFlag;
  1170. growby := pVarHeader(p2)[-1].ch.h - fSizeFlags;
  1171. size := oldpsize + growby;
  1172. statv := used + growby;
  1173. used := statv;
  1174. inc(statv, gs.hugeUsed);
  1175. if statv > maxUsed then
  1176. maxUsed := statv;
  1177. { Update p size. }
  1178. inc(pVarHeader(result - VarHeaderSize)^.ch.h, growby);
  1179. if pVarHeader(p2)[-1].ch.h >= MinSearchableVarHeaderAndPayload then
  1180. varFree.Remove(p2);
  1181. { No empty chunk? }
  1182. if fSizeFlags <= LastFlag then
  1183. begin
  1184. inc(pVarHeader(result - VarHeaderSize)^.ch.h, fSizeFlags); { Either += LastFlag or a no-op. }
  1185. if fSizeFlags = 0 then { logically “and LastFlag = 0” }
  1186. dec(pVarHeader(result + size - VarHeaderSize)^.ch.h, PrevIsFreeFlag);
  1187. exit;
  1188. end;
  1189. end else
  1190. { Possible another case to handle: on growth, if there is no space to the right but there is space to the LEFT, move the data there, avoiding the GetMem + FreeMem.
  1191. Probably not common enough, but I didn’t even investigate. }
  1192. exit(nil);
  1193. { Format new free var chunk. }
  1194. fp := result + size;
  1195. pVarHeader(fp - VarHeaderSize)^.ofsToOs := pVarHeader(result - VarHeaderSize)^.ofsToOs - int32(size);
  1196. pVarHeader(fp - VarHeaderSize)^.ch.h := fSizeFlags;
  1197. if fSizeFlags and LastFlag = 0 then
  1198. begin
  1199. pVarHeader(fp + fSizeFlags - VarHeaderSize)^.ch.h := pVarHeader(fp + fSizeFlags - VarHeaderSize)^.ch.h or PrevIsFreeFlag; { Could have it already. }
  1200. pFreeVarTail(fp + fSizeFlags - VarHeaderSize - FreeVarTailSize)^.size := fSizeFlags;
  1201. end;
  1202. if fSizeFlags >= MinSearchableVarHeaderAndPayload then
  1203. varFree.Add(fp, VarSizeToBinIndex(fSizeFlags, false));
  1204. end;
  1205. { If SysOSFree is available, huge chunks aren’t cached by any means.
  1206. If SysOSFree is not available, there’s no choice but to cache them.
  1207. Caching is done directly into gs.freeOS if FPC_HAS_FEATURE_THREADING, otherwise ThreadState.freeOS. }
  1208. class function HeapInc.ThreadState.AddToHugeUsed(delta: SizeInt): SizeUint;
  1209. begin
  1210. {$if not defined(FPC_HAS_FEATURE_THREADING)}
  1211. result := SizeUint(SizeInt(gs.hugeUsed) + delta);
  1212. gs.hugeUsed := result;
  1213. {$elseif not defined(VER3_2)}
  1214. result := AtomicIncrement(gs.hugeUsed, SizeUint(delta));
  1215. {$elseif sizeof(SizeInt) = sizeof(int64)}
  1216. result := SizeUint(delta + InterlockedExchangeAdd64(SizeInt(gs.hugeUsed), delta));
  1217. {$else}
  1218. result := SizeUint(delta + InterlockedExchangeAdd(SizeInt(gs.hugeUsed), delta));
  1219. {$endif}
  1220. end;
  1221. function HeapInc.ThreadState.AllocHuge(size: SizeUint): pointer;
  1222. var
  1223. userSize: SizeUint;
  1224. begin
  1225. userSize := size;
  1226. size := (size + (HugeChunkDataOffset + CommonHeaderSize + OSChunkVarSizeQuant - 1)) and SizeUint(-OSChunkVarSizeQuant);
  1227. if size < userSize then { Overflow. }
  1228. exit(AllocFailed);
  1229. {$ifdef FPC_HAS_FEATURE_THREADING}
  1230. if Assigned(toFree) then
  1231. FlushToFree;
  1232. {$endif}
  1233. {$ifdef HAS_SYSOSFREE}
  1234. result := SysOSAlloc(size);
  1235. if not Assigned(result) then
  1236. exit(AllocFailed);
  1237. pHugeChunk(result)^.size := size;
  1238. {$else HAS_SYSOSFREE}
  1239. result := GetOSChunk(size, High(SizeUint));
  1240. if not Assigned(result) then
  1241. begin
  1242. result := AllocateOSChunk(size, High(SizeUint));
  1243. if not Assigned(result) then
  1244. exit; { AllocateOSChunk throws an error if required. }
  1245. end;
  1246. size := pOSChunk(result)^.size;
  1247. dec(allocated, size); { After GetOSChunk* chunk size is counted in “allocated”; don’t count. }
  1248. {$endif HAS_SYSOSFREE}
  1249. pCommonHeader(result + HugeChunkDataOffset)^.h := HugeHeader;
  1250. inc(result, HugeChunkDataOffset + CommonHeaderSize);
  1251. UpdateMaxStats(AddToHugeUsed(size));
  1252. end;
  1253. function HeapInc.ThreadState.FreeHuge(p: pointer): SizeUint;
  1254. {$ifndef HAS_SYSOSFREE}
  1255. var
  1256. fOs: ^FreeOSChunkList;
  1257. osPrev: pOSChunk;
  1258. {$endif ndef HAS_SYSOSFREE}
  1259. begin
  1260. dec(p, HugeChunkDataOffset + CommonHeaderSize);
  1261. result := pHugeChunk(p)^.size;
  1262. AddToHugeUsed(-SizeInt(result));
  1263. {$ifndef HAS_SYSOSFREE} { But you’d better have SysOSFree... }
  1264. {$ifdef FPC_HAS_FEATURE_THREADING}
  1265. fOs := @gs.freeOS; { gs.freeOS aren’t counted anywhere (for now). }
  1266. EnterCriticalSection(gs.lock);
  1267. {$else FPC_HAS_FEATURE_THREADING}
  1268. fOs := @freeOS;
  1269. inc(allocated, result); { ThreadState.freeOS are counted in ThreadState.allocated. But since “size” (= result) is just moved from “hugeUsed” to “allocated”, it won’t affect maximums. }
  1270. {$endif FPC_HAS_FEATURE_THREADING}
  1271. { Turn p into FreeOSChunk and add to fOs; add to the end to reduce the chance for this chunk to be reused
  1272. (other OS chunks are added to the beginning and searched from the beginning). }
  1273. osPrev := fOs^.last;
  1274. pFreeOSChunk(p)^.prev := osPrev;
  1275. pFreeOSChunk(p)^.next := nil;
  1276. if Assigned(osPrev) then
  1277. osPrev^.next := p
  1278. else
  1279. fOs^.first := p;
  1280. fOs^.last := p;
  1281. {$ifdef FPC_HAS_FEATURE_THREADING} LeaveCriticalSection(gs.lock); {$endif}
  1282. {$endif ndef HAS_SYSOSFREE}
  1283. {$ifdef HAS_SYSOSFREE} SysOSFree(p, result); {$endif}
  1284. dec(result, HugeChunkDataOffset + CommonHeaderSize);
  1285. end;
  1286. function HeapInc.ThreadState.TryResizeHuge(p: pointer; size: SizeUint): pointer;
  1287. var
  1288. userSize, oldSize: SizeUint;
  1289. begin
  1290. userSize := size;
  1291. size := (size + (HugeChunkDataOffset + CommonHeaderSize + OSChunkVarSizeQuant - 1)) and SizeUint(-OSChunkVarSizeQuant);
  1292. if (size < userSize) or { Overflow. }
  1293. (size < GrowHeapSize2 div 4) { Limit on shrinking huge chunks. }
  1294. then
  1295. exit(nil);
  1296. oldSize := pHugeChunk(p - (HugeChunkDataOffset + CommonHeaderSize))^.size;
  1297. if size = oldSize then
  1298. exit(p);
  1299. {$ifdef FPC_SYSTEM_HAS_SYSOSREALLOC}
  1300. result := SysOSRealloc(p - (HugeChunkDataOffset + CommonHeaderSize), oldSize, size);
  1301. if Assigned(result) then
  1302. begin
  1303. UpdateMaxStats(AddToHugeUsed(SizeInt(size) - SizeInt(oldSize)));
  1304. pHugeChunk(result)^.size := size;
  1305. inc(result, HugeChunkDataOffset + CommonHeaderSize);
  1306. end;
  1307. {$else FPC_SYSTEM_HAS_SYSOSREALLOC}
  1308. result := nil; { Just don’t. Note shrinking 20 Mb to 19 will require temporary 39 because of this. }
  1309. {$endif FPC_SYSTEM_HAS_SYSOSREALLOC}
  1310. end;
  1311. procedure HeapInc.ThreadState.UpdateMaxStats(hugeUsed: SizeUint);
  1312. var
  1313. statv: SizeUint;
  1314. begin
  1315. statv := used + hugeUsed;
  1316. if statv > maxUsed then
  1317. maxUsed := statv;
  1318. statv := allocated + hugeUsed;
  1319. if statv > maxAllocated then
  1320. maxAllocated := statv;
  1321. end;
  1322. {$ifdef FPC_HAS_FEATURE_THREADING}
  1323. procedure HeapInc.ThreadState.PushToFree(p: pFreeChunk);
  1324. var
  1325. next: pFreeChunk;
  1326. begin
  1327. repeat
  1328. next := toFree;
  1329. p^.next := next;
  1330. WriteBarrier; { Write p after p^.next. }
  1331. until InterlockedCompareExchange(toFree, p, next) = next;
  1332. end;
  1333. procedure HeapInc.ThreadState.FlushToFree;
  1334. var
  1335. tf, nx: pFreeChunk;
  1336. begin
  1337. tf := InterlockedExchange(toFree, nil);
  1338. while Assigned(tf) do
  1339. begin
  1340. ReadDependencyBarrier; { Read toFree^.next after toFree. }
  1341. nx := tf^.next;
  1342. SysFreeMem(tf);
  1343. tf := nx;
  1344. end;
  1345. end;
  1346. procedure HeapInc.ThreadState.Orphan;
  1347. var
  1348. arena: pFixedArena;
  1349. vOs: pVarOSChunk;
  1350. p: pointer;
  1351. h: uint32;
  1352. {$ifndef HAS_SYSOSFREE}
  1353. lastFree, nextFree: pFreeOSChunk;
  1354. {$endif not HAS_SYSOSFREE}
  1355. begin
  1356. if gs.lockUse > 0 then
  1357. EnterCriticalSection(HeapInc.gs.lock);
  1358. FlushToFree; { Performing it under gs.lock guarantees there will be no new toFree requests. }
  1359. { Has to free all empty arenas, otherwise the chunk that contains only empty arenas will leak (no one will ever adopt it, as it has nothing to free). }
  1360. while nEmptyArenas > 0 do
  1361. begin
  1362. arena := emptyArenas;
  1363. emptyArenas := arena^.next;
  1364. dec(nEmptyArenas);
  1365. FreeVar(arena);
  1366. end;
  1367. {$ifndef HAS_SYSOSFREE}
  1368. { Prepend freeOS to gs.freeOS. }
  1369. lastFree := freeOS.last;
  1370. if Assigned(lastFree) then
  1371. begin
  1372. nextFree := gs.freeOS.first;
  1373. lastFree^.next := nextFree;
  1374. if Assigned(nextFree) then
  1375. nextFree^.prev := lastFree
  1376. else
  1377. gs.freeOS.last := lastFree;
  1378. gs.freeOS.first := freeOS.first;
  1379. { Zeroing is probably required, because Orphan is called from FinalizeHeap which is called from DoneThread which can be called twice, according to this comment from syswin.inc: }
  1380. // DoneThread; { Assume everything is idempotent there }
  1381. freeOS.first := nil;
  1382. freeOS.last := nil;
  1383. end;
  1384. {$endif not HAS_SYSOSFREE}
  1385. vOs := varOS;
  1386. while Assigned(vOs) do
  1387. begin
  1388. vOs^.threadState := nil;
  1389. p := pointer(vOs) + (VarOSChunkDataOffset + VarHeaderSize);
  1390. repeat
  1391. h := pVarHeader(p - VarHeaderSize)^.ch.h;
  1392. if (h and UsedFlag = 0) and (h >= MinSearchableVarHeaderAndPayload) then
  1393. gs.varFree.Add(p, pFreeVarChunk(p)^.binIndex);
  1394. inc(p, h and VarSizeMask);
  1395. until h and LastFlag <> 0;
  1396. vOs := vOs^.next;
  1397. end;
  1398. varOS := nil;
  1399. if gs.lockUse > 0 then
  1400. LeaveCriticalSection(gs.lock);
  1401. {$ifdef HAS_SYSOSFREE}
  1402. if Assigned(freeOS1) then
  1403. begin
  1404. SysOSFree(freeOS1, freeOS1^.size); { Does not require gs.lock. }
  1405. freeOS1 := nil;
  1406. end;
  1407. {$endif HAS_SYSOSFREE}
  1408. end;
  1409. procedure HeapInc.ThreadState.AdoptArena(arena: pFixedArena);
  1410. var
  1411. sizeIndex: SizeUint;
  1412. nextArena: pFixedArena;
  1413. begin
  1414. sizeIndex := pCommonHeader(pointer(arena) + FixedArenaDataOffset)^.h and SizeIndexMask;
  1415. inc(used, arena^.usedSizeMinus1 + 1); { maxUsed is updated at the end of AdoptVarOwner. }
  1416. { Orphan frees all empty arenas, so adopted arena can’t be empty. }
  1417. if arena^.usedSizeMinus1 < arena^.almostFullThreshold + IndexToSize(sizeIndex) then
  1418. begin
  1419. { Add arena to partialArenas[sizeIndex]. }
  1420. nextArena := partialArenas[sizeIndex];
  1421. arena^.prev := nil;
  1422. arena^.next := nextArena;
  1423. if Assigned(nextArena) then
  1424. nextArena^.prev := arena;
  1425. partialArenas[sizeIndex] := arena;
  1426. end else
  1427. inc(allocatedByFullArenas[sizeIndex], pVarHeader(arena)[-1].ch.h and VarSizeMask);
  1428. end;
  1429. procedure HeapInc.ThreadState.AdoptVarOwner(p: pointer);
  1430. var
  1431. statv: SizeUint;
  1432. h: uint32;
  1433. vOs, osNext: pVarOSChunk;
  1434. begin
  1435. vOs := p + pVarHeader(p)[-1].ofsToOs;
  1436. vOs^.threadState := @self;
  1437. { Add OS chunk to varOS. }
  1438. vOs^.prev := nil;
  1439. osNext := varOS;
  1440. vOs^.next := osNext;
  1441. if Assigned(osNext) then
  1442. osNext^.prev := vOs;
  1443. varOS := vOs;
  1444. statv := allocated + vOs^.size;
  1445. allocated := statv;
  1446. inc(statv, gs.hugeUsed);
  1447. if statv > maxAllocated then
  1448. maxAllocated := statv;
  1449. p := pointer(vOs) + VarOSChunkDataOffset + VarHeaderSize;
  1450. repeat
  1451. h := pVarHeader(p - VarHeaderSize)^.ch.h;
  1452. if h and UsedFlag = 0 then
  1453. begin
  1454. if h >= MinSearchableVarHeaderAndPayload then
  1455. begin
  1456. gs.varFree.Remove(p);
  1457. varFree.Add(p, pFreeVarChunk(p)^.binIndex);
  1458. end;
  1459. end
  1460. else if h and FixedArenaFlag <> 0 then
  1461. AdoptArena(p)
  1462. else
  1463. inc(used, h and VarSizeMask); { maxUsed is updated after the loop. }
  1464. inc(p, h and VarSizeMask);
  1465. until h and LastFlag <> 0;
  1466. statv := used + gs.hugeUsed;
  1467. if statv > maxUsed then
  1468. maxUsed := statv;
  1469. end;
  1470. {$ifndef FPC_SECTION_THREADVARS}
  1471. procedure HeapInc.ThreadState.FixupSelfPtr;
  1472. var
  1473. vOs: pVarOSChunk;
  1474. begin
  1475. vOs := varOS;
  1476. while Assigned(vOs) do
  1477. begin
  1478. vOs^.threadState := @self;
  1479. vOs := vOs^.next;
  1480. end;
  1481. end;
  1482. {$endif ndef FPC_SECTION_THREADVARS}
  1483. {$endif FPC_HAS_FEATURE_THREADING}
  1484. class function HeapInc.AllocFailed: pointer;
  1485. begin
  1486. if not ReturnNilIfGrowHeapFails then
  1487. HandleError(204);
  1488. result := nil;
  1489. end;
  1490. function SysGetFPCHeapStatus:TFPCHeapStatus;
  1491. var
  1492. ts: HeapInc.pThreadState;
  1493. hugeUsed: SizeUint;
  1494. begin
  1495. ts := @HeapInc.thisTs;
  1496. hugeUsed := HeapInc.gs.hugeUsed;
  1497. ts^.UpdateMaxStats(hugeUsed); { Cheat to avoid clearly implausible values like current > max. }
  1498. result.MaxHeapSize := ts^.maxAllocated;
  1499. result.MaxHeapUsed := ts^.maxUsed;
  1500. result.CurrHeapSize := hugeUsed + ts^.allocated;
  1501. result.CurrHeapUsed := hugeUsed + ts^.used;
  1502. result.CurrHeapFree := result.CurrHeapSize - result.CurrHeapUsed;
  1503. end;
  1504. function SysGetHeapStatus :THeapStatus;
  1505. var
  1506. fhs: TFPCHeapStatus;
  1507. begin
  1508. fhs := SysGetFPCHeapStatus;
  1509. FillChar((@result)^, sizeof(result), 0);
  1510. result.TotalAllocated := fhs.CurrHeapUsed;
  1511. result.TotalFree := fhs.CurrHeapSize - fhs.CurrHeapUsed;
  1512. result.TotalAddrSpace := fhs.CurrHeapSize;
  1513. end;
  1514. function SysGetMem(size : ptruint):pointer;
  1515. var
  1516. ts: HeapInc.pThreadState;
  1517. begin
  1518. ts := @HeapInc.thisTs;
  1519. if size <= HeapInc.MaxFixedHeaderAndPayload - HeapInc.CommonHeaderSize then
  1520. result := ts^.AllocFixed(size)
  1521. else if (size < GrowHeapSize2 div 2) { Approximate idea on the max size of the variable chunk. Approximate because size does not include headers but GrowHeapSize2 does. }
  1522. and (size <= HeapInc.MaxVarHeaderAndPayload - HeapInc.VarHeaderSize) then
  1523. result := ts^.AllocVar(size, false)
  1524. else
  1525. result := ts^.AllocHuge(size);
  1526. end;
  1527. function SysFreeMem(p: pointer): ptruint;
  1528. var
  1529. ts: HeapInc.pThreadState;
  1530. begin
  1531. if Assigned(p) then
  1532. begin
  1533. ts := @HeapInc.thisTs;
  1534. if HeapInc.pCommonHeader(p - HeapInc.CommonHeaderSize)^.h and HeapInc.FixedFlag <> 0 then
  1535. result := ts^.FreeFixed(p)
  1536. else if HeapInc.pCommonHeader(p - HeapInc.CommonHeaderSize)^.h <> HeapInc.HugeHeader then
  1537. result := ts^.FreeVar(p)
  1538. else
  1539. result := ts^.FreeHuge(p);
  1540. end
  1541. else
  1542. result := 0;
  1543. end;
  1544. function SysTryResizeMem(var p: pointer; size: ptruint): boolean;
  1545. var
  1546. ts: HeapInc.pThreadState;
  1547. h: uint32;
  1548. newp: pointer;
  1549. begin
  1550. h := HeapInc.pCommonHeader(p - HeapInc.CommonHeaderSize)^.h;
  1551. if h and HeapInc.FixedFlag <> 0 then
  1552. result := (size <= HeapInc.MaxFixedHeaderAndPayload - HeapInc.CommonHeaderSize) and (h and HeapInc.SizeIndexMask = HeapInc.SizeMinus1ToIndex(size + (HeapInc.CommonHeaderSize - 1)))
  1553. else
  1554. begin
  1555. ts := @HeapInc.thisTs;
  1556. {$ifdef FPC_HAS_FEATURE_THREADING}
  1557. if Assigned(ts^.toFree) then
  1558. ts^.FlushToFree;
  1559. {$endif FPC_HAS_FEATURE_THREADING}
  1560. if h <> HeapInc.HugeHeader then
  1561. newp := ts^.TryResizeVar(p, size)
  1562. else
  1563. newp := ts^.TryResizeHuge(p, size);
  1564. result := Assigned(newp);
  1565. if result then
  1566. p := newp;
  1567. end;
  1568. end;
  1569. function SysMemSize(p: pointer): ptruint;
  1570. var
  1571. h: uint32;
  1572. begin
  1573. if not Assigned(p) then
  1574. exit(0);
  1575. h := HeapInc.pCommonHeader(p - HeapInc.CommonHeaderSize)^.h;
  1576. if h and HeapInc.FixedFlag <> 0 then
  1577. result := HeapInc.IndexToSize(h and HeapInc.SizeIndexMask) - HeapInc.CommonHeaderSize
  1578. else if h <> HeapInc.HugeHeader then
  1579. result := HeapInc.pVarHeader(p - HeapInc.VarHeaderSize)^.ch.h and uint32(HeapInc.VarSizeMask) - HeapInc.VarHeaderSize
  1580. else
  1581. result := HeapInc.pHugeChunk(p - (HeapInc.HugeChunkDataOffset + HeapInc.CommonHeaderSize))^.size - (HeapInc.HugeChunkDataOffset + HeapInc.CommonHeaderSize);
  1582. end;
  1583. function SysReAllocMem(var p: pointer; size: ptruint):pointer;
  1584. var
  1585. oldsize, newsize, tocopy: SizeUint;
  1586. begin
  1587. if size = 0 then
  1588. begin
  1589. SysFreeMem(p);
  1590. result := nil;
  1591. p := nil;
  1592. end
  1593. else if not Assigned(p) then
  1594. begin
  1595. result := SysGetMem(size);
  1596. p := result;
  1597. end
  1598. else if SysTryResizeMem(p, size) then
  1599. result := p
  1600. else
  1601. begin
  1602. oldsize := SysMemSize(p);
  1603. newsize := size;
  1604. result := SysGetMem(newsize);
  1605. if not Assigned(result) then
  1606. begin
  1607. if size <= oldsize then
  1608. { Don’t fail if shrinking. }
  1609. result := p;
  1610. exit; { If growing failed, return nil, but keep the old p. }
  1611. end;
  1612. tocopy := oldsize;
  1613. if tocopy > newsize then
  1614. tocopy := newsize;
  1615. Move(p^, result^, tocopy);
  1616. SysFreeMem(p);
  1617. p := result;
  1618. end;
  1619. end;
  1620. Function SysFreeMemSize(p: pointer; size: ptruint):ptruint;
  1621. begin
  1622. { can't free partial blocks, ignore size }
  1623. result := SysFreeMem(p);
  1624. end;
  1625. function SysAllocMem(size: ptruint): pointer;
  1626. begin
  1627. result := SysGetMem(size);
  1628. if Assigned(result) then
  1629. FillChar(result^, SysMemSize(result), 0);
  1630. end;
  1631. {*****************************************************************************
  1632. InitHeap
  1633. *****************************************************************************}
  1634. { This function will initialize the Heap manager and need to be called from
  1635. the initialization of the system unit }
  1636. {$ifdef FPC_HAS_FEATURE_THREADING}
  1637. procedure InitHeapThread;
  1638. begin
  1639. if HeapInc.gs.lockUse>0 then
  1640. InterlockedIncrement(HeapInc.gs.lockUse);
  1641. end;
  1642. {$endif}
  1643. procedure InitHeap; public name '_FPC_InitHeap';
  1644. begin
  1645. { we cannot initialize the locks here yet, thread support is
  1646. not loaded yet }
  1647. end;
  1648. procedure RelocateHeap;
  1649. begin
  1650. {$ifdef FPC_HAS_FEATURE_THREADING}
  1651. if HeapInc.gs.lockUse > 0 then
  1652. exit;
  1653. HeapInc.gs.lockUse := 1;
  1654. InitCriticalSection(HeapInc.gs.lock);
  1655. {$ifndef FPC_SECTION_THREADVARS}
  1656. { threadState pointers still point to main thread's thisTs, but they
  1657. have a reference to the global main thisTs, fix them to point
  1658. to the main thread specific variable.
  1659. even if section threadvars are used, this shouldn't cause problems as threadState pointers simply
  1660. do not change but we do not need it }
  1661. HeapInc.thisTs.FixupSelfPtr;
  1662. {$endif FPC_SECTION_THREADVARS}
  1663. if MemoryManager.RelocateHeap <> nil then
  1664. MemoryManager.RelocateHeap();
  1665. {$endif FPC_HAS_FEATURE_THREADING}
  1666. end;
  1667. procedure FinalizeHeap;
  1668. begin
  1669. { Do not try to do anything if the heap manager already reported an error }
  1670. if (errorcode=203) or (errorcode=204) then
  1671. exit;
  1672. {$if defined(FPC_HAS_FEATURE_THREADING)}
  1673. HeapInc.thisTs.Orphan;
  1674. if (HeapInc.gs.lockUse > 0) and (InterlockedDecrement(HeapInc.gs.lockUse) = 0) then
  1675. DoneCriticalSection(HeapInc.gs.lock);
  1676. {$elseif defined(HAS_SYSOSFREE)}
  1677. if Assigned(HeapInc.thisTs.freeOS1) then
  1678. begin
  1679. dec(HeapInc.thisTs.allocated, HeapInc.thisTs.freeOS1^.size); { Just in case... }
  1680. SysOSFree(HeapInc.thisTs.freeOS1, HeapInc.thisTs.freeOS1^.size);
  1681. HeapInc.thisTs.freeOS1 := nil; { Just in case... }
  1682. end;
  1683. {$endif FPC_HAS_FEATURE_THREADING | defined(HAS_SYSOSFREE)}
  1684. end;
  1685. {$endif ndef HAS_MEMORYMANAGER}
  1686. {$endif FPC_HAS_FEATURE_HEAP}