{ $Id$ This file is part of the Free Pascal run time library. Copyright (c) 1993,97 by the Free Pascal development team. See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {**************************************************************************** functions for heap management in the data segment ****************************************************************************} {**** 10/06/97 added checkings and corrected some bugs in getmem/freemem ****} {**** Pierre Muller *********************************************************} { three conditionnals here } { TEMPHEAP to allow to split the heap in two parts for easier release} { started for the compiler } { USEBLOCKS if you want special allocation for small blocks } { CHECKHEAP if you want to test the heap integrity } {$IfDef CHECKHEAP} { 4 levels of tracing } const tracesize = 4; type pheap_mem_info = ^heap_mem_info; heap_mem_info = record next,previous : pheap_mem_info; size : longint; sig : longint; {dummy number for test } calls : array [1..tracesize] of longint; end; { size 8*4 = 32 } { help variables for debugging with GDB } const check : boolean = false; const last_assigned : pheap_mem_info = nil; const growheapstop : boolean = false; const free_nothing : boolean = false; const trace : boolean = true; const getmem_nb : longint = 0; const freemem_nb : longint = 0; {$EndIf CHECKHEAP} const heap_split : boolean = false; max_size = 256; maxblock = max_size div 8; freerecord_list_length : longint = 0; var _memavail : longint; _internal_heapsize : longint; type {$ifdef UseBlocks} tblocks = array[1..maxblock] of pointer; pblocks = ^tblocks; tnblocks = array[1..maxblock] of longint; pnblocks = ^tnblocks; {$endif UseBlocks} pheapinfo = ^theapinfo; theapinfo = record heaporg,heapptr,heapend,freelist : pointer; memavail,heapsize : longint; {$ifdef UseBlocks} block : pblocks; nblock : pnblocks; {$endif UseBlocks} {$IfDef CHECKHEAP} last_mem : pheap_mem_info; nb_get,nb_free : longint; {$EndIf CHECKHEAP} end; type pfreerecord = ^tfreerecord; tfreerecord = record next : pfreerecord; size : longint; end; var baseheap : theapinfo; curheap : pheapinfo; {$ifdef TEMPHEAP} tempheap : theapinfo; otherheap : pheapinfo; {$endif TEMPHEAP} {$ifdef UseBlocks} baseblocks : tblocks; basenblocks : tnblocks; {$endif UseBlocks} { this is not supported by FPK nil do begin call_stack(pp+sizeof(heap_mem_info)); if mark then pp^.sig:=$AAAAAAAA; pp:=pp^.previous; end; end; procedure dump_free(p : pheap_mem_info); var bp : longint; begin Writeln('Marked memory at ',HexStr(longint(p),8),' released'); call_stack(p+sizeof(heap_mem_info)); asm move.l (a6),a0 move.l (a0),d0 move.l d0,bp end; dump_stack(bp); end; function is_in_getmem_list (p : pointer) : boolean; var pp : pheap_mem_info; i : longint; begin is_in_getmem_list:=false; pp:=last_assigned; i:=0; while pp<>nil do begin if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then begin writeln('error in linked list of heap_mem_info'); runerror(204); end; if pp=p then begin is_in_getmem_list:=true; end; pp:=pp^.previous; inc(i); if i > getmem_nb - freemem_nb then writeln('error in linked list of heap_mem_info'); end; end; function is_in_free(p : pointer) : boolean; var hp : pfreerecord; begin if p>heapptr then begin is_in_free:=true; exit; end else begin hp:=freelist; while assigned(hp) do begin if (p>=hp) and (plongint(heapptr)) then writeln('freerecordlist bad at end ') end else if ((longint(hp^.next)<=(longint(hp)+hp^.size)) or ((hp^.size mod 8) <> 0)) then writeln('error in freerecord list '); {$EndIf CHECKHEAP} hp:=hp^.next; end; cal_memavail:=ma; end; {$ifdef TEMPHEAP} procedure split_heap; var i :longint; begin if not heap_split then begin baseheap.heaporg:=heaporg; baseheap.heapptr:=heapptr; baseheap.freelist:=freelist; baseheap.block:=blocks; baseheap.nblock:=nblocks; longint(baseheap.heapend):=((longint(heapend)+longint(heapptr)) div 16)*8; tempheap.heaporg:=baseheap.heapend; tempheap.freelist:=nil; tempheap.heapptr:=tempheap.heaporg; {$IfDef CHECKHEAP} tempheap.last_mem:=nil; tempheap.nb_get:=0; tempheap.nb_free:=0; {$EndIf CHECKHEAP} tempheap.heapend:=heapend; tempheap.memavail:=longint(tempheap.heapend) - longint(tempheap.heaporg); tempheap.heapsize:=tempheap.memavail; getmem(tempheap.block,sizeof(tblocks)); getmem(tempheap.nblock,sizeof(tnblocks)); for i:=1 to maxblock do begin tempheap.block^[i]:=nil; tempheap.nblock^[i]:=0; end; heapend:=baseheap.heapend; _memavail:=cal_memavail; baseheap.memavail:=_memavail; baseheap.heapsize:=longint(baseheap.heapend)-longint(baseheap.heaporg); curheap:=@baseheap; otherheap:=@tempheap; heap_split:=true; end; end; procedure switch_to_temp_heap; begin if curheap = @baseheap then begin baseheap.heaporg:=heaporg; baseheap.heapend:=heapend; baseheap.heapptr:=heapptr; baseheap.freelist:=freelist; baseheap.memavail:=_memavail; baseheap.block:=blocks; baseheap.nblock:=nblocks; {$IfDef CHECKHEAP} baseheap.last_mem:=last_assigned; last_assigned:=tempheap.last_mem; baseheap.nb_get:=getmem_nb; baseheap.nb_free:=freemem_nb; getmem_nb:=tempheap.nb_get; freemem_nb:=tempheap.nb_free; {$EndIf CHECKHEAP} heaporg:=tempheap.heaporg; heapptr:=tempheap.heapptr; freelist:=tempheap.freelist; heapend:=tempheap.heapend; blocks:=tempheap.block; nblocks:=tempheap.nblock; _memavail:=cal_memavail; curheap:=@tempheap; otherheap:=@baseheap; end; end; procedure switch_to_base_heap; begin if curheap = @tempheap then begin tempheap.heaporg:=heaporg; tempheap.heapend:=heapend; tempheap.heapptr:=heapptr; tempheap.freelist:=freelist; tempheap.memavail:=_memavail; {$IfDef CHECKHEAP} tempheap.last_mem:=last_assigned; last_assigned:=baseheap.last_mem; tempheap.nb_get:=getmem_nb; tempheap.nb_free:=freemem_nb; getmem_nb:=baseheap.nb_get; freemem_nb:=baseheap.nb_free; {$EndIf CHECKHEAP} heaporg:=baseheap.heaporg; heapptr:=baseheap.heapptr; freelist:=baseheap.freelist; heapend:=baseheap.heapend; blocks:=baseheap.block; nblocks:=baseheap.nblock; _memavail:=cal_memavail; curheap:=@baseheap; otherheap:=@tempheap; end; end; procedure switch_heap; begin if not heap_split then split_heap; if curheap = @tempheap then switch_to_base_heap else switch_to_temp_heap; end; procedure gettempmem(var p : pointer;size : longint); begin split_heap; switch_to_temp_heap; allow_special:=true; getmem(p,size); allow_special:=false; end; {$endif TEMPHEAP} function memavail : longint; begin memavail:=_memavail; end; {$ifdef TEMPHEAP} procedure unsplit_heap; var hp,hp2,thp : pfreerecord; begin {heapend can be modified by HeapError } if not heap_split then exit; if baseheap.heapend = tempheap.heaporg then begin switch_to_base_heap; hp:=pfreerecord(freelist); if assigned(hp) then while assigned(hp^.next) do hp:=hp^.next; if tempheap.heapptr<>tempheap.heaporg then begin if hp<>nil then hp^.next:=heapptr; hp:=pfreerecord(heapptr); hp^.size:=heapend-heapptr; hp^.next:=tempheap.freelist; heapptr:=tempheap.heapptr; end; heapend:=tempheap.heapend; _memavail:=cal_memavail; heap_split:=false; end else begin hp:=pfreerecord(baseheap.freelist); hp2:=pfreerecord(tempheap.freelist); while assigned(hp) and assigned(hp2) do begin if hp=hp2 then break; if hp>hp2 then begin thp:=hp2; hp2:=hp; hp:=thp; end; while assigned(hp^.next) and (hp^.nextheaporg then writeln('Warning in releasetempheap : ',longint(tempheap.heapsize)-longint(tempheap.memavail),' bytes used !'); dump_heap(true); { release(heaporg); fillchar(heaporg^,longint(heapend)-longint(heaporg),#0);} {$endif CHECKHEAP } unsplit_heap; split_heap; end; {$endif TEMPHEAP} function maxavail : longint; var hp : pfreerecord; begin maxavail:=heapend-heapptr; hp:=freelist; while assigned(hp) do begin if hp^.size>maxavail then maxavail:=hp^.size; hp:=hp^.next; end; end; {$ifdef CHECKHEAP} procedure test_memavail; begin if check and (_memavail<>cal_memavail) then begin writeln('Memavail error in getmem/freemem'); end; end; {$endif CHECKHEAP} procedure getmem(var p : pointer;size : longint);[public,alias: 'GETMEM']; {$IfDef CHECKHEAP} var i,bp,orsize : longint; label check_new; {$endif CHECKHEAP} { changed to removed the OS conditionnals } function call_heaperror(addr : pointer; size : longint) : integer; begin asm pea.l size move.l addr,a0 jsr (a0) move.w d0,@Result end; end; var last,hp : pfreerecord; nochmal : boolean; s : longint; begin {$ifdef CHECKHEAP} if trace then begin orsize:=size; size:=size+sizeof(heap_mem_info); end; {$endif CHECKHEAP} if size=0 then begin p:=heapend; {$ifdef CHECKHEAP} goto check_new; {$else CHECKHEAP} exit; {$endif CHECKHEAP} end; {$ifdef TEMPHEAP} if heap_split and not allow_special then begin if (@p < otherheap^.heapend) and (@p > otherheap^.heaporg) then { useful line for the debugger } writeln('warning : p and @p are in different heaps !'); end; {$endif TEMPHEAP} { calc to multiply of 8 } if (size mod 8)<>0 then size:=size+(8-(size mod 8)); dec(_memavail,size); {$ifdef UseBlocks} { search cache } if size<=max_size then begin s:=size div 8; if assigned(blocks^[s]) then begin p:=blocks^[s]; blocks^[s]:=pointer(blocks^[s]^); dec(nblocks^[s]); {$ifdef CHECKHEAP} goto check_new; {$else CHECKHEAP} exit; {$endif CHECKHEAP} end; end; {$endif UseBlocks} repeat nochmal:=false; { search the freelist } if assigned(freelist) then begin last:=nil; hp:=freelist; while assigned(hp) do begin { take the first fitting block } if hp^.size>=size then begin p:=hp; { need we the whole block ? } if hp^.size>size then begin {$ifdef UseBlocks} { we must check if we are still below the limit !! } if hp^.size-size<=max_size then begin { adjust the list } if assigned(last) then last^.next:=hp^.next else freelist:=hp^.next; { insert in chain } s:=(hp^.size-size) div 8; ppointer(hp+size)^:=blocks^[s]; blocks^[s]:=hp+size; inc(nblocks^[s]); end else {$endif UseBlocks} begin (hp+size)^.size:=hp^.size-size; (hp+size)^.next:=hp^.next; if assigned(last) then last^.next:=hp+size else freelist:=hp+size; end; end else begin {$IfDef CHECKHEAP} dec(freerecord_list_length); {$endif CHECKHEAP} if assigned(last) then last^.next:=hp^.next else {this was wrong !!} {freelist:=nil;} freelist:=hp^.next; end; {$ifdef CHECKHEAP} goto check_new; {$else CHECKHEAP} exit; {$endif CHECKHEAP} end; last:=hp; hp:=hp^.next; end; end; { Latly, the top of the heap is checked, to see if there is } { still memory available. } if heapend-heapptrnil then last_assigned^.next:=pheap_mem_info(p); last_assigned:=p; pheap_mem_info(p)^.next:=nil; pheap_mem_info(p)^.size:=orsize; for i:=1 to tracesize do begin pheap_mem_info(p)^.calls[i]:=get_addr(bp); bp:=get_next_frame(bp); end; p:=p+sizeof(heap_mem_info); end; {$endif CHECKHEAP} end; procedure freemem(var p : pointer;size : longint);[public,alias: 'FREEMEM']; var hp : pfreerecord; {$ifdef TEMPHEAP} heap_switched : boolean; {$endif TEMPHEAP} s : longint; label freemem_exit; begin {$ifdef CHECKHEAP} if free_nothing then begin p:=nil; exit; end; if trace then begin size:=size+sizeof(heap_mem_info); p:=p-sizeof(heap_mem_info); { made after heap_switch if not (is_in_getmem_list(p)) then runerror(204); } end; {$endif CHECKHEAP} if size=0 then begin p:=nil; exit; end; if p=nil then RunError (204); {$ifdef TEMPHEAP} heap_switched:=false; if heap_split and not allow_special then begin if (p <= heapptr) and ( p >= heaporg) and (@p <= otherheap^.heapend) and (@p >= otherheap^.heaporg) then begin writeln('warning : p and @p are in different heaps !'); end; end; if (pheapptr) then begin if heap_split and (potherheap^.heaporg) then begin if (@p >= heaporg) and (@p <= heapptr) and not allow_special then writeln('warning : p and @p are in different heaps !'); switch_heap; heap_switched:=true; end else begin writeln('pointer ',hexstr(longint(@p),8),' at ', hexstr(longint(p),8),' doesn''t points to the heap'); runerror(204); end; end; {$endif TEMPHEAP} {$ifdef CHECKHEAP} if trace then begin if not (is_in_getmem_list(p)) then runerror(204); if pheap_mem_info(p)^.sig=$AAAAAAAA then dump_free(p); if pheap_mem_info(p)^.next<>nil then pheap_mem_info(p)^.next^.previous:=pheap_mem_info(p)^.previous; if pheap_mem_info(p)^.previous<>nil then pheap_mem_info(p)^.previous^.next:=pheap_mem_info(p)^.next; if pheap_mem_info(p)=last_assigned then last_assigned:=last_assigned^.previous; end; {$endif CHECKHEAP} { calc to multiple of 8 } if (size mod 8)<>0 then size:=size+(8-(size mod 8)); inc(_memavail,size); if p+size>=heapptr then heapptr:=p {$ifdef UseBlocks} { insert into cache } else if size<=max_size then begin s:=size div 8; ppointer(p)^:=blocks^[s]; blocks^[s]:=p; inc(nblocks^[s]); end {$endif UseBlocks} else begin { size can be allways set } pfreerecord(p)^.size:=size; { if there is no free list } if not assigned(freelist) then begin { then generate one } freelist:=p; pfreerecord(p)^.next:=nil; {$ifdef CHECKHEAP} inc(freerecord_list_length); {$endif CHECKHEAP} goto freemem_exit; end; if p+sizenil) and (hp+hp^.size>hp^.next) then begin writeln('pointer to dispose at ',hexstr(longint(p),8), ' is too big !!'); runerror(204); end; break; end { if the end is reached, then concat } else if hp^.next=nil then begin hp^.next:=p; {$ifdef CHECKHEAP} inc(freerecord_list_length); {$endif CHECKHEAP} pfreerecord(p)^.next:=nil; break; end { falls der n„chste Zeiger gr”áer ist, dann } { Einh„ngen } else if hp^.next>p then begin { connect to blocks } if p+size=hp^.next then begin pfreerecord(p)^.next:=hp^.next^.next; inc(pfreerecord(p)^.size,hp^.next^.size); { we have to reset the right position } hp^.next:=pfreerecord(p); end else begin pfreerecord(p)^.next:=hp^.next; hp^.next:=p; {$ifdef CHECKHEAP} inc(freerecord_list_length); {$endif CHECKHEAP} end; break; end; hp:=hp^.next; end; end; freemem_exit: {$ifdef CHECKHEAP} inc(freemem_nb); test_memavail; {$endif CHECKHEAP} p:=nil; {$ifdef TEMPHEAP} if heap_switched then switch_heap; {$endif TEMPHEAP} end; procedure release(var p : pointer); begin heapptr:=p; freelist:=nil; _memavail:=cal_memavail; end; procedure mark(var p : pointer); begin p:=heapptr; end; procedure markheap(var oldfreelist,oldheapptr : pointer); begin oldheapptr:=heapptr; oldfreelist:=freelist; freelist:=nil; _memavail:=cal_memavail; end; procedure releaseheap(oldfreelist,oldheapptr : pointer); begin heapptr:=oldheapptr; if longint(freelist) < longint(heapptr) then begin {here we should reget the freed blocks} end; freelist:=oldfreelist; _memavail:=cal_memavail; end; { the sbrk function is moved to the system.pp } { as it is system dependent !! } function growheap(size :longint) : integer; var NewPos,wantedsize : longint; hp : pfreerecord; Newlimit : longint; begin wantedsize:=size; size:=size+$ffff; size:=size and $ffff0000; { Allocate by 64K size } { first try 1Meg } NewPos:=Sbrk($100000); if NewPos=-1 then NewPos:=Sbrk(size) else size:=$100000; if (NewPos = -1) then begin GrowHeap:=0; {$IfDef CHECKHEAP} writeln('Call to GrowHeap failed'); readln; {$EndIf CHECKHEAP} Exit; end else begin { make the room clean } {$ifdef CHECKHEAP} Fillword(pointer(NewPos)^,size div 2,$ABCD); Newlimit:= (newpos+size) or $3fff; {$else } Fillchar(pointer(NewPos)^,size,#0); {$endif } hp:=pfreerecord(freelist); if not assigned(hp) then begin if pointer(newpos) = heapend then heapend:=pointer(newpos+size) else begin if heapend - heapptr > 0 then begin freelist:=heapptr; hp:=pfreerecord(freelist); hp^.size:=heapend-heapptr; hp^.next:=nil; end; heapptr:=pointer(newpos); heapend:=pointer(newpos+size); end; end else begin if pointer(newpos) = heapend then heapend:=pointer(newpos+size) else begin while assigned(hp^.next) and (longint(hp^.next) < longint(NewPos)) do hp:=hp^.next; if hp^.next = nil then begin hp^.next:=pfreerecord(heapptr); hp:=pfreerecord(heapptr); hp^.size:=heapend-heapptr; hp^.next:=nil; heapptr:=pointer(NewPos); heapend:=pointer(NewPos+Size); end else begin pfreerecord(NewPos)^.Size:=Size; pfreerecord(NewPos)^.Next:=hp^.next; hp^.next:=pfreerecord(NewPos); end; end; end; { the wanted size has to be substracted } _memavail:=cal_memavail-wantedsize; { set the total new heap size } asm move.l Size,d0 move.l HEAP_SIZE,d1 add.l d0,d1 move.l d1,HEAP_SIZE end; GrowHeap:=2;{ try again } _internal_heapsize:=size+_internal_heapsize; {$IfDef CHECKHEAP} writeln('Call to GrowHeap succedeed : HeapSize = ',_internal_heapsize,' MemAvail = ',memavail); writeln('New heap part begins at ',Newpos,' with size ',size); if growheapstop then readln; {$EndIf CHECKHEAP} exit; end; end; { This function will initialize the Heap manager and need to be called from the initialization of the system unit } procedure InitHeap; {$ifdef UseBlocks} var i : longint; {$endif UseBlocks} begin {$ifdef UseBlocks} Blocks:=@baseblocks; Nblocks:=@basenblocks; for i:=1 to maxblock do begin Blocks^[i]:=nil; Nblocks^[i]:=0; end; {$endif UseBlocks} Curheap := @baseheap; {$ifdef TEMPHEAP} Otherheap := @tempheap; {$endif TEMPHEAP} HeapOrg := GetHeapStart; HeapPtr := HeapOrg; _memavail := GetHeapSize; HeapEnd := HeapOrg + _memavail; HeapError := @GrowHeap; _internal_heapsize:=longint(heapend)-longint(heaporg); Freelist := nil; end; { $Log$ Revision 1.4 1998-07-08 11:54:40 carl + reinstated hepasize function * renamed HEAPSIZE global var to HEAP_SIZE to remove conflicts Revision 1.3 1998/07/02 14:24:08 michael Undid carls changes, but renamed _heapsize to _internal_heapsize. Make cycle now works Revision 1.2 1998/07/02 12:22:38 carl - removed heapsize function, would cause conflicts with HEAPSIZE var * GetHeapstart was misplaced Revision 1.1.1.1 1998/03/25 11:18:44 root * Restored version Revision 1.3 1998/01/26 12:01:52 michael + Added log at the end Working file: rtl/m68k/heap.inc description: ---------------------------- revision 1.2 date: 1998/01/05 16:51:24; author: michael; state: Exp; lines: +31 -1 + Moved init of heap to heap.inc: INITheap() (From Peter Vreman) ---------------------------- revision 1.1 date: 1998/01/05 00:32:44; author: carl; state: Exp; + First Version of m68k heap handler (handles amiga/macos/atari) ============================================================================= }