← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to rtl/inc/heap.inc

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/inc/heap.inc
1
 
{
2
 
    $Id: heap.inc,v 1.29 2004/04/26 16:20:54 peter Exp $
3
 
    This file is part of the Free Pascal run time library.
4
 
    Copyright (c) 1999-2000 by the Free Pascal development team.
5
 
 
6
 
    functions for heap management in the data segment
7
 
 
8
 
    See the file COPYING.FPC, included in this distribution,
9
 
    for details about the copyright.
10
 
 
11
 
    This program is distributed in the hope that it will be useful,
12
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
13
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
 
 
15
 
 **********************************************************************}
16
 
 
17
 
{****************************************************************************}
18
 
 
19
 
{ Reuse bigger blocks instead of allocating a new block at freelist/heapptr.
20
 
  the tried bigger blocks are always multiple sizes of the current block }
21
 
{$define REUSEBIGGER}
22
 
 
23
 
{ Allocate small blocks at heapptr instead of walking the freelist }
24
 
{ define SMALLATHEAPPTR}
25
 
 
26
 
{ Try to find the best matching block in general freelist }
27
 
{ define BESTMATCH}
28
 
 
29
 
{ Concat free blocks when placing big blocks in the mainlist }
30
 
{$define CONCATFREE}
31
 
 
32
 
{ DEBUG: Dump info when the heap needs to grow }
33
 
{ define DUMPGROW}
34
 
 
35
 
{ DEBUG: Test the FreeList on correctness }
36
 
{$ifdef SYSTEMDEBUG}
37
 
{$define TestFreeLists}
38
 
{$endif SYSTEMDEBUG}
39
 
 
40
 
const
41
 
{$ifdef CPU64}
42
 
  blocksize    = 32;  { at least size of freerecord }
43
 
  blockshr     = 5;   { shr value for blocksize=2^blockshr}
44
 
  maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
45
 
{$else}
46
 
  blocksize    = 16;  { at least size of freerecord }
47
 
  blockshr     = 4;   { shr value for blocksize=2^blockshr}
48
 
  maxblocksize = 512+blocksize; { 1024+8 needed for heaprecord }
49
 
{$endif}
50
 
  maxblock     = maxblocksize div blocksize;
51
 
  maxreusebigger = 8; { max reuse bigger tries }
52
 
 
53
 
  usedmask = 1;            { flag if the block is used or not }
54
 
  beforeheapendmask = 2;   { flag if the block is just before a heapptr }
55
 
  sizemask = not(blocksize-1);
56
 
 
57
 
{****************************************************************************}
58
 
 
59
 
{$ifdef DUMPGROW}
60
 
  {$define DUMPBLOCKS}
61
 
{$endif}
62
 
 
63
 
{ Forward defines }
64
 
procedure SysHeapMutexInit;forward;
65
 
procedure SysHeapMutexDone;forward;
66
 
procedure SysHeapMutexLock;forward;
67
 
procedure SysHeapMutexUnlock;forward;
68
 
 
69
 
{ Memory manager }
70
 
const
71
 
  MemoryManager: TMemoryManager = (
72
 
    NeedLock: true;
73
 
    GetMem: @SysGetMem;
74
 
    FreeMem: @SysFreeMem;
75
 
    FreeMemSize: @SysFreeMemSize;
76
 
    AllocMem: @SysAllocMem;
77
 
    ReAllocMem: @SysReAllocMem;
78
 
    MemSize: @SysMemSize;
79
 
    MemAvail: @SysMemAvail;
80
 
    MaxAvail: @SysMaxAvail;
81
 
    HeapSize: @SysHeapSize;
82
 
  );
83
 
 
84
 
  MemoryMutexManager: TMemoryMutexManager = (
85
 
    MutexInit: @SysHeapMutexInit;
86
 
    MutexDone: @SysHeapMutexDone;
87
 
    MutexLock: @SysHeapMutexLock;
88
 
    MutexUnlock: @SysHeapMutexUnlock;
89
 
  );
90
 
 
91
 
type
92
 
  ppfreerecord = ^pfreerecord;
93
 
  pfreerecord  = ^tfreerecord;
94
 
  tfreerecord  = record
95
 
    size  : ptrint;
96
 
    next,
97
 
    prev  : pfreerecord;
98
 
  end; { 12/24 bytes }
99
 
 
100
 
  pheaprecord = ^theaprecord;
101
 
  theaprecord = record
102
 
  { this should overlap with tfreerecord }
103
 
    size  : ptrint;
104
 
  end; { 4/8 bytes }
105
 
 
106
 
  tfreelists   = array[0..maxblock] of pfreerecord;
107
 
{$ifdef SYSTEMDEBUG}
108
 
  tfreecount   = array[0..maxblock] of dword;
109
 
{$endif SYSTEMDEBUG}
110
 
  pfreelists   = ^tfreelists;
111
 
 
112
 
var
113
 
  internal_memavail  : ptrint;
114
 
  internal_heapsize  : ptrint;
115
 
  freelists          : tfreelists;
116
 
  before_heapend_block : pfreerecord;
117
 
{$ifdef SYSTEMDEBUG}
118
 
  freecount : tfreecount;
119
 
{$endif SYSTEMDEBUG}
120
 
{$ifdef TestFreeLists}
121
 
{ this can be turned on by debugger }
122
 
const
123
 
  test_each : boolean = false;
124
 
{$endif TestFreeLists}
125
 
 
126
 
{*****************************************************************************
127
 
                             Memory Manager
128
 
*****************************************************************************}
129
 
 
130
 
procedure SetMemoryMutexManager(var MutexMgr: TMemoryMutexManager);
131
 
begin
132
 
  { Release old mutexmanager, the default manager does nothing so
133
 
    calling this without initializing is safe }
134
 
  MemoryMutexManager.MutexDone;
135
 
  { Copy new mutexmanager }
136
 
  MemoryMutexManager:=MutexMgr;
137
 
  { Init new mutexmanager }
138
 
  MemoryMutexManager.MutexInit;
139
 
end;
140
 
 
141
 
 
142
 
procedure GetMemoryManager(var MemMgr:TMemoryManager);
143
 
begin
144
 
  if IsMultiThread and MemoryManager.NeedLock then
145
 
   begin
146
 
     try
147
 
       MemoryMutexManager.MutexLock;
148
 
       MemMgr:=MemoryManager;
149
 
     finally
150
 
       MemoryMutexManager.MutexUnlock;
151
 
     end;
152
 
   end
153
 
  else
154
 
   begin
155
 
     MemMgr:=MemoryManager;
156
 
   end;
157
 
end;
158
 
 
159
 
 
160
 
procedure SetMemoryManager(const MemMgr:TMemoryManager);
161
 
begin
162
 
  if IsMultiThread and MemoryManager.NeedLock then
163
 
   begin
164
 
     try
165
 
       MemoryMutexManager.MutexLock;
166
 
       MemoryManager:=MemMgr;
167
 
     finally
168
 
       MemoryMutexManager.MutexUnlock;
169
 
     end;
170
 
   end
171
 
  else
172
 
   begin
173
 
     MemoryManager:=MemMgr;
174
 
   end;
175
 
end;
176
 
 
177
 
 
178
 
function IsMemoryManagerSet:Boolean;
179
 
begin
180
 
  if IsMultiThread and MemoryManager.NeedLock then
181
 
   begin
182
 
     try
183
 
       MemoryMutexManager.MutexLock;
184
 
       IsMemoryManagerSet:=(MemoryManager.GetMem<>@SysGetMem) or
185
 
                           (MemoryManager.FreeMem<>@SysFreeMem);
186
 
     finally
187
 
       MemoryMutexManager.MutexUnlock;
188
 
     end;
189
 
   end
190
 
  else
191
 
   begin
192
 
     IsMemoryManagerSet:=(MemoryManager.GetMem<>@SysGetMem) or
193
 
                         (MemoryManager.FreeMem<>@SysFreeMem);
194
 
   end;
195
 
end;
196
 
 
197
 
 
198
 
procedure GetMem(Var p:pointer;Size:ptrint);
199
 
begin
200
 
  if IsMultiThread and MemoryManager.NeedLock then
201
 
   begin
202
 
     try
203
 
       MemoryMutexManager.MutexLock;
204
 
       p:=MemoryManager.GetMem(Size);
205
 
     finally
206
 
       MemoryMutexManager.MutexUnlock;
207
 
     end;
208
 
   end
209
 
  else
210
 
   begin
211
 
     p:=MemoryManager.GetMem(Size);
212
 
   end;
213
 
end;
214
 
 
215
 
procedure GetMemory(Var p:pointer;Size:ptrint);
216
 
begin
217
 
  GetMem(p,size);
218
 
end;
219
 
 
220
 
procedure FreeMem(p:pointer;Size:ptrint);
221
 
begin
222
 
  if IsMultiThread and MemoryManager.NeedLock then
223
 
   begin
224
 
     try
225
 
       MemoryMutexManager.MutexLock;
226
 
       MemoryManager.FreeMemSize(p,Size);
227
 
     finally
228
 
       MemoryMutexManager.MutexUnlock;
229
 
     end;
230
 
   end
231
 
  else
232
 
   begin
233
 
     MemoryManager.FreeMemSize(p,Size);
234
 
   end;
235
 
end;
236
 
 
237
 
procedure FreeMemory(p:pointer;Size:ptrint);
238
 
begin
239
 
  FreeMem(p,size);
240
 
end;
241
 
 
242
 
function MaxAvail:ptrint;
243
 
begin
244
 
  if IsMultiThread and MemoryManager.NeedLock then
245
 
   begin
246
 
     try
247
 
       MemoryMutexManager.MutexLock;
248
 
       MaxAvail:=MemoryManager.MaxAvail();
249
 
     finally
250
 
       MemoryMutexManager.MutexUnlock;
251
 
     end;
252
 
   end
253
 
  else
254
 
   begin
255
 
     MaxAvail:=MemoryManager.MaxAvail();
256
 
   end;
257
 
end;
258
 
 
259
 
 
260
 
function MemAvail:ptrint;
261
 
begin
262
 
  if IsMultiThread and MemoryManager.NeedLock then
263
 
   begin
264
 
     try
265
 
       MemoryMutexManager.MutexLock;
266
 
       MemAvail:=MemoryManager.MemAvail();
267
 
     finally
268
 
       MemoryMutexManager.MutexUnlock;
269
 
     end;
270
 
   end
271
 
  else
272
 
   begin
273
 
     MemAvail:=MemoryManager.MemAvail();
274
 
   end;
275
 
end;
276
 
 
277
 
 
278
 
{ FPC Additions }
279
 
function HeapSize:ptrint;
280
 
begin
281
 
  if IsMultiThread and MemoryManager.NeedLock then
282
 
   begin
283
 
     try
284
 
       MemoryMutexManager.MutexLock;
285
 
       HeapSize:=MemoryManager.HeapSize();
286
 
     finally
287
 
       MemoryMutexManager.MutexUnlock;
288
 
     end;
289
 
   end
290
 
  else
291
 
   begin
292
 
     HeapSize:=MemoryManager.HeapSize();
293
 
   end;
294
 
end;
295
 
 
296
 
 
297
 
function MemSize(p:pointer):ptrint;
298
 
begin
299
 
  if IsMultiThread and MemoryManager.NeedLock then
300
 
   begin
301
 
     try
302
 
       MemoryMutexManager.MutexLock;
303
 
       MemSize:=MemoryManager.MemSize(p);
304
 
     finally
305
 
       MemoryMutexManager.MutexUnlock;
306
 
     end;
307
 
   end
308
 
  else
309
 
   begin
310
 
     MemSize:=MemoryManager.MemSize(p);
311
 
   end;
312
 
end;
313
 
 
314
 
 
315
 
{ Delphi style }
316
 
function FreeMem(p:pointer):ptrint;
317
 
begin
318
 
  if IsMultiThread and MemoryManager.NeedLock then
319
 
   begin
320
 
     try
321
 
       MemoryMutexManager.MutexLock;
322
 
       Freemem:=MemoryManager.FreeMem(p);
323
 
     finally
324
 
       MemoryMutexManager.MutexUnlock;
325
 
     end;
326
 
   end
327
 
  else
328
 
   begin
329
 
     Freemem:=MemoryManager.FreeMem(p);
330
 
   end;
331
 
end;
332
 
 
333
 
function FreeMemory(p:pointer):ptrint;
334
 
 
335
 
begin
336
 
 FreeMemory:=FreeMem(p);
337
 
end;
338
 
 
339
 
function GetMem(size:ptrint):pointer;
340
 
begin
341
 
  if IsMultiThread and MemoryManager.NeedLock then
342
 
   begin
343
 
     try
344
 
       MemoryMutexManager.MutexLock;
345
 
       GetMem:=MemoryManager.GetMem(Size);
346
 
     finally
347
 
       MemoryMutexManager.MutexUnlock;
348
 
     end;
349
 
   end
350
 
  else
351
 
   begin
352
 
     GetMem:=MemoryManager.GetMem(Size);
353
 
   end;
354
 
end;
355
 
 
356
 
function GetMemory(size:ptrint):pointer;
357
 
 
358
 
begin
359
 
 GetMemory:=Getmem(size);
360
 
end;
361
 
 
362
 
function AllocMem(Size:ptrint):pointer;
363
 
begin
364
 
  if IsMultiThread and MemoryManager.NeedLock then
365
 
   begin
366
 
     try
367
 
       MemoryMutexManager.MutexLock;
368
 
       AllocMem:=MemoryManager.AllocMem(size);
369
 
     finally
370
 
       MemoryMutexManager.MutexUnlock;
371
 
     end;
372
 
   end
373
 
  else
374
 
   begin
375
 
     AllocMem:=MemoryManager.AllocMem(size);
376
 
   end;
377
 
end;
378
 
 
379
 
 
380
 
function ReAllocMem(var p:pointer;Size:ptrint):pointer;
381
 
begin
382
 
  if IsMultiThread and MemoryManager.NeedLock then
383
 
   begin
384
 
     try
385
 
       MemoryMutexManager.MutexLock;
386
 
       ReAllocMem:=MemoryManager.ReAllocMem(p,size);
387
 
     finally
388
 
       MemoryMutexManager.MutexUnlock;
389
 
     end;
390
 
   end
391
 
  else
392
 
   begin
393
 
     ReAllocMem:=MemoryManager.ReAllocMem(p,size);
394
 
   end;
395
 
end;
396
 
 
397
 
 
398
 
function ReAllocMemory(var p:pointer;Size:ptrint):pointer;
399
 
 
400
 
begin
401
 
 ReAllocMemory:=ReAllocMem(p,size);
402
 
end;
403
 
 
404
 
{$ifdef ValueGetmem}
405
 
 
406
 
{ Needed for calls from Assembler }
407
 
function fpc_getmem(size:ptrint):pointer;compilerproc;[public,alias:'FPC_GETMEM'];
408
 
begin
409
 
  if IsMultiThread and MemoryManager.NeedLock then
410
 
   begin
411
 
     try
412
 
       MemoryMutexManager.MutexLock;
413
 
       fpc_GetMem:=MemoryManager.GetMem(size);
414
 
     finally
415
 
       MemoryMutexManager.MutexUnlock;
416
 
     end;
417
 
   end
418
 
  else
419
 
   begin
420
 
     fpc_GetMem:=MemoryManager.GetMem(size);
421
 
   end;
422
 
end;
423
 
 
424
 
{$else ValueGetmem}
425
 
 
426
 
{ Needed for calls from Assembler }
427
 
procedure AsmGetMem(var p:pointer;size:ptrint);[public,alias:'FPC_GETMEM'];
428
 
begin
429
 
  p:=MemoryManager.GetMem(size);
430
 
end;
431
 
 
432
 
{$endif ValueGetmem}
433
 
 
434
 
{$ifdef ValueFreemem}
435
 
 
436
 
procedure fpc_freemem(p:pointer);compilerproc;[public,alias:'FPC_FREEMEM'];
437
 
begin
438
 
  if IsMultiThread and MemoryManager.NeedLock then
439
 
   begin
440
 
     try
441
 
       MemoryMutexManager.MutexLock;
442
 
       if p <> nil then
443
 
         MemoryManager.FreeMem(p);
444
 
     finally
445
 
       MemoryMutexManager.MutexUnlock;
446
 
     end;
447
 
   end
448
 
  else
449
 
   begin
450
 
     if p <> nil then
451
 
       MemoryManager.FreeMem(p);
452
 
   end;
453
 
end;
454
 
 
455
 
{$else ValueFreemem}
456
 
 
457
 
procedure AsmFreeMem(var p:pointer);[public,alias:'FPC_FREEMEM'];
458
 
begin
459
 
  if p <> nil then
460
 
    MemoryManager.FreeMem(p);
461
 
end;
462
 
 
463
 
{$endif ValueFreemem}
464
 
 
465
 
 
466
 
{*****************************************************************************
467
 
                         Heapsize,Memavail,MaxAvail
468
 
*****************************************************************************}
469
 
 
470
 
function SysHeapsize : ptrint;
471
 
begin
472
 
  Sysheapsize:=internal_heapsize;
473
 
end;
474
 
 
475
 
 
476
 
function SysMemavail : ptrint;
477
 
begin
478
 
  Sysmemavail:=internal_memavail;
479
 
end;
480
 
 
481
 
 
482
 
function SysMaxavail : ptrint;
483
 
var
484
 
  hp : pfreerecord;
485
 
begin
486
 
  Sysmaxavail:=heapend-heapptr;
487
 
  hp:=freelists[0];
488
 
  while assigned(hp) do
489
 
   begin
490
 
     if hp^.size>Sysmaxavail then
491
 
       Sysmaxavail:=hp^.size;
492
 
     hp:=hp^.next;
493
 
   end;
494
 
end;
495
 
 
496
 
 
497
 
{$ifdef DUMPBLOCKS}
498
 
procedure DumpBlocks;
499
 
var
500
 
  s,i,j : ptrint;
501
 
  hp  : pfreerecord;
502
 
begin
503
 
  for i:=1 to maxblock do
504
 
   begin
505
 
     hp:=freelists[i];
506
 
     j:=0;
507
 
     while assigned(hp) do
508
 
      begin
509
 
        inc(j);
510
 
        hp:=hp^.next;
511
 
      end;
512
 
     writeln('Block ',i*blocksize,': ',j);
513
 
   end;
514
 
{ freelist 0 }
515
 
  hp:=freelists[0];
516
 
  j:=0;
517
 
  s:=0;
518
 
  while assigned(hp) do
519
 
   begin
520
 
     inc(j);
521
 
     if hp^.size>s then
522
 
      s:=hp^.size;
523
 
     hp:=hp^.next;
524
 
   end;
525
 
  writeln('Main: ',j,' maxsize: ',s);
526
 
end;
527
 
{$endif}
528
 
 
529
 
 
530
 
{$ifdef TestFreeLists}
531
 
procedure TestFreeLists;
532
 
var
533
 
  i,j : ptrint;
534
 
  hp  : pfreerecord;
535
 
begin
536
 
  for i:=0 to maxblock do
537
 
   begin
538
 
     j:=0;
539
 
     hp:=freelists[i];
540
 
     while assigned(hp) do
541
 
      begin
542
 
        inc(j);
543
 
        if (i>0) and ((hp^.size and sizemask) <> i * blocksize) then
544
 
          RunError(204);
545
 
        hp:=hp^.next;
546
 
      end;
547
 
      if j<>freecount[i] then
548
 
        RunError(204);
549
 
    end;
550
 
end;
551
 
{$endif TestFreeLists}
552
 
 
553
 
 
554
 
{$ifdef CONCATFREE}
555
 
{*****************************************************************************
556
 
                         Try concat freerecords
557
 
*****************************************************************************}
558
 
 
559
 
procedure TryConcatFreeRecord(pcurr:pfreerecord);
560
 
var
561
 
  hp : pfreerecord;
562
 
  pcurrsize,s1 : ptrint;
563
 
begin
564
 
  pcurrsize:=pcurr^.size and sizemask;
565
 
  hp:=pcurr;
566
 
  repeat
567
 
    { block used or before a heapend ? }
568
 
    if (hp^.size and beforeheapendmask)<>0 then
569
 
     begin
570
 
       { Peter, why can't we add this one if free ?? }
571
 
       { It's already added in the previous iteration, we only go to the }
572
 
       { next heap record after this check (JM)                          }
573
 
       pcurr^.size:=pcurrsize or beforeheapendmask;
574
 
       { keep track of the block that lies before the current heapend }
575
 
       if (pointer(pcurr)+pcurrsize+sizeof(tfreerecord) >= heapend) then
576
 
         before_heapend_block := pcurr;
577
 
       break;
578
 
     end;
579
 
    { the size of this block can never be 0. when it is 0 we'll get in
580
 
      an infinite loop, so we throw a RTE instead (PFV) }
581
 
    if (hp^.size and sizemask)=0 then
582
 
      HandleError(204);
583
 
    { get next block }
584
 
    hp:=pfreerecord(pointer(hp)+(hp^.size and sizemask));
585
 
    { when we're at heapptr then we can stop and set heapptr to pcurr }
586
 
    if (hp=heapptr) then
587
 
     begin
588
 
       heapptr:=pcurr;
589
 
       { remove the block }
590
 
       if assigned(pcurr^.next) then
591
 
         pcurr^.next^.prev := pcurr^.prev;
592
 
       if assigned(pcurr^.prev) then
593
 
         pcurr^.prev^.next := pcurr^.next
594
 
       else
595
 
         freelists[0] := pcurr^.next;
596
 
{$ifdef SYSTEMDEBUG}
597
 
       dec(freecount[0]);
598
 
{$endif SYSTEMDEBUG}
599
 
       break;
600
 
     end;
601
 
    { block is used? then we stop and add the block to the freelist }
602
 
    if (hp^.size and usedmask)<>0 then
603
 
     begin
604
 
       pcurr^.size:=pcurrsize;
605
 
       break;
606
 
     end;
607
 
    { remove block from freelist and increase the size }
608
 
    s1:=hp^.size and sizemask;
609
 
    inc(pcurrsize,s1);
610
 
    s1:=s1 shr blockshr;
611
 
    if s1>maxblock then
612
 
     s1:=0;
613
 
    if assigned(hp^.next) then
614
 
     hp^.next^.prev:=hp^.prev;
615
 
    if assigned(hp^.prev) then
616
 
     hp^.prev^.next:=hp^.next
617
 
    else
618
 
     freelists[s1]:=hp^.next;
619
 
{$ifdef SYSTEMDEBUG}
620
 
    dec(freecount[s1]);
621
 
{$endif SYSTEMDEBUG}
622
 
  until false;
623
 
end;
624
 
{$endif CONCATFREE}
625
 
 
626
 
{*****************************************************************************
627
 
                                 SysGetMem
628
 
*****************************************************************************}
629
 
 
630
 
function SysGetMem(size : ptrint):pointer;
631
 
type
632
 
  heaperrorproc=function(size:ptrint):integer;
633
 
var
634
 
  proc  : heaperrorproc;
635
 
  pcurr : pfreerecord;
636
 
  s,s1,maxs1,
637
 
  sizeleft : ptrint;
638
 
  again : boolean;
639
 
{$ifdef BESTMATCH}
640
 
  pbest : pfreerecord;
641
 
{$endif}
642
 
begin
643
 
{ Something to allocate ? }
644
 
  if size<=0 then
645
 
   begin
646
 
     { give an error for < 0 }
647
 
     if size<0 then
648
 
      HandleError(204);
649
 
     { we always need to allocate something, using heapend is not possible,
650
 
       because heappend can be changed by growheap (PFV) }
651
 
     size:=1;
652
 
   end;
653
 
{ calc to multiply of 16 after adding the needed 8 bytes heaprecord }
654
 
  size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1));
655
 
  dec(internal_memavail,size);
656
 
{ try to find a block in one of the freelists per size }
657
 
  s:=size shr blockshr;
658
 
  if s<=maxblock then
659
 
   begin
660
 
     pcurr:=freelists[s];
661
 
     { correct size match ? }
662
 
     if assigned(pcurr) then
663
 
      begin
664
 
        { create the block we should return }
665
 
        sysgetmem:=pointer(pcurr)+sizeof(theaprecord);
666
 
        { fix size }
667
 
        pcurr^.size:=pcurr^.size or usedmask;
668
 
        { update freelist }
669
 
        freelists[s]:=pcurr^.next;
670
 
{$ifdef SYSTEMDEBUG}
671
 
        dec(freecount[s]);
672
 
{$endif SYSTEMDEBUG}
673
 
        if assigned(freelists[s]) then
674
 
         freelists[s]^.prev:=nil;
675
 
{$ifdef TestFreeLists}
676
 
        if test_each then
677
 
         TestFreeLists;
678
 
{$endif TestFreeLists}
679
 
        exit;
680
 
      end;
681
 
{$ifdef SMALLATHEAPPTR}
682
 
     if heapend-heapptr>=size then
683
 
      begin
684
 
        sysgetmem:=heapptr;
685
 
        { set end flag if we do not have enough room to add
686
 
          another tfreerecord behind }
687
 
        if (heapptr+size+sizeof(tfreerecord)>=heapend) then
688
 
         begin
689
 
           pheaprecord(sysgetmem)^.size:=size or (usedmask or beforeheapendmask)
690
 
           { keep track of the block that lies before the current heapend }
691
 
           before_heapend_block := sysgetmem;
692
 
         end  
693
 
        else
694
 
         pheaprecord(sysgetmem)^.size:=size or usedmask;
695
 
        inc(sysgetmem,sizeof(theaprecord));
696
 
        inc(heapptr,size);
697
 
{$ifdef TestFreeLists}
698
 
        if test_each then
699
 
         TestFreeLists;
700
 
{$endif TestFreeLists}
701
 
        exit;
702
 
      end;
703
 
{$endif}
704
 
{$ifdef REUSEBIGGER}
705
 
     { try a bigger block }
706
 
     s1:=s+s;
707
 
     maxs1:=s1+maxreusebigger;
708
 
     if maxblock<maxs1 then
709
 
       maxs1:=maxblock;
710
 
     while s1<=maxs1 do
711
 
       begin
712
 
         if freelists[s1]<>nil then
713
 
           begin
714
 
             s:=s1;
715
 
             pcurr:=freelists[s1];
716
 
             break;
717
 
           end;
718
 
         inc(s1);
719
 
       end;
720
 
     pcurr:=nil;
721
 
{$endif}
722
 
   end
723
 
  else
724
 
   pcurr:=nil;
725
 
{ not found, then check the main freelist for the first match }
726
 
  if not(assigned(pcurr)) then
727
 
   begin
728
 
     s:=0;
729
 
{$ifdef BESTMATCH}
730
 
     pbest:=nil;
731
 
{$endif}
732
 
     pcurr:=freelists[0];
733
 
     while assigned(pcurr) do
734
 
      begin
735
 
{$ifdef BESTMATCH}
736
 
        if pcurr^.size=size then
737
 
         break
738
 
        else
739
 
         begin
740
 
           if (pcurr^.size>size) then
741
 
            begin
742
 
              if (not assigned(pbest)) or
743
 
                 (pcurr^.size<pbest^.size) then
744
 
               pbest:=pcurr;
745
 
            end
746
 
         end;
747
 
{$else BESTMATCH}
748
 
{$ifdef CONCATFREE}
749
 
        TryConcatFreeRecord(pcurr);
750
 
        if (pcurr <> heapptr) then
751
 
          begin
752
 
            if pcurr^.size>=size then
753
 
              break;
754
 
          end
755
 
        else
756
 
          begin
757
 
            pcurr := nil;
758
 
            break;
759
 
          end;
760
 
{$else CONCATFREE}
761
 
        if pcurr^.size>=size then
762
 
          break;
763
 
{$endif CONCATFREE}
764
 
{$endif BESTMATCH}
765
 
        pcurr:=pcurr^.next;
766
 
      end;
767
 
{$ifdef BESTMATCH}
768
 
     if not assigned(pcurr) then
769
 
      pcurr:=pbest;
770
 
{$endif}
771
 
   end;
772
 
  { have we found a block, then get it and free up the other left part,
773
 
    if no blocks are found then allocated at the heapptr or grow the heap }
774
 
  if assigned(pcurr) then
775
 
   begin
776
 
     { get pointer of the block we should return }
777
 
     sysgetmem:=pointer(pcurr);
778
 
     { remove the current block from the freelist }
779
 
     if assigned(pcurr^.next) then
780
 
      pcurr^.next^.prev:=pcurr^.prev;
781
 
     if assigned(pcurr^.prev) then
782
 
      pcurr^.prev^.next:=pcurr^.next
783
 
     else
784
 
      freelists[s]:=pcurr^.next;
785
 
{$ifdef SYSTEMDEBUG}
786
 
     dec(freecount[s]);
787
 
{$endif SYSTEMDEBUG}
788
 
     { create the left over freelist block, if at least 16 bytes are free }
789
 
     sizeleft:=pcurr^.size-size;
790
 
     if sizeleft>=sizeof(tfreerecord) then
791
 
      begin
792
 
        pcurr:=pfreerecord(pointer(pcurr)+size);
793
 
        { inherit the beforeheapendmask }
794
 
        pcurr^.size:=sizeleft or (pheaprecord(sysgetmem)^.size and beforeheapendmask);
795
 
        { the block we return does not lie before any heapend anymore (there's now }
796
 
        { a block after it)                                                        }
797
 
        pheaprecord(sysgetmem)^.size := pheaprecord(sysgetmem)^.size and not(beforeheapendmask);
798
 
        { keep track of the block that lies before the current heapend }
799
 
        if (pointer(pcurr)+(pcurr^.size and sizemask)+sizeof(tfreerecord) >= heapend) then
800
 
          before_heapend_block := pcurr;
801
 
        { insert the block in the freelist }
802
 
        pcurr^.prev:=nil;
803
 
        s1:=sizeleft shr blockshr;
804
 
        if s1>maxblock then
805
 
         s1:=0;
806
 
        pcurr^.next:=freelists[s1];
807
 
        if assigned(freelists[s1]) then
808
 
         freelists[s1]^.prev:=pcurr;
809
 
        freelists[s1]:=pcurr;
810
 
{$ifdef SYSTEMDEBUG}
811
 
        inc(freecount[s1]);
812
 
{$endif SYSTEMDEBUG}
813
 
        { create the block we need to return }
814
 
        pheaprecord(sysgetmem)^.size:=size or usedmask;
815
 
      end
816
 
     else
817
 
      begin
818
 
        { create the block we need to return }
819
 
        pheaprecord(sysgetmem)^.size:=size or usedmask or (pheaprecord(sysgetmem)^.size and beforeheapendmask);
820
 
      end;
821
 
 
822
 
     inc(sysgetmem,sizeof(theaprecord));
823
 
{$ifdef TestFreeLists}
824
 
     if test_each then
825
 
      TestFreeLists;
826
 
{$endif TestFreeLists}
827
 
     exit;
828
 
   end;
829
 
  { Lastly, the top of the heap is checked, to see if there is }
830
 
  { still memory available.                                   }
831
 
  repeat
832
 
    again:=false;
833
 
    if heapend-heapptr>=size then
834
 
     begin
835
 
       sysgetmem:=heapptr;
836
 
       if (heapptr+size+sizeof(tfreerecord)>=heapend) then
837
 
        begin
838
 
          pheaprecord(sysgetmem)^.size:=size or (usedmask or beforeheapendmask);
839
 
          { keep track of the block that lies before the current heapend }
840
 
          before_heapend_block := sysgetmem;
841
 
        end
842
 
       else
843
 
        pheaprecord(sysgetmem)^.size:=size or usedmask;
844
 
       inc(sysgetmem,sizeof(theaprecord));
845
 
       inc(heapptr,size);
846
 
{$ifdef TestFreeLists}
847
 
       if test_each then
848
 
        TestFreeLists;
849
 
{$endif TestFreeLists}
850
 
       exit;
851
 
     end;
852
 
    { Call the heaperror proc }
853
 
    if assigned(heaperror) then
854
 
     begin
855
 
       proc:=heaperrorproc(heaperror);
856
 
       case proc(size) of
857
 
        0 : HandleError(203);
858
 
        1 : sysgetmem:=nil;
859
 
        2 : again:=true;
860
 
       end;
861
 
     end
862
 
    else
863
 
     HandleError(203);
864
 
  until not again;
865
 
{$ifdef TestFreeLists}
866
 
  if test_each then
867
 
    TestFreeLists;
868
 
{$endif TestFreeLists}
869
 
end;
870
 
 
871
 
 
872
 
{*****************************************************************************
873
 
                               SysFreeMem
874
 
*****************************************************************************}
875
 
 
876
 
Function SysFreeMem(p : pointer):ptrint;
877
 
var
878
 
  pcurrsize,s : ptrint;
879
 
  pcurr : pfreerecord;
880
 
begin
881
 
  if p=nil then
882
 
   HandleError(204);
883
 
{ fix p to point to the heaprecord }
884
 
  pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord));
885
 
  pcurrsize:=pcurr^.size and sizemask;
886
 
  inc(internal_memavail,pcurrsize);
887
 
{ insert the block in it's freelist }
888
 
  pcurr^.size:=pcurr^.size and (not usedmask);
889
 
  pcurr^.prev:=nil;
890
 
  s:=pcurrsize shr blockshr;
891
 
  if s>maxblock then
892
 
   s:=0;
893
 
  pcurr^.next:=freelists[s];
894
 
  if assigned(pcurr^.next) then
895
 
   pcurr^.next^.prev:=pcurr;
896
 
  freelists[s]:=pcurr;
897
 
{$ifdef SYSTEMDEBUG}
898
 
  inc(freecount[s]);
899
 
{$endif SYSTEMDEBUG}
900
 
  SysFreeMem:=pcurrsize;
901
 
{$ifdef TestFreeLists}
902
 
  if test_each then
903
 
    TestFreeLists;
904
 
{$endif TestFreeLists}
905
 
end;
906
 
 
907
 
 
908
 
{*****************************************************************************
909
 
                              SysFreeMemSize
910
 
*****************************************************************************}
911
 
 
912
 
Function SysFreeMemSize(p : pointer;size : ptrint):ptrint;
913
 
var
914
 
  pcurrsize,s : ptrint;
915
 
  pcurr : pfreerecord;
916
 
begin
917
 
  SysFreeMemSize:=0;
918
 
  if size<=0 then
919
 
   begin
920
 
     if size<0 then
921
 
      HandleError(204);
922
 
     exit;
923
 
   end;
924
 
  if p=nil then
925
 
   HandleError(204);
926
 
{ fix p to point to the heaprecord }
927
 
  pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord));
928
 
  pcurrsize:=pcurr^.size and sizemask;
929
 
  inc(internal_memavail,pcurrsize);
930
 
{ size check }
931
 
  size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1));
932
 
  if size<>pcurrsize then
933
 
   HandleError(204);
934
 
{ insert the block in it's freelist }
935
 
  pcurr^.size:=pcurr^.size and (not usedmask);
936
 
  pcurr^.prev:=nil;
937
 
{ set the return values }
938
 
  s:=pcurrsize shr blockshr;
939
 
  if s>maxblock then
940
 
   s:=0;
941
 
  pcurr^.next:=freelists[s];
942
 
  if assigned(pcurr^.next) then
943
 
   pcurr^.next^.prev:=pcurr;
944
 
  freelists[s]:=pcurr;
945
 
{$ifdef SYSTEMDEBUG}
946
 
  inc(freecount[s]);
947
 
{$endif SYSTEMDEBUG}
948
 
  SysFreeMemSize:=pcurrsize;
949
 
{$ifdef TestFreeLists}
950
 
  if test_each then
951
 
    TestFreeLists;
952
 
{$endif TestFreeLists}
953
 
end;
954
 
 
955
 
 
956
 
{*****************************************************************************
957
 
                                 SysMemSize
958
 
*****************************************************************************}
959
 
 
960
 
function SysMemSize(p:pointer):ptrint;
961
 
begin
962
 
  SysMemSize:=(pheaprecord(pointer(p)-sizeof(theaprecord))^.size and sizemask)-sizeof(theaprecord);
963
 
end;
964
 
 
965
 
 
966
 
{*****************************************************************************
967
 
                                 SysAllocMem
968
 
*****************************************************************************}
969
 
 
970
 
function SysAllocMem(size : ptrint):pointer;
971
 
begin
972
 
  sysallocmem:=MemoryManager.GetMem(size);
973
 
  if sysallocmem<>nil then
974
 
   FillChar(sysallocmem^,size,0);
975
 
end;
976
 
 
977
 
 
978
 
{*****************************************************************************
979
 
                                 SysResizeMem
980
 
*****************************************************************************}
981
 
 
982
 
function SysTryResizeMem(var p:pointer;size : ptrint):boolean;
983
 
var
984
 
  oldsize,
985
 
  currsize,
986
 
  foundsize,
987
 
  sizeleft,
988
 
  s     : ptrint;
989
 
  wasbeforeheapend : boolean;
990
 
  hp,
991
 
  pnew,
992
 
  pcurr : pfreerecord;
993
 
begin
994
 
{ fix needed size }
995
 
  size:=(size+sizeof(theaprecord)+(blocksize-1)) and (not (blocksize-1));
996
 
{ fix p to point to the heaprecord }
997
 
  pcurr:=pfreerecord(pointer(p)-sizeof(theaprecord));
998
 
  currsize:=pcurr^.size and sizemask;
999
 
  oldsize:=currsize;
1000
 
  wasbeforeheapend:=(pcurr^.size and beforeheapendmask)<>0;
1001
 
{ is the allocated block still correct? }
1002
 
  if currsize=size then
1003
 
   begin
1004
 
     SysTryResizeMem:=true;
1005
 
{$ifdef TestFreeLists}
1006
 
     if test_each then
1007
 
      TestFreeLists;
1008
 
{$endif TestFreeLists}
1009
 
     exit;
1010
 
   end;
1011
 
{ do we need to allocate more memory ? }
1012
 
  if size>currsize then
1013
 
   begin
1014
 
   { the size is bigger than the previous size, we need to allocated more mem.
1015
 
     We first check if the blocks after the current block are free. If not we
1016
 
     simply call getmem/freemem to get the new block }
1017
 
     foundsize:=0;
1018
 
     hp:=pcurr;
1019
 
     repeat
1020
 
       inc(foundsize,hp^.size and sizemask);
1021
 
       { block used or before a heapptr ? }
1022
 
       if (hp^.size and beforeheapendmask)<>0 then
1023
 
        begin
1024
 
          wasbeforeheapend:=true;
1025
 
          break;
1026
 
        end;
1027
 
       { get next block }
1028
 
       hp:=pfreerecord(pointer(hp)+(hp^.size and sizemask));
1029
 
       { when we're at heapptr then we can stop }
1030
 
       if (hp=heapptr) then
1031
 
        begin
1032
 
          inc(foundsize,heapend-heapptr);
1033
 
          break;
1034
 
        end;
1035
 
       if (hp^.size and usedmask)<>0 then
1036
 
        break;
1037
 
     until (foundsize>=size);
1038
 
   { found enough free blocks? }
1039
 
     if foundsize>=size then
1040
 
      begin
1041
 
        { we walk the list again and remove all blocks }
1042
 
        foundsize:=pcurr^.size and sizemask;
1043
 
        hp:=pcurr;
1044
 
        repeat
1045
 
          { get next block }
1046
 
          hp:=pfreerecord(pointer(hp)+(hp^.size and sizemask));
1047
 
          { when we're at heapptr then we can increase it, if there is enough
1048
 
            room is already checked }
1049
 
          if (hp=heapptr) then
1050
 
           begin
1051
 
             inc(heapptr,size-foundsize);
1052
 
             foundsize:=size;
1053
 
             if (heapend-heapptr)<sizeof(tfreerecord) then
1054
 
              wasbeforeheapend:=true;
1055
 
             break;
1056
 
           end;
1057
 
          s:=hp^.size and sizemask;
1058
 
          inc(foundsize,s);
1059
 
          { remove block from freelist }
1060
 
          s:=s shr blockshr;
1061
 
          if s>maxblock then
1062
 
           s:=0;
1063
 
          if assigned(hp^.next) then
1064
 
           hp^.next^.prev:=hp^.prev;
1065
 
          if assigned(hp^.prev) then
1066
 
           hp^.prev^.next:=hp^.next
1067
 
          else
1068
 
           freelists[s]:=hp^.next;
1069
 
{$ifdef SYSTEMDEBUG}
1070
 
           dec(freecount[s]);
1071
 
{$endif SYSTEMDEBUG}
1072
 
        until (foundsize>=size);
1073
 
        if wasbeforeheapend then
1074
 
         begin
1075
 
           pcurr^.size:=foundsize or usedmask or beforeheapendmask;
1076
 
           { keep track of the block that lies before the current heapend }
1077
 
           if (pointer(pcurr)+foundsize+sizeof(tfreerecord) >= heapend) then
1078
 
             before_heapend_block := pcurr;
1079
 
         end
1080
 
        else
1081
 
         pcurr^.size:=foundsize or usedmask;
1082
 
      end
1083
 
     else
1084
 
      begin
1085
 
        { we need to call getmem/move/freemem }
1086
 
        SysTryResizeMem:=false;
1087
 
{$ifdef TestFreeLists}
1088
 
        if test_each then
1089
 
         TestFreeLists;
1090
 
{$endif TestFreeLists}
1091
 
        exit;
1092
 
      end;
1093
 
     currsize:=pcurr^.size and sizemask;
1094
 
   end;
1095
 
{ is the size smaller then we can adjust the block to that size and insert
1096
 
  the other part into the freelist }
1097
 
  if size<currsize then
1098
 
   begin
1099
 
     { create the left over freelist block, if at least 16 bytes are free }
1100
 
     sizeleft:=currsize-size;
1101
 
     if sizeleft>sizeof(tfreerecord) then
1102
 
      begin
1103
 
        pnew:=pfreerecord(pointer(pcurr)+size);
1104
 
        pnew^.size:=sizeleft or (pcurr^.size and beforeheapendmask);
1105
 
        { keep track of the block that lies before the current heapend }
1106
 
        if (pointer(pnew)+(pnew^.size and sizemask)+sizeof(tfreerecord) >= heapend) then
1107
 
          before_heapend_block := pnew;
1108
 
        { pcurr does not lie before the heapend anymore }
1109
 
        pcurr^.size := pcurr^.size and not(beforeheapendmask);
1110
 
        { insert the block in the freelist }
1111
 
        pnew^.prev:=nil;
1112
 
        s:=sizeleft shr blockshr;
1113
 
        if s>maxblock then
1114
 
         s:=0;
1115
 
        pnew^.next:=freelists[s];
1116
 
        if assigned(freelists[s]) then
1117
 
         freelists[s]^.prev:=pnew;
1118
 
        freelists[s]:=pnew;
1119
 
{$ifdef SYSTEMDEBUG}
1120
 
        inc(freecount[s]);
1121
 
{$endif SYSTEMDEBUG}
1122
 
        { fix the size of the current block and leave }
1123
 
        pcurr^.size:=size or usedmask;
1124
 
      end
1125
 
     else
1126
 
      begin
1127
 
        { fix the size of the current block and leave }
1128
 
        pcurr^.size:=size or usedmask or (pcurr^.size and beforeheapendmask);
1129
 
      end;
1130
 
   end;
1131
 
  dec(internal_memavail,size-oldsize);
1132
 
  SysTryResizeMem:=true;
1133
 
{$ifdef TestFreeLists}
1134
 
  if test_each then
1135
 
    TestFreeLists;
1136
 
{$endif TestFreeLists}
1137
 
end;
1138
 
 
1139
 
 
1140
 
{*****************************************************************************
1141
 
                                 SysResizeMem
1142
 
*****************************************************************************}
1143
 
 
1144
 
function SysReAllocMem(var p:pointer;size : ptrint):pointer;
1145
 
var
1146
 
  oldsize : ptrint;
1147
 
  p2 : pointer;
1148
 
begin
1149
 
  { Free block? }
1150
 
  if size=0 then
1151
 
   begin
1152
 
     if p<>nil then
1153
 
      begin
1154
 
        MemoryManager.FreeMem(p);
1155
 
        p:=nil;
1156
 
      end;
1157
 
   end
1158
 
  else
1159
 
   { Allocate a new block? }
1160
 
   if p=nil then
1161
 
    begin
1162
 
      p:=MemoryManager.GetMem(size);
1163
 
    end
1164
 
  else
1165
 
   { Resize block }
1166
 
   if not SysTryResizeMem(p,size) then
1167
 
    begin
1168
 
      oldsize:=MemoryManager.MemSize(p);
1169
 
      p2:=MemoryManager.GetMem(size);
1170
 
      if p2<>nil then
1171
 
       Move(p^,p2^,oldsize);
1172
 
      MemoryManager.FreeMem(p);
1173
 
      p:=p2;
1174
 
    end;
1175
 
  SysReAllocMem:=p;
1176
 
end;
1177
 
 
1178
 
 
1179
 
{*****************************************************************************
1180
 
                                Mark/Release
1181
 
*****************************************************************************}
1182
 
 
1183
 
procedure release(var p : pointer);
1184
 
begin
1185
 
end;
1186
 
 
1187
 
 
1188
 
procedure mark(var p : pointer);
1189
 
begin
1190
 
end;
1191
 
 
1192
 
 
1193
 
{*****************************************************************************
1194
 
                                Grow Heap
1195
 
*****************************************************************************}
1196
 
 
1197
 
function growheap(size : SizeInt) : integer;
1198
 
var
1199
 
  sizeleft,s1 : longword;
1200
 
  NewPos    : pointer;
1201
 
  pcurr     : pfreerecord;
1202
 
begin
1203
 
{$ifdef DUMPGROW}
1204
 
  writeln('growheap(',size,')  allocating ',(size+$ffff) and $ffff0000);
1205
 
  DumpBlocks;
1206
 
{$endif}
1207
 
  { Allocate by 64K size }
1208
 
  size:=(size+$ffff) and $ffff0000;
1209
 
  { first try 256K (default) }
1210
 
  if size<=GrowHeapSize1 then
1211
 
   begin
1212
 
     NewPos:=Sbrk(GrowHeapSize1);
1213
 
     if NewPos<>nil then
1214
 
      size:=GrowHeapSize1;
1215
 
   end
1216
 
  else
1217
 
  { second try 1024K (default) }
1218
 
   if size<=GrowHeapSize2 then
1219
 
    begin
1220
 
      NewPos:=Sbrk(GrowHeapSize2);
1221
 
      if NewPos<>nil then
1222
 
       size:=GrowHeapSize2;
1223
 
    end
1224
 
  { else allocate the needed bytes }
1225
 
  else
1226
 
    NewPos:=SBrk(size);
1227
 
  { try again }
1228
 
  if NewPos=nil then
1229
 
   begin
1230
 
     NewPos:=Sbrk(size);
1231
 
     if NewPos=nil then
1232
 
      begin
1233
 
        if ReturnNilIfGrowHeapFails then
1234
 
          GrowHeap:=1
1235
 
        else
1236
 
          GrowHeap:=0;
1237
 
        Exit;
1238
 
      end;
1239
 
   end;
1240
 
{ increase heapend or add to freelist }
1241
 
  if heapend=newpos then
1242
 
   begin
1243
 
     heapend:=newpos+size;
1244
 
     { the block that was marked as "before heapend" is no longer right before the heapend }
1245
 
     if assigned(before_heapend_block) then
1246
 
       begin
1247
 
         before_heapend_block^.size := before_heapend_block^.size and not(beforeheapendmask);
1248
 
         before_heapend_block := nil;
1249
 
       end;
1250
 
   end
1251
 
  else
1252
 
   begin
1253
 
     { create freelist entry for old heapptr-heapend }
1254
 
     sizeleft:=heapend-heapptr;
1255
 
     if sizeleft>=sizeof(tfreerecord) then
1256
 
      begin
1257
 
        pcurr:=pfreerecord(heapptr);
1258
 
        pcurr^.size:=sizeleft or beforeheapendmask;
1259
 
        { keep track of the block that lies before the current heapend }
1260
 
        { insert the block in the freelist }
1261
 
        s1:=sizeleft shr blockshr;
1262
 
        if s1>maxblock then
1263
 
         s1:=0;
1264
 
        pcurr^.next:=freelists[s1];
1265
 
        pcurr^.prev:=nil;
1266
 
        if assigned(freelists[s1]) then
1267
 
         freelists[s1]^.prev:=pcurr;
1268
 
        freelists[s1]:=pcurr;
1269
 
{$ifdef SYSTEMDEBUG}
1270
 
        inc(freecount[s1]);
1271
 
{$endif SYSTEMDEBUG}
1272
 
      end;
1273
 
     { now set the new heapptr,heapend to the new block }
1274
 
     heapptr:=newpos;
1275
 
     heapend:=newpos+size;
1276
 
     { no block lies before the current heapend, and the one that lay before }
1277
 
     { the previous one will remain before a heapend indefinitely            }
1278
 
     before_heapend_block := nil;
1279
 
   end;
1280
 
{ set the total new heap size }
1281
 
  inc(internal_memavail,size);
1282
 
  inc(internal_heapsize,size);
1283
 
{ try again }
1284
 
  GrowHeap:=2;
1285
 
{$ifdef TestFreeLists}
1286
 
  TestFreeLists;
1287
 
{$endif TestFreeLists}
1288
 
end;
1289
 
 
1290
 
 
1291
 
{*****************************************************************************
1292
 
                       MemoryMutexManager default hooks
1293
 
*****************************************************************************}
1294
 
 
1295
 
procedure SysHeapMutexInit;
1296
 
begin
1297
 
  { nothing todo }
1298
 
end;
1299
 
 
1300
 
procedure SysHeapMutexDone;
1301
 
begin
1302
 
  { nothing todo }
1303
 
end;
1304
 
 
1305
 
procedure SysHeapMutexLock;
1306
 
begin
1307
 
  { give an runtime error. the program is running multithreaded without
1308
 
    any heap protection. this will result in unpredictable errors so
1309
 
    stopping here with an error is more safe (PFV) }
1310
 
  runerror(244);
1311
 
end;
1312
 
 
1313
 
procedure SysHeapMutexUnLock;
1314
 
begin
1315
 
  { see SysHeapMutexLock for comment }
1316
 
  runerror(244);
1317
 
end;
1318
 
 
1319
 
 
1320
 
{*****************************************************************************
1321
 
                                 InitHeap
1322
 
*****************************************************************************}
1323
 
 
1324
 
{ This function will initialize the Heap manager and need to be called from
1325
 
  the initialization of the system unit }
1326
 
procedure InitHeap;
1327
 
begin
1328
 
  FillChar(FreeLists,sizeof(TFreeLists),0);
1329
 
{$ifdef SYSTEMDEBUG}
1330
 
  FillChar(FreeCount,sizeof(TFreeCount),0);
1331
 
{$endif SYSTEMDEBUG}
1332
 
  before_heapend_block := nil;
1333
 
  internal_heapsize:=GetHeapSize;
1334
 
  internal_memavail:=internal_heapsize;
1335
 
  HeapOrg:=GetHeapStart;
1336
 
  HeapPtr:=HeapOrg;
1337
 
  HeapEnd:=HeapOrg+internal_memavail;
1338
 
  HeapError:=@GrowHeap;
1339
 
end;
1340
 
 
1341
 
{
1342
 
  $Log: heap.inc,v $
1343
 
  Revision 1.29  2004/04/26 16:20:54  peter
1344
 
    * 64bit fixes
1345
 
 
1346
 
  Revision 1.28  2004/03/15 21:48:26  peter
1347
 
    * cmem moved to rtl
1348
 
    * longint replaced with ptrint in heapmanagers
1349
 
 
1350
 
  Revision 1.27  2004/03/15 20:42:39  peter
1351
 
    * exit with rte 204 instead of looping infinite when a heap record
1352
 
      size is overwritten with 0
1353
 
 
1354
 
  Revision 1.26  2004/01/29 22:45:25  jonas
1355
 
    * improved beforeheapend inheritance (remove flag again when possible,
1356
 
      sometimes resulting in more opportunities for TryConcatFreeRecord)
1357
 
 
1358
 
  Revision 1.25  2003/12/15 21:39:16  daniel
1359
 
    * Small microoptimization
1360
 
 
1361
 
  Revision 1.24  2003/10/02 14:03:24  marco
1362
 
   * *memORY overloads
1363
 
 
1364
 
  Revision 1.23  2003/09/28 12:43:48  peter
1365
 
    * fixed wrong check when allocation of a block > 1mb failed
1366
 
 
1367
 
  Revision 1.22  2003/09/27 11:52:35  peter
1368
 
    * sbrk returns pointer
1369
 
 
1370
 
  Revision 1.21  2003/05/23 14:53:48  peter
1371
 
    * check newpos < 0 instead of = -1
1372
 
 
1373
 
  Revision 1.20  2003/05/01 08:05:23  florian
1374
 
    * started to make the rtl 64 bit save by introducing SizeInt and SizeUInt (similar to size_t of C)
1375
 
 
1376
 
  Revision 1.19  2002/11/01 17:38:04  peter
1377
 
    * fix setmemorymutexmanager to call mutexdone on the already
1378
 
      installed manager instead of the passed manager
1379
 
 
1380
 
  Revision 1.18  2002/10/30 20:39:13  peter
1381
 
    * MemoryManager record has a field NeedLock if the wrapper functions
1382
 
      need to provide locking for multithreaded programs
1383
 
 
1384
 
  Revision 1.17  2002/10/30 19:54:19  peter
1385
 
    * remove wrong lock from SysMemSize, MemSize() does the locking
1386
 
      already.
1387
 
 
1388
 
  Revision 1.16  2002/10/14 19:39:17  peter
1389
 
    * threads unit added for thread support
1390
 
 
1391
 
  Revision 1.15  2002/09/07 15:07:45  peter
1392
 
    * old logs removed and tabs fixed
1393
 
 
1394
 
  Revision 1.14  2002/06/17 08:33:04  jonas
1395
 
    * heap manager now fragments the heap much less
1396
 
 
1397
 
  Revision 1.13  2002/04/21 18:56:59  peter
1398
 
    * fpc_freemem and fpc_getmem compilerproc
1399
 
 
1400
 
  Revision 1.12  2002/02/10 15:33:45  carl
1401
 
  * fixed some missing IsMultiThreaded variables
1402
 
 
1403
 
  Revision 1.11  2002/01/02 13:43:09  jonas
1404
 
    * fix for web bug 1727 from Peter (corrected)
1405
 
 
1406
 
}
1407