paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-31 17:31:42 +01:00
Code Issues Packages Projects Releases Wiki Activity
980efd582d
fpc/compiler/tgobj.pas
peter 6b90162c5a * fixes for temp type patch
2003-11-04 19:03:50 +00:00

758 lines
25 KiB
ObjectPascal
Raw Blame History

{
$Id$
Copyright (c) 1998-2002 by Florian Klaempfl
This unit implements the base object for temp. generator
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
{#@abstract(Temporary reference allocator unit)
Temporary reference allocator unit. This unit contains
all which is related to allocating temporary memory
space on the stack, as required, by the code generator.
}
unit tgobj;
{$i fpcdefs.inc}
interface
uses
cclasses,
globals,globtype,
symtype,
cpubase,cpuinfo,cgbase,
aasmbase,aasmtai;
type
ttemptypeset = set of ttemptype;
ptemprecord = ^ttemprecord;
ttemprecord = record
temptype : ttemptype;
pos : longint;
size : longint;
def : tdef;
next : ptemprecord;
nextfree : ptemprecord; { for faster freeblock checking }
{$ifdef EXTDEBUG}
posinfo,
releaseposinfo : tfileposinfo;
{$endif}
end;
{# Generates temporary variables }
ttgobj = class
private
{ contains all free temps using nextfree links }
tempfreelist : ptemprecord;
function alloctemp(list: taasmoutput; size : longint; temptype : ttemptype; def:tdef) : longint;
procedure freetemp(list: taasmoutput; pos:longint;temptypes:ttemptypeset);
public
{ contains all temps }
templist : ptemprecord;
{ Offsets of the first/last temp }
firsttemp,
lasttemp : longint;
direction : shortint;
constructor create;
{# Clear and free the complete linked list of temporary memory
locations. The list is set to nil.}
procedure resettempgen;
{# Sets the first offset from the frame pointer or stack pointer where
the temporary references will be allocated. It is to note that this
value should always be negative.
@param(l start offset where temps will start in stack)
}
procedure setfirsttemp(l : longint);
procedure gettemp(list: taasmoutput; size : longint;temptype:ttemptype;var ref : treference);
procedure gettemptyped(list: taasmoutput; def:tdef;temptype:ttemptype;var ref : treference);
procedure ungettemp(list: taasmoutput; const ref : treference);
function sizeoftemp(list: taasmoutput; const ref: treference): longint;
function changetemptype(list: taasmoutput; const ref:treference;temptype:ttemptype):boolean;
{# Returns TRUE if the reference ref is allocated in temporary volatile memory space,
otherwise returns FALSE.
@param(ref reference to verify)
}
function istemp(const ref : treference) : boolean;
{# Frees a reference @var(ref) which was allocated in the volatile temporary memory space.
The freed space can later be reallocated and reused. If this reference
is not in the temporary memory, it is simply not freed.
}
procedure ungetiftemp(list: taasmoutput; const ref : treference);
{ Allocate space for a local }
procedure getlocal(list: taasmoutput; size : longint;var ref : tparareference);
procedure UnGetLocal(list: taasmoutput; const ref : tparareference);
end;
var
tg: ttgobj;
implementation
uses
cutils,
systems,verbose,
procinfo
;
const
FreeTempTypes = [tt_free,tt_freenoreuse];
{$ifdef EXTDEBUG}
TempTypeStr : array[ttemptype] of string[18] = (
'<none>',
'free','normal','persistant',
'noreuse','freenoreuse'
);
{$endif EXTDEBUG}
Used2Free : array[ttemptype] of ttemptype = (
tt_none,
tt_none,tt_free,tt_free,
tt_freenoreuse,tt_none
);
{*****************************************************************************
TTGOBJ
*****************************************************************************}
constructor ttgobj.create;
begin
tempfreelist:=nil;
templist:=nil;
{ we could create a new child class for this but I don't if it is worth the effort (FK) }
{$ifdef powerpc}
direction:=1;
{$else powerpc}
direction:=-1;
{$endif powerpc}
end;
procedure ttgobj.resettempgen;
var
hp : ptemprecord;
begin
{ Clear the old templist }
while assigned(templist) do
begin
{$ifdef EXTDEBUG}
if not(templist^.temptype in FreeTempTypes) then
begin
Comment(V_Warning,'tgobj: (ResetTempgen) temp at pos '+tostr(templist^.pos)+
' with size '+tostr(templist^.size)+' and type '+TempTypeStr[templist^.temptype]+
' from pos '+tostr(templist^.posinfo.line)+':'+tostr(templist^.posinfo.column)+
' not freed at the end of the procedure');
end;
{$endif}
hp:=templist;
templist:=hp^.next;
dispose(hp);
end;
templist:=nil;
tempfreelist:=nil;
firsttemp:=0;
lasttemp:=0;
end;
procedure ttgobj.setfirsttemp(l : longint);
begin
{ this is a negative value normally }
if l*direction>=0 then
begin
if odd(l) then
inc(l,direction);
end
else
internalerror(200204221);
firsttemp:=l;
lasttemp:=l;
end;
function ttgobj.AllocTemp(list: taasmoutput; size : longint; temptype : ttemptype;def : tdef) : longint;
var
tl,
bestslot,bestprev,
hprev,hp : ptemprecord;
bestsize : longint;
freetype : ttemptype;
begin
AllocTemp:=0;
bestprev:=nil;
bestslot:=nil;
tl:=nil;
bestsize:=0;
if size=0 then
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'tgobj: (AllocTemp) temp of size 0 requested, allocating 4 bytes');
{$endif}
size:=4;
end;
freetype:=Used2Free[temptype];
if freetype=tt_none then
internalerror(200208201);
{ Align needed size on 4 bytes }
size:=align(size,4);
{ First check the tmpfreelist, but not when
we don't want to reuse an already allocated block }
if assigned(tempfreelist) and
(temptype<>tt_noreuse) then
begin
{ Check for a slot with the same size first }
hprev:=nil;
hp:=tempfreelist;
while assigned(hp) do
begin
{$ifdef EXTDEBUG}
if not(hp^.temptype in FreeTempTypes) then
Comment(V_Warning,'tgobj: (AllocTemp) temp at pos '+tostr(hp^.pos)+ ' in freelist is not set to tt_free !');
{$endif}
if (hp^.temptype=freetype) and
(hp^.def=def) and
(hp^.size>=size) then
begin
{ Slot is the same size, then leave immediatly }
if hp^.size=size then
begin
bestprev:=hprev;
bestslot:=hp;
bestsize:=size;
break;
end
else
begin
if (bestsize=0) or (hp^.size<bestsize) then
begin
bestprev:=hprev;
bestslot:=hp;
bestsize:=hp^.size;
end;
end;
end;
hprev:=hp;
hp:=hp^.nextfree;
end;
end;
{ Reuse an old temp ? }
if assigned(bestslot) then
begin
if bestsize=size then
begin
tl:=bestslot;
tl^.temptype:=temptype;
tl^.def:=def;
{ Remove from the tempfreelist }
if assigned(bestprev) then
bestprev^.nextfree:=tl^.nextfree
else
tempfreelist:=tl^.nextfree;
tl^.nextfree:=nil;
end
else
begin
{ Resize the old block }
dec(bestslot^.size,size);
{ Create new block and link after bestslot }
new(tl);
tl^.temptype:=temptype;
tl^.def:=def;
if direction=1 then
begin
tl^.pos:=bestslot^.pos;
inc(bestslot^.pos,size);
end
else
tl^.pos:=bestslot^.pos+bestslot^.size;
tl^.size:=size;
tl^.nextfree:=nil;
{ link the new block }
tl^.next:=bestslot^.next;
bestslot^.next:=tl;
end;
end
else
begin
{ create a new temp, we need to allocate at least a minimum of
4 bytes, else we get two temps at the same position resulting
in problems when finding the corresponding temprecord }
if size<4 then
size:=4;
{ now we can create the templist entry }
new(tl);
tl^.temptype:=temptype;
tl^.def:=def;
if direction=-1 then
begin
{ Extend the temp }
dec(lasttemp,size);
tl^.pos:=lasttemp;
end
else
begin
tl^.pos:=lasttemp;
{ Extend the temp }
inc(lasttemp,size);
end;
tl^.size:=size;
tl^.next:=templist;
tl^.nextfree:=nil;
templist:=tl;
end;
{$ifdef EXTDEBUG}
tl^.posinfo:=aktfilepos;
if assigned(tl^.def) then
list.concat(tai_tempalloc.allocinfo(tl^.pos,tl^.size,'allocated with type '+TempTypeStr[tl^.temptype]+' for def '+tl^.def.typename))
else
list.concat(tai_tempalloc.allocinfo(tl^.pos,tl^.size,'allocated with type '+TempTypeStr[tl^.temptype]));
{$else}
list.concat(tai_tempalloc.alloc(tl^.pos,tl^.size));
{$endif}
AllocTemp:=tl^.pos;
end;
procedure ttgobj.FreeTemp(list: taasmoutput; pos:longint;temptypes:ttemptypeset);
var
hp,hnext,hprev,hprevfree : ptemprecord;
begin
hp:=templist;
hprev:=nil;
hprevfree:=nil;
while assigned(hp) do
begin
if (hp^.pos=pos) then
begin
{ check if already freed }
if hp^.temptype in FreeTempTypes then
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'tgobj: (FreeTemp) temp at pos '+tostr(pos)+ ' is already free !');
list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp is already freed'));
{$endif}
exit;
end;
{ check type that are allowed to be released }
if not(hp^.temptype in temptypes) then
begin
{$ifdef EXTDEBUG}
Comment(V_Debug,'tgobj: (Freetemp) temp at pos '+tostr(pos)+ ' has different type ('+TempTypeStr[hp^.temptype]+'), not releasing');
list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp has wrong type ('+TempTypeStr[hp^.temptype]+') not releasing'));
{$endif}
exit;
end;
list.concat(tai_tempalloc.dealloc(hp^.pos,hp^.size));
{ set this block to free }
hp^.temptype:=Used2Free[hp^.temptype];
{ Update tempfreelist }
if assigned(hprevfree) then
begin
{ Concat blocks when the previous block is free and
there is no block assigned for a tdef }
if assigned(hprev) and
(hp^.temptype=tt_free) and
not assigned(hp^.def) and
(hprev^.temptype=tt_free) and
not assigned(hprev^.def) then
begin
inc(hprev^.size,hp^.size);
if direction=1 then
hprev^.pos:=hp^.pos;
hprev^.next:=hp^.next;
dispose(hp);
hp:=hprev;
end
else
hprevfree^.nextfree:=hp;
end
else
begin
hp^.nextfree:=tempfreelist;
tempfreelist:=hp;
end;
{ Concat blocks when the next block is free and
there is no block assigned for a tdef }
hnext:=hp^.next;
if assigned(hnext) and
(hp^.temptype=tt_free) and
not assigned(hp^.def) and
(hnext^.temptype=tt_free) and
not assigned(hnext^.def) then
begin
inc(hp^.size,hnext^.size);
if direction=1 then
hp^.pos:=hnext^.pos;
hp^.nextfree:=hnext^.nextfree;
hp^.next:=hnext^.next;
dispose(hnext);
end;
{ Stop }
exit;
end;
if (hp^.temptype=tt_free) then
hprevfree:=hp;
hprev:=hp;
hp:=hp^.next;
end;
end;
procedure ttgobj.gettemp(list: taasmoutput; size : longint;temptype:ttemptype;var ref : treference);
begin
{ can't use reference_reset_base, because that will let tgobj depend
on cgobj (PFV) }
fillchar(ref,sizeof(ref),0);
ref.base:=current_procinfo.framepointer;
ref.offset:=alloctemp(list,size,temptype,nil);
end;
procedure ttgobj.gettemptyped(list: taasmoutput; def:tdef;temptype:ttemptype;var ref : treference);
begin
{ can't use reference_reset_base, because that will let tgobj depend
on cgobj (PFV) }
fillchar(ref,sizeof(ref),0);
ref.base:=current_procinfo.framepointer;
ref.offset:=alloctemp(list,def.size,temptype,def);
end;
function ttgobj.istemp(const ref : treference) : boolean;
begin
{ ref.index = R_NO was missing
led to problems with local arrays
with lower bound > 0 (PM) }
if direction = 1 then
begin
istemp:=(ref.base=current_procinfo.framepointer) and
(ref.index=NR_NO) and
(ref.offset>=firsttemp);
end
else
begin
istemp:=(ref.base=current_procinfo.framepointer) and
(ref.index=NR_NO) and
(ref.offset<firsttemp);
end;
end;
function ttgobj.sizeoftemp(list: taasmoutput; const ref: treference): longint;
var
hp : ptemprecord;
begin
SizeOfTemp := -1;
hp:=templist;
while assigned(hp) do
begin
if (hp^.pos=ref.offset) then
begin
sizeoftemp := hp^.size;
exit;
end;
hp := hp^.next;
end;
{$ifdef EXTDEBUG}
comment(v_debug,'tgobj: (SizeOfTemp) temp at pos '+tostr(ref.offset)+' not found !');
list.concat(tai_tempalloc.allocinfo(ref.offset,0,'temp not found'));
{$endif}
end;
function ttgobj.ChangeTempType(list: taasmoutput; const ref:treference;temptype:ttemptype):boolean;
var
hp : ptemprecord;
begin
ChangeTempType:=false;
hp:=templist;
while assigned(hp) do
begin
if (hp^.pos=ref.offset) then
begin
if hp^.temptype<>tt_free then
begin
{$ifdef EXTDEBUG}
if hp^.temptype=temptype then
Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
' at pos '+tostr(ref.offset)+ ' is already of the correct type !');
list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'type changed to '+TempTypeStr[temptype]));
{$endif}
ChangeTempType:=true;
hp^.temptype:=temptype;
end
else
begin
{$ifdef EXTDEBUG}
Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
' at pos '+tostr(ref.offset)+ ' is already freed !');
list.concat(tai_tempalloc.allocinfo(hp^.pos,hp^.size,'temp is already freed'));
{$endif}
end;
exit;
end;
hp:=hp^.next;
end;
{$ifdef EXTDEBUG}
Comment(V_Warning,'tgobj: (ChangeTempType) temp'+
' at pos '+tostr(ref.offset)+ ' not found !');
list.concat(tai_tempalloc.allocinfo(ref.offset,0,'temp not found'));
{$endif}
end;
procedure ttgobj.UnGetTemp(list: taasmoutput; const ref : treference);
begin
FreeTemp(list,ref.offset,[tt_normal,tt_noreuse,tt_persistent]);
end;
procedure ttgobj.UnGetIfTemp(list: taasmoutput; const ref : treference);
begin
if istemp(ref) then
FreeTemp(list,ref.offset,[tt_normal]);
end;
procedure ttgobj.getlocal(list: taasmoutput; size : longint;var ref : tparareference);
begin
ref.index:=current_procinfo.framepointer;
ref.offset:=alloctemp(list,size,tt_persistent,nil);
end;
procedure ttgobj.UnGetLocal(list: taasmoutput; const ref : tparareference);
begin
FreeTemp(list,ref.offset,[tt_persistent]);
end;
end.
{
$Log$
Revision 1.42 2003-11-04 19:03:54 peter
* fixes for temp type patch
Revision 1.41 2003/11/04 15:35:13 peter
* fix for referencecounted temps
Revision 1.40 2003/10/01 20:34:49 peter
* procinfo unit contains tprocinfo
* cginfo renamed to cgbase
* moved cgmessage to verbose
* fixed ppc and sparc compiles
Revision 1.39 2003/09/23 17:56:06 peter
* locals and paras are allocated in the code generation
* tvarsym.localloc contains the location of para/local when
generating code for the current procedure
Revision 1.38 2003/09/03 15:55:01 peter
* NEWRA branch merged
Revision 1.37.2.2 2003/08/31 15:46:26 peter
* more updates for tregister
Revision 1.37.2.1 2003/08/29 17:28:59 peter
* next batch of updates
Revision 1.37 2003/08/20 17:48:49 peter
* fixed stackalloc to not allocate localst.datasize twice
* order of stackalloc code fixed for implicit init/final
Revision 1.36 2003/07/06 17:58:22 peter
* framepointer fixes for sparc
* parent framepointer code more generic
Revision 1.35 2003/06/03 13:01:59 daniel
* Register allocator finished
Revision 1.34 2003/05/17 13:30:08 jonas
* changed tt_persistant to tt_persistent :)
* tempcreatenode now doesn't accept a boolean anymore for persistent
temps, but a ttemptype, so you can also create ansistring temps etc
Revision 1.33 2003/05/13 20:13:41 florian
* fixed temp. management for CPUs were the temp. space grows upwards
Revision 1.32 2003/05/12 21:29:59 peter
* extdebug info temp alloc type was wrong
Revision 1.31 2003/04/27 11:21:35 peter
* aktprocdef renamed to current_procdef
* procinfo renamed to current_procinfo
* procinfo will now be stored in current_module so it can be
cleaned up properly
* gen_main_procsym changed to create_main_proc and release_main_proc
to also generate a tprocinfo structure
* fixed unit implicit initfinal
Revision 1.30 2003/04/25 20:59:35 peter
* removed funcretn,funcretsym, function result is now in varsym
and aliases for result and function name are added using absolutesym
* vs_hidden parameter for funcret passed in parameter
* vs_hidden fixes
* writenode changed to printnode and released from extdebug
* -vp option added to generate a tree.log with the nodetree
* nicer printnode for statements, callnode
Revision 1.29 2003/04/23 08:40:39 jonas
* fixed istemp() when tg.direction = 1
Revision 1.28 2003/04/22 09:46:17 peter
* always allocate 4 bytes when 0 bytes are asked
Revision 1.27 2003/03/11 21:46:24 jonas
* lots of new regallocator fixes, both in generic and ppc-specific code
(ppc compiler still can't compile the linux system unit though)
Revision 1.26 2003/02/19 22:00:15 daniel
* Code generator converted to new register notation
- Horribily outdated todo.txt removed
Revision 1.25 2003/02/03 23:10:39 daniel
* Fixed last commit
Revision 1.24 2003/02/03 23:07:39 daniel
* Made gettemp use intended procedure for setting reference
Revision 1.23 2003/01/08 18:43:57 daniel
* Tregister changed into a record
Revision 1.22 2002/12/01 18:58:26 carl
* fix bugs with istemp() was wrong, and every reference was a temp
Revision 1.21 2002/11/24 18:18:04 carl
- remove some unused defines
Revision 1.20 2002/11/17 17:49:08 mazen
+ return_result_reg and function_result_reg are now used, in all plateforms, to pass functions result between called function and its caller. See the explanation of each one
Revision 1.19 2002/11/15 01:58:54 peter
* merged changes from 1.0.7 up to 04-11
- -V option for generating bug report tracing
- more tracing for option parsing
- errors for cdecl and high()
- win32 import stabs
- win32 records<=8 are returned in eax:edx (turned off by default)
- heaptrc update
- more info for temp management in .s file with EXTDEBUG
Revision 1.18 2002/10/11 11:57:43 florian
*** empty log message ***
Revision 1.16 2002/09/07 18:25:00 florian
+ added tcg.direction to allow upwards growing temp areas
i.e. temps with positive index
Revision 1.15 2002/09/01 18:42:50 peter
* reduced level of comment that type is wrong for release
Revision 1.14 2002/09/01 12:14:53 peter
* fixed some wrong levels in extdebug comments
Revision 1.13 2002/08/24 18:35:04 peter
* when reusing a block also update the temptype instead of forcing it
to tt_normal
Revision 1.12 2002/08/23 16:14:49 peter
* tempgen cleanup
* tt_noreuse temp type added that will be used in genentrycode
Revision 1.11 2002/08/17 09:23:44 florian
* first part of procinfo rewrite
Revision 1.10 2002/07/01 18:46:29 peter
* internal linker
* reorganized aasm layer
Revision 1.9 2002/05/18 13:34:21 peter
* readded missing revisions
Revision 1.8 2002/05/16 19:46:45 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.7 2002/05/14 19:34:52 peter
* removed old logs and updated copyright year
Revision 1.6 2002/04/15 19:08:22 carl
+ target_info.size_of_pointer -> pointer_size
+ some cleanup of unused types/variables
Revision 1.5 2002/04/07 13:38:48 carl
+ update documentation
Revision 1.4 2002/04/07 09:17:17 carl
+ documentation
- clean-up
Revision 1.3 2002/04/04 19:06:06 peter
* removed unused units
* use tlocation.size in cg.a_*loc*() routines
Revision 1.2 2002/04/02 17:11:32 peter
* tlocation,treference update
* LOC_CONSTANT added for better constant handling
* secondadd splitted in multiple routines
* location_force_reg added for loading a location to a register
of a specified size
* secondassignment parses now first the right and then the left node
(this is compatible with Kylix). This saves a lot of push/pop especially
with string operations
* adapted some routines to use the new cg methods
Revision 1.1 2002/03/31 20:26:37 jonas
+ a_loadfpu_* and a_loadmm_* methods in tcg
* register allocation is now handled by a class and is mostly processor
independent (+rgobj.pas and i386/rgcpu.pas)
* temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
* some small improvements and fixes to the optimizer
* some register allocation fixes
* some fpuvaroffset fixes in the unary minus node
* push/popusedregisters is now called rg.save/restoreusedregisters and
(for i386) uses temps instead of push/pop's when using -Op3 (that code is
also better optimizable)
* fixed and optimized register saving/restoring for new/dispose nodes
* LOC_FPU locations now also require their "register" field to be set to
R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
- list field removed of the tnode class because it's not used currently
and can cause hard-to-find bugs
}
Reference in New Issue View Git Blame Copy Permalink