paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 13:39:36 +02:00
Code Issues Packages Projects Releases Wiki Activity

* patch from Peter to fix inlining of case statements

Browse Source
This commit is contained in:
Jonas Maebe 2004-11-30 18:13:39 +00:00
parent 24cc110e9f
commit bd04491f50
9 changed files with 340 additions and 346 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/cgobj.pas
View File

@ -57,7 +57,7 @@ unit cgobj;
public
alignment : talignment;
rg : array[tregistertype] of trgobj;
t_times:cardinal;
t_times : longint;
{$ifdef flowgraph}
aktflownode:word;
{$endif}
@ -2047,7 +2047,10 @@ finalization
end.
{
$Log$
Revision 1.186 2004-11-08 21:47:39 florian
Revision 1.187 2004-11-30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.186 2004/11/08 21:47:39 florian
* better code generation for copying of open arrays
Revision 1.185 2004/11/08 20:23:29 florian

25
compiler/i386/n386set.pas
View File

@ -34,8 +34,8 @@ interface
ti386casenode = class(tcgcasenode)
procedure optimizevalues(var max_linear_list:aint;var max_dist:aword);override;
function has_jumptable : boolean;override;
procedure genjumptable(hp : pcaserecord;min_,max_ : aint);override;
procedure genlinearlist(hp : pcaserecord);override;
procedure genjumptable(hp : pcaselabel;min_,max_ : aint);override;
procedure genlinearlist(hp : pcaselabel);override;
end;
@ -77,7 +77,7 @@ implementation
end;
procedure ti386casenode.genjumptable(hp : pcaserecord;min_,max_ : aint);
procedure ti386casenode.genjumptable(hp : pcaselabel;min_,max_ : aint);
var
table : tasmlabel;
last : TConstExprInt;
@ -85,7 +85,7 @@ implementation
href : treference;
jumpsegment : TAAsmOutput;
procedure genitem(t : pcaserecord);
procedure genitem(t : pcaselabel);
var
i : aint;
begin
@ -95,7 +95,7 @@ implementation
for i:=last+1 to t^._low-1 do
jumpSegment.concat(Tai_const.Create_sym(elselabel));
for i:=t^._low to t^._high do
jumpSegment.concat(Tai_const.Create_sym(t^.statement));
jumpSegment.concat(Tai_const.Create_sym(blocklabel(t^.blockid)));
last:=t^._high;
if assigned(t^.greater) then
genitem(t^.greater);
@ -133,14 +133,14 @@ implementation
end;
procedure ti386casenode.genlinearlist(hp : pcaserecord);
procedure ti386casenode.genlinearlist(hp : pcaselabel);
var
first : boolean;
lastrange : boolean;
last : TConstExprInt;
cond_lt,cond_le : tresflags;
procedure genitem(t : pcaserecord);
procedure genitem(t : pcaselabel);
begin
if assigned(t^.less) then
genitem(t^.less);
@ -152,11 +152,11 @@ implementation
if t^._low=t^._high then
begin
if t^._low-last=0 then
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,0,hregister,t^.statement)
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,0,hregister,blocklabel(t^.blockid))
else
begin
cg.a_op_const_reg(exprasmlist, OP_SUB, opsize, aint(t^._low-last), hregister);
cg.a_jmp_flags(exprasmlist,F_E,t^.statement);
cg.a_jmp_flags(exprasmlist,F_E,blocklabel(t^.blockid));
end;
last:=t^._low;
lastrange:=false;
@ -188,7 +188,7 @@ implementation
{we need to use A_SUB, because A_DEC does not set the correct flags, therefor
using a_op_const_reg(OP_SUB) is not possible }
emit_const_reg(A_SUB,TCGSize2OpSize[opsize],aint(t^._high-t^._low),hregister);
cg.a_jmp_flags(exprasmlist,cond_le,t^.statement);
cg.a_jmp_flags(exprasmlist,cond_le,blocklabel(t^.blockid));
last:=t^._high;
lastrange:=true;
end;
@ -226,7 +226,10 @@ begin
end.
{
$Log$
Revision 1.76 2004-06-20 08:55:31 florian
Revision 1.77 2004-11-30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.76 2004/06/20 08:55:31 florian
* logs truncated
Revision 1.75 2004/06/16 20:07:10 florian

2
compiler/msg/errore.msg
View File

@ -743,7 +743,7 @@ parser_e_cant_publish_that_property=03134_E_That kind of property can't be publi
% Properties in a \var{published} section cannot be array properties.
% they must be moved to public sections. Properties in a \var{published}
% section must be an ordinal type, a real type, strings or sets.
parser_e_empty_import_name=03136_W_An import name is required
parser_e_empty_import_name=03136_E_An import name is required
% Some targets need a name for the imported procedure or a \var{cdecl} specifier
parser_e_division_by_zero=03138_E_Division by zero
% There is a divsion by zero encounted

2
compiler/msgtxt.inc
View File

@ -228,7 +228,7 @@ const msgtxt : array[0..000157,1..240] of char=(
'03132_E_The default value of a property must be constant'#000+
'03133_E_Symb','ol can'#039't be published, can be only a class'#000+
'03134_E_That kind of property can'#039't be published'#000+
'03136_W_An import name is required'#000+
'03136_E_An import name is required'#000+
'03138_E_Division by zero'#000+
'03139_E_Invalid floating point operation'#000+
'03140_E_Upper bound of range is less than lower',' bound'#000+

195
compiler/ncgset.pas
View File

@ -2,7 +2,7 @@
$Id$
Copyright (c) 1998-2002 by Florian Klaempfl and Carl Eric Codere
Generate generic assembler for in set/case nodes
Generate generic assembler for in set/case labels
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
@ -73,12 +73,12 @@ interface
{ has the implementation jumptable support }
min_label : tconstexprint;
function blocklabel(id:longint):tasmlabel;
procedure optimizevalues(var max_linear_list:aint;var max_dist:aword);virtual;
function has_jumptable : boolean;virtual;
procedure genjumptable(hp : pcaserecord;min_,max_ : aint); virtual;
procedure genlinearlist(hp : pcaserecord); virtual;
procedure genlinearcmplist(hp : pcaserecord); virtual;
procedure gentreejmp(p : pcaserecord);
procedure genjumptable(hp : pcaselabel;min_,max_ : aint); virtual;
procedure genlinearlist(hp : pcaselabel); virtual;
procedure genlinearcmplist(hp : pcaselabel); virtual;
end;
@ -135,8 +135,6 @@ implementation
procedure tcginnode.emit_bit_test_reg_reg(list : taasmoutput;
bitsize: tcgsize; bitnumber,value : tregister;
ressize: tcgsize; res :tregister);
var
newres: tregister;
begin
{ first make sure that the bit number is modulo 32 }
@ -473,6 +471,14 @@ implementation
TCGCASENODE
*****************************************************************************}
function tcgcasenode.blocklabel(id:longint):tasmlabel;
begin
if not assigned(blocks[id]) then
internalerror(200411301);
result:=pcaseblock(blocks[id])^.blocklabel;
end;
procedure tcgcasenode.optimizevalues(var max_linear_list:aint;var max_dist:aword);
begin
{ no changes by default }
@ -486,20 +492,20 @@ implementation
end;
procedure tcgcasenode.genjumptable(hp : pcaserecord;min_,max_ : aint);
procedure tcgcasenode.genjumptable(hp : pcaselabel;min_,max_ : aint);
begin
internalerror(200209161);
end;
procedure tcgcasenode.genlinearlist(hp : pcaserecord);
procedure tcgcasenode.genlinearlist(hp : pcaselabel);
var
first : boolean;
last : TConstExprInt;
scratch_reg: tregister;
procedure genitem(t : pcaserecord);
procedure genitem(t : pcaselabel);
procedure gensub(value:aint);
begin
@ -520,11 +526,11 @@ implementation
if t^._low=t^._high then
begin
if t^._low-last=0 then
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,0,hregister,t^.statement)
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,0,hregister,blocklabel(t^.blockid))
else
begin
gensub(aint(t^._low-last));
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,aint(t^._low-last),scratch_reg,t^.statement);
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,aint(t^._low-last),scratch_reg,blocklabel(t^.blockid));
end;
last:=t^._low;
end
@ -548,7 +554,7 @@ implementation
cg.a_cmp_const_reg_label(exprasmlist, opsize,jmp_lt,aint(t^._low-last),scratch_reg,elselabel);
end;
gensub(aint(t^._high-t^._low));
cg.a_cmp_const_reg_label(exprasmlist, opsize,jmp_le,aint(t^._high-t^._low),scratch_reg,t^.statement);
cg.a_cmp_const_reg_label(exprasmlist, opsize,jmp_le,aint(t^._high-t^._low),scratch_reg,blocklabel(t^.blockid));
last:=t^._high;
end;
first:=false;
@ -571,13 +577,13 @@ implementation
end;
procedure tcgcasenode.genlinearcmplist(hp : pcaserecord);
procedure tcgcasenode.genlinearcmplist(hp : pcaselabel);
var
last : TConstExprInt;
lastwasrange: boolean;
procedure genitem(t : pcaserecord);
procedure genitem(t : pcaselabel);
{$ifndef cpu64bit}
var
@ -594,13 +600,13 @@ implementation
begin
objectlibrary.getlabel(l1);
cg.a_cmp_const_reg_label(exprasmlist, OS_32, OC_NE, aint(hi(int64(t^._low))),hregister2,l1);
cg.a_cmp_const_reg_label(exprasmlist, OS_32, OC_EQ, aint(lo(int64(t^._low))),hregister, t^.statement);
cg.a_cmp_const_reg_label(exprasmlist, OS_32, OC_EQ, aint(lo(int64(t^._low))),hregister, blocklabel(t^.blockid));
cg.a_label(exprasmlist,l1);
end
else
{$endif cpu64bit}
begin
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ, aint(t^._low),hregister, t^.statement);
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ, aint(t^._low),hregister, blocklabel(t^.blockid));
end;
{ Reset last here, because we've only checked for one value and need to compare
for the next range both the lower and upper bound }
@ -637,16 +643,16 @@ implementation
begin
objectlibrary.getlabel(l1);
cg.a_cmp_const_reg_label(exprasmlist, OS_32, jmp_lt, aint(hi(int64(t^._high))), hregister2,
t^.statement);
blocklabel(t^.blockid));
cg.a_cmp_const_reg_label(exprasmlist, OS_32, jmp_gt, aint(hi(int64(t^._high))), hregister2,
l1);
cg.a_cmp_const_reg_label(exprasmlist, OS_32, OC_BE, aint(lo(int64(t^._high))), hregister, t^.statement);
cg.a_cmp_const_reg_label(exprasmlist, OS_32, OC_BE, aint(lo(int64(t^._high))), hregister, blocklabel(t^.blockid));
cg.a_label(exprasmlist,l1);
end
else
{$endif cpu64bit}
begin
cg.a_cmp_const_reg_label(exprasmlist, opsize, jmp_le, aint(t^._high), hregister, t^.statement);
cg.a_cmp_const_reg_label(exprasmlist, opsize, jmp_le, aint(t^._high), hregister, blocklabel(t^.blockid));
end;
last:=t^._high;
@ -664,48 +670,6 @@ implementation
end;
procedure tcgcasenode.gentreejmp(p : pcaserecord);
var
lesslabel,greaterlabel : tasmlabel;
begin
cg.a_label(exprasmlist,p^._at);
{ calculate labels for left and right }
if (p^.less=nil) then
lesslabel:=elselabel
else
lesslabel:=p^.less^._at;
if (p^.greater=nil) then
greaterlabel:=elselabel
else
greaterlabel:=p^.greater^._at;
{ calculate labels for left and right }
{ no range label: }
if p^._low=p^._high then
begin
if greaterlabel=lesslabel then
begin
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_NE,p^._low,hregister, lesslabel);
end
else
begin
cg.a_cmp_const_reg_label(exprasmlist,opsize, jmp_lt,p^._low,hregister, lesslabel);
cg.a_cmp_const_reg_label(exprasmlist,opsize, jmp_gt,p^._low,hregister, greaterlabel);
end;
cg.a_jmp_always(exprasmlist,p^.statement);
end
else
begin
cg.a_cmp_const_reg_label(exprasmlist,opsize,jmp_lt,p^._low, hregister, lesslabel);
cg.a_cmp_const_reg_label(exprasmlist,opsize,jmp_gt,p^._high,hregister, greaterlabel);
cg.a_jmp_always(exprasmlist,p^.statement);
end;
if assigned(p^.less) then
gentreejmp(p^.less);
if assigned(p^.greater) then
gentreejmp(p^.greater);
end;
procedure ReLabel(var p:tasmsymbol);
begin
if p.defbind = AB_LOCAL then
@ -718,44 +682,26 @@ implementation
end;
procedure relabelcaserecord(p : pcaserecord);
begin
Relabel(p^.statement);
Relabel(p^._at);
if assigned(p^.greater) then
relabelcaserecord(p^.greater);
if assigned(p^.less) then
relabelcaserecord(p^.less);
end;
procedure tcgcasenode.pass_2;
var
i : longint;
lv,hv,
max_label: tconstexprint;
labels : aint;
labelcnt : aint;
max_linear_list : aint;
otl, ofl: tasmlabel;
isjump : boolean;
max_dist,
dist : aword;
hp : tstatementnode;
relabeling: boolean;
begin
location_reset(location,LOC_VOID,OS_NO);
{ Relabel for inlining? }
relabeling := false;
if assigned(nodes) and
(nodes^.statement.getrefs <> 0) then
begin
objectlibrary.CreateUsedAsmSymbolList;
relabelcaserecord(nodes);
relabeling := true;
end;
{ Allocate labels }
objectlibrary.getlabel(endlabel);
objectlibrary.getlabel(elselabel);
for i:=0 to blocks.count-1 do
objectlibrary.getlabel(pcaseblock(blocks[i])^.blocklabel);
with_sign:=is_signed(left.resulttype.def);
if with_sign then
begin
@ -769,6 +715,7 @@ implementation
jmp_lt:=OC_B;
jmp_le:=OC_BE;
end;
{ save current truelabel and falselabel }
isjump:=false;
if left.location.loc=LOC_JUMP then
@ -801,15 +748,15 @@ implementation
{ we need the min_label always to choose between }
{ cmps and subs/decs }
min_label:=case_get_min(nodes);
min_label:=case_get_min(labels);
{ Generate the jumps }
{$ifdef OLDREGVARS}
load_all_regvars(exprasmlist);
{$endif OLDREGVARS}
{ now generate the jumps }
{$ifndef cpu64bit}
if opsize in [OS_64,OS_S64] then
genlinearcmplist(nodes)
genlinearcmplist(labels)
else
{$endif cpu64bit}
begin
@ -822,8 +769,8 @@ implementation
{ moreover can the size only be appro- }
{ ximated as it is not known if rel8, }
{ rel16 or rel32 jumps are used }
max_label:=case_get_max(nodes);
labels:=case_count_labels(nodes);
max_label:=case_get_max(labels);
labelcnt:=case_count_labels(labels);
{ can we omit the range check of the jump table ? }
getrange(left.resulttype.def,lv,hv);
jumptable_no_range:=(lv=min_label) and (hv=max_label);
@ -844,17 +791,17 @@ implementation
if cs_littlesize in aktglobalswitches then
begin
if has_jumptable and
not((labels<=2) or
not((labelcnt<=2) or
((max_label-min_label)<0) or
((max_label-min_label)>3*labels)) then
((max_label-min_label)>3*labelcnt)) then
begin
{ if the labels less or more a continuum then }
genjumptable(nodes,min_label,max_label);
genjumptable(labels,min_label,max_label);
end
else
begin
{ a linear list is always smaller than a jump tree }
genlinearlist(nodes);
genlinearlist(labels);
end;
end
else
@ -868,55 +815,39 @@ implementation
{ allow processor specific values }
optimizevalues(max_linear_list,max_dist);
if (labels<=max_linear_list) then
genlinearlist(nodes)
if (labelcnt<=max_linear_list) then
genlinearlist(labels)
else
begin
if (has_jumptable) and
(dist<max_dist) then
genjumptable(nodes,min_label,max_label)
(dist<max_dist) and
(min_label>=low(aint)) and
(max_label<=high(aint)) then
genjumptable(labels,min_label,max_label)
else
begin
{
This one expects that the case labels are a
perfectly balanced tree, which is not the case
very often -> generates really bad code (JM)
if labels>16 then
gentreejmp(nodes)
else
}
genlinearlist(nodes);
end;
genlinearlist(labels);
end;
end;
end
else
{ it's always not bad }
genlinearlist(nodes);
genlinearlist(labels);
end;
{ now generate the instructions }
hp:=tstatementnode(right);
while assigned(hp) do
{ generate the instruction blocks }
for i:=0 to blocks.count-1 do
begin
{ relabel when inlining }
if relabeling then
begin
if hp.left.nodetype<>labeln then
internalerror(200211261);
Relabel(tlabelnode(hp.left).labelnr);
end;
secondpass(hp.left);
cg.a_label(exprasmlist,pcaseblock(blocks[i])^.blocklabel);
secondpass(pcaseblock(blocks[i])^.statement);
{ don't come back to case line }
aktfilepos:=exprasmList.getlasttaifilepos^;
{$ifdef OLDREGVARS}
load_all_regvars(exprasmlist);
{$endif OLDREGVARS}
cg.a_jmp_always(exprasmlist,endlabel);
hp:=tstatementnode(hp.right);
end;
cg.a_label(exprasmlist,elselabel);
{ ...and the else block }
cg.a_label(exprasmlist,elselabel);
if assigned(elseblock) then
begin
secondpass(elseblock);
@ -926,14 +857,9 @@ implementation
end;
cg.a_label(exprasmlist,endlabel);
{ Remove relabels for inlining }
if relabeling and
assigned(nodes) then
begin
{ restore used symbols }
objectlibrary.UsedAsmSymbolListResetAltSym;
objectlibrary.DestroyUsedAsmSymbolList;
end;
{ Reset labels }
for i:=0 to blocks.count-1 do
pcaseblock(blocks[i])^.blocklabel:=nil;
end;
@ -944,7 +870,10 @@ begin
end.
{
$Log$
Revision 1.70 2004-10-31 21:45:03 peter
Revision 1.71 2004-11-30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.70 2004/10/31 21:45:03 peter
* generic tlocation
* move tlocation to cgutils

338
compiler/nset.pas
View File

@ -27,27 +27,29 @@ unit nset;
interface
uses
cclasses,
node,globtype,globals,
aasmbase,aasmtai,symtype;
type
pcaserecord = ^tcaserecord;
tcaserecord = record
pcaselabel = ^tcaselabel;
tcaselabel = record
{ range }
_low,_high : TConstExprInt;
{ only used by gentreejmp }
_at : tasmlabel;
{ label of instruction }
statement : tasmlabel;
{ is this the first of an case entry, needed to release statement
label (PFV) }
firstlabel : boolean;
_low,
_high : TConstExprInt;
{ unique blockid }
blockid : longint;
{ left and right tree node }
less,greater : pcaserecord;
less,
greater : pcaselabel;
end;
pcaseblock = ^tcaseblock;
tcaseblock = record
{ label (only used in pass_2) }
blocklabel : tasmlabel;
{ instructions }
statement : tnode;
end;
tsetelementnode = class(tbinarynode)
@ -71,10 +73,11 @@ interface
end;
trangenodeclass = class of trangenode;
tcasenode = class(tbinarynode)
nodes : pcaserecord;
tcasenode = class(tunarynode)
labels : pcaselabel;
blocks : tlist;
elseblock : tnode;
constructor create(l,r : tnode;n : pcaserecord);virtual;
constructor create(l:tnode);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
procedure ppuwrite(ppufile:tcompilerppufile);override;
@ -85,6 +88,9 @@ interface
function det_resulttype:tnode;override;
function pass_1 : tnode;override;
function docompare(p: tnode): boolean; override;
procedure addlabel(blockid:longint;l,h : TConstExprInt);
procedure addblock(blockid:longint;instr:tnode);
procedure addelseblock(instr:tnode);
end;
tcasenodeclass = class of tcasenode;
@ -95,21 +101,20 @@ interface
ccasenode : tcasenodeclass;
{ counts the labels }
function case_count_labels(root : pcaserecord) : longint;
function case_count_labels(root : pcaselabel) : longint;
{ searches the highest label }
{$ifdef int64funcresok}
function case_get_max(root : pcaserecord) : tconstexprint;
function case_get_max(root : pcaselabel) : tconstexprint;
{$else int64funcresok}
function case_get_max(root : pcaserecord) : longint;
function case_get_max(root : pcaselabel) : longint;
{$endif int64funcresok}
{ searches the lowest label }
{$ifdef int64funcresok}
function case_get_min(root : pcaserecord) : tconstexprint;
function case_get_min(root : pcaselabel) : tconstexprint;
{$else int64funcresok}
function case_get_min(root : pcaserecord) : longint;
function case_get_min(root : pcaselabel) : longint;
{$endif int64funcresok}
function gencasenode(l,r : tnode;nodes : pcaserecord) : tnode;
implementation
@ -120,15 +125,6 @@ implementation
htypechk,pass_1,
nbas,ncnv,ncon,nld,cgobj,cgbase;
function gencasenode(l,r : tnode;nodes : pcaserecord) : tnode;
var
t : tnode;
begin
t:=ccasenode.create(l,r,nodes);
gencasenode:=t;
end;
{*****************************************************************************
TSETELEMENTNODE
@ -376,11 +372,11 @@ implementation
Case Helpers
*****************************************************************************}
function case_count_labels(root : pcaserecord) : longint;
function case_count_labels(root : pcaselabel) : longint;
var
_l : longint;
procedure count(p : pcaserecord);
procedure count(p : pcaselabel);
begin
inc(_l);
if assigned(p^.less) then
@ -397,12 +393,12 @@ implementation
{$ifdef int64funcresok}
function case_get_max(root : pcaserecord) : tconstexprint;
function case_get_max(root : pcaselabel) : tconstexprint;
{$else int64funcresok}
function case_get_max(root : pcaserecord) : longint;
function case_get_max(root : pcaselabel) : longint;
{$endif int64funcresok}
var
hp : pcaserecord;
hp : pcaselabel;
begin
hp:=root;
while assigned(hp^.greater) do
@ -412,12 +408,12 @@ implementation
{$ifdef int64funcresok}
function case_get_min(root : pcaserecord) : tconstexprint;
function case_get_min(root : pcaselabel) : tconstexprint;
{$else int64funcresok}
function case_get_min(root : pcaserecord) : longint;
function case_get_min(root : pcaselabel) : longint;
{$endif int64funcresok}
var
hp : pcaserecord;
hp : pcaselabel;
begin
hp:=root;
while assigned(hp^.less) do
@ -425,7 +421,7 @@ implementation
case_get_min:=hp^._low;
end;
procedure deletecaselabels(p : pcaserecord);
procedure deletecaselabels(p : pcaselabel);
begin
if assigned(p^.greater) then
@ -435,31 +431,29 @@ implementation
dispose(p);
end;
function copycaserecord(p : pcaserecord) : pcaserecord;
function copycaselabel(p : pcaselabel) : pcaselabel;
var
n : pcaserecord;
n : pcaselabel;
begin
new(n);
n^:=p^;
if assigned(p^.greater) then
n^.greater:=copycaserecord(p^.greater);
n^.greater:=copycaselabel(p^.greater);
if assigned(p^.less) then
n^.less:=copycaserecord(p^.less);
copycaserecord:=n;
n^.less:=copycaselabel(p^.less);
copycaselabel:=n;
end;
procedure ppuwritecaserecord(ppufile:tcompilerppufile;p : pcaserecord);
procedure ppuwritecaselabel(ppufile:tcompilerppufile;p : pcaselabel);
var
b : byte;
begin
ppufile.putexprint(p^._low);
ppufile.putexprint(p^._high);
ppufile.putasmsymbol(p^._at);
ppufile.putasmsymbol(p^.statement);
ppufile.putbyte(byte(p^.firstlabel));
ppufile.putlongint(p^.blockid);
b:=0;
if assigned(p^.greater) then
b:=b or 1;
@ -467,44 +461,31 @@ implementation
b:=b or 2;
ppufile.putbyte(b);
if assigned(p^.greater) then
ppuwritecaserecord(ppufile,p^.greater);
ppuwritecaselabel(ppufile,p^.greater);
if assigned(p^.less) then
ppuwritecaserecord(ppufile,p^.less);
ppuwritecaselabel(ppufile,p^.less);
end;
function ppuloadcaserecord(ppufile:tcompilerppufile):pcaserecord;
function ppuloadcaselabel(ppufile:tcompilerppufile):pcaselabel;
var
b : byte;
p : pcaserecord;
p : pcaselabel;
begin
new(p);
p^._low:=ppufile.getexprint;
p^._high:=ppufile.getexprint;
p^._at:=tasmlabel(ppufile.getasmsymbol);
p^.statement:=tasmlabel(ppufile.getasmsymbol);
p^.firstlabel:=boolean(ppufile.getbyte);
p^.blockid:=ppufile.getlongint;
b:=ppufile.getbyte;
if (b and 1)=1 then
p^.greater:=ppuloadcaserecord(ppufile)
p^.greater:=ppuloadcaselabel(ppufile)
else
p^.greater:=nil;
if (b and 2)=2 then
p^.less:=ppuloadcaserecord(ppufile)
p^.less:=ppuloadcaselabel(ppufile)
else
p^.less:=nil;
ppuloadcaserecord:=p;
end;
procedure ppuderefcaserecord(p : pcaserecord);
begin
objectlibrary.derefasmsymbol(tasmsymbol(p^._at));
objectlibrary.derefasmsymbol(tasmsymbol(p^.statement));
if assigned(p^.greater) then
ppuderefcaserecord(p^.greater);
if assigned(p^.less) then
ppuderefcaserecord(p^.less);
ppuloadcaselabel:=p;
end;
@ -512,54 +493,80 @@ implementation
TCASENODE
*****************************************************************************}
constructor tcasenode.create(l,r : tnode;n : pcaserecord);
constructor tcasenode.create(l:tnode);
begin
inherited create(casen,l,r);
nodes:=n;
inherited create(casen,l);
labels:=nil;
blocks:=tlist.create;
elseblock:=nil;
set_file_line(l);
end;
destructor tcasenode.destroy;
var
i : longint;
hp : pcaseblock;
begin
elseblock.free;
deletecaselabels(nodes);
deletecaselabels(labels);
for i:=0 to blocks.count-1 do
begin
pcaseblock(blocks[i])^.statement.free;
hp:=pcaseblock(blocks[i]);
dispose(hp);
end;
inherited destroy;
end;
constructor tcasenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
var
cnt,i : longint;
begin
inherited ppuload(t,ppufile);
elseblock:=ppuloadnode(ppufile);
nodes:=ppuloadcaserecord(ppufile);
cnt:=ppufile.getlongint();
blocks:=tlist.create;
for i:=0 to cnt-1 do
addblock(i,ppuloadnode(ppufile));
labels:=ppuloadcaselabel(ppufile);
end;
procedure tcasenode.ppuwrite(ppufile:tcompilerppufile);
var
i : longint;
begin
inherited ppuwrite(ppufile);
ppuwritenode(ppufile,elseblock);
ppuwritecaserecord(ppufile,nodes);
ppufile.putlongint(blocks.count);
for i:=0 to blocks.count-1 do
ppuwritenode(ppufile,pcaseblock(blocks[i])^.statement);
ppuwritecaselabel(ppufile,labels);
end;
procedure tcasenode.buildderefimpl;
var
i : integer;
begin
inherited buildderefimpl;
if assigned(elseblock) then
elseblock.buildderefimpl;
{ppubuildderefimplcaserecord(nodes);}
for i:=0 to blocks.count-1 do
pcaseblock(blocks[i])^.statement.buildderefimpl;
end;
procedure tcasenode.derefimpl;
var
i : integer;
begin
inherited derefimpl;
if assigned(elseblock) then
elseblock.derefimpl;
ppuderefcaserecord(nodes);
for i:=0 to blocks.count-1 do
pcaseblock(blocks[i])^.statement.derefimpl;
end;
@ -574,7 +581,8 @@ implementation
function tcasenode.pass_1 : tnode;
var
old_t_times : longint;
hp : tstatementnode;
hp : tnode;
i : integer;
begin
result:=nil;
expectloc:=LOC_VOID;
@ -591,39 +599,36 @@ implementation
{ walk through all instructions }
{ estimates the repeat of each instruction }
{ estimates the repeat of each instruction }
old_t_times:=cg.t_times;
if not(cs_littlesize in aktglobalswitches) then
begin
cg.t_times:=cg.t_times div case_count_labels(nodes);
cg.t_times:=cg.t_times div case_count_labels(labels);
if cg.t_times<1 then
cg.t_times:=1;
end;
{ first case }
hp:=tstatementnode(right);
while assigned(hp) do
for i:=0 to blocks.count-1 do
begin
firstpass(hp.left);
firstpass(pcaseblock(blocks[i])^.statement);
{ searchs max registers }
if hp.left.registersint>registersint then
registersint:=hp.left.registersint;
if hp.left.registersfpu>registersfpu then
registersfpu:=hp.left.registersfpu;
hp:=pcaseblock(blocks[i])^.statement;
if hp.registersint>registersint then
registersint:=hp.registersint;
if hp.registersfpu>registersfpu then
registersfpu:=hp.registersfpu;
{$ifdef SUPPORT_MMX}
if hp.left.registersmmx>registersmmx then
registersmmx:=hp.left.registersmmx;
if hp.registersmmx>registersmmx then
registersmmx:=hp.registersmmx;
{$endif SUPPORT_MMX}
hp:=tstatementnode(hp.right);
end;
{ may be handle else tree }
if assigned(elseblock) then
begin
firstpass(elseblock);
if codegenerror then
exit;
if registersint<elseblock.registersint then
registersint:=elseblock.registersint;
if registersfpu<elseblock.registersfpu then
@ -638,26 +643,39 @@ implementation
{ there is one register required for the case expression }
{ for 64 bit ints we cheat: the high dword is stored in EDI }
{ so we don't need an extra register }
if registersint<1 then registersint:=1;
if registersint<1 then
registersint:=1;
end;
function tcasenode.getcopy : tnode;
var
p : tcasenode;
n : tcasenode;
i : longint;
begin
p:=tcasenode(inherited getcopy);
n:=tcasenode(inherited getcopy);
if assigned(elseblock) then
p.elseblock:=elseblock.getcopy
n.elseblock:=elseblock.getcopy
else
p.elseblock:=nil;
if assigned(nodes) then
p.nodes:=copycaserecord(nodes)
n.elseblock:=nil;
if assigned(labels) then
n.labels:=copycaselabel(labels)
else
p.nodes:=nil;
getcopy:=p;
n.labels:=nil;
if assigned(blocks) then
begin
n.blocks:=tlist.create;
for i:=0 to blocks.count-1 do
begin
if not assigned(blocks[i]) then
internalerror(200411302);
n.addblock(i,pcaseblock(blocks[i])^.statement.getcopy);
end;
end
else
n.labels:=nil;
getcopy:=n;
end;
procedure tcasenode.insertintolist(l : tnodelist);
@ -665,27 +683,116 @@ implementation
begin
end;
function casenodesequal(n1,n2: pcaserecord): boolean;
function caselabelsequal(n1,n2: pcaselabel): boolean;
begin
casenodesequal :=
result :=
(not assigned(n1) and not assigned(n2)) or
(assigned(n1) and assigned(n2) and
(n1^._low = n2^._low) and
(n1^._high = n2^._high) and
{ the rest of the fields don't matter for equality (JM) }
casenodesequal(n1^.less,n2^.less) and
casenodesequal(n1^.greater,n2^.greater))
caselabelsequal(n1^.less,n2^.less) and
caselabelsequal(n1^.greater,n2^.greater))
end;
function caseblocksequal(b1,b2:tlist): boolean;
var
i : longint;
begin
result:=false;
if b1.count<>b2.count then
exit;
for i:=0 to b1.count-1 do
begin
if not pcaseblock(b1[i])^.statement.isequal(pcaseblock(b2[i])^.statement) then
exit;
end;
result:=true;
end;
function tcasenode.docompare(p: tnode): boolean;
begin
docompare :=
result :=
inherited docompare(p) and
casenodesequal(nodes,tcasenode(p).nodes) and
caselabelsequal(labels,tcasenode(p).labels) and
caseblocksequal(blocks,tcasenode(p).blocks) and
elseblock.isequal(tcasenode(p).elseblock);
end;
procedure tcasenode.addblock(blockid:longint;instr:tnode);
var
hcaseblock : pcaseblock;
begin
new(hcaseblock);
fillchar(hcaseblock^,sizeof(hcaseblock^),0);
hcaseblock^.statement:=instr;
if blockid>=blocks.count then
blocks.count:=blockid+1;
blocks[blockid]:=hcaseblock;
end;
procedure tcasenode.addelseblock(instr:tnode);
begin
elseblock:=instr;
end;
procedure tcasenode.addlabel(blockid:longint;l,h : TConstExprInt);
var
hcaselabel : pcaselabel;
function insertlabel(var p : pcaselabel):pcaselabel;
begin
if p=nil then
begin
p:=hcaselabel;
result:=p;
end
else
if (p^._low>hcaselabel^._low) and
(p^._low>hcaselabel^._high) then
begin
if (hcaselabel^.blockid = p^.blockid) and
(p^._low = hcaselabel^._high + 1) then
begin
p^._low := hcaselabel^._low;
dispose(hcaselabel);
result:=p;
end
else
result:=insertlabel(p^.less)
end
else
if (p^._high<hcaselabel^._low) and
(p^._high<hcaselabel^._high) then
begin
if (hcaselabel^.blockid = p^.blockid) and
(p^._high+1 = hcaselabel^._low) then
begin
p^._high := hcaselabel^._high;
dispose(hcaselabel);
result:=p;
end
else
result:=insertlabel(p^.greater);
end
else
Message(parser_e_double_caselabel);
end;
begin
new(hcaselabel);
fillchar(hcaselabel^,sizeof(tcaselabel),0);
hcaselabel^.blockid:=blockid;
hcaselabel^._low:=l;
hcaselabel^._high:=h;
insertlabel(labels);
end;
begin
csetelementnode:=tsetelementnode;
cinnode:=tinnode;
@ -694,7 +801,10 @@ begin
end.
{
$Log$
Revision 1.55 2004-06-20 08:55:29 florian
Revision 1.56 2004-11-30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.55 2004/06/20 08:55:29 florian
* logs truncated
Revision 1.54 2004/06/16 20:07:09 florian

17
compiler/powerpc/nppcset.pas
View File

@ -33,7 +33,7 @@ interface
tppccasenode = class(tcgcasenode)
protected
procedure genlinearlist(hp : pcaserecord); override;
procedure genlinearlist(hp : pcaselabel); override;
end;
@ -56,13 +56,13 @@ implementation
*****************************************************************************}
procedure tppccasenode.genlinearlist(hp : pcaserecord);
procedure tppccasenode.genlinearlist(hp : pcaselabel);
var
first, lastrange : boolean;
last : TConstExprInt;
procedure genitem(t : pcaserecord);
procedure genitem(t : pcaselabel);
var r:Tregister;
@ -95,10 +95,10 @@ implementation
if t^._low=t^._high then
begin
if t^._low-last=0 then
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,0,hregister,t^.statement)
cg.a_cmp_const_reg_label(exprasmlist, opsize, OC_EQ,0,hregister,blocklabel(t^.blockid))
else
gensub(longint(t^._low-last));
tcgppc(cg).a_jmp_cond(exprasmlist,OC_EQ,t^.statement);
tcgppc(cg).a_jmp_cond(exprasmlist,OC_EQ,blocklabel(t^.blockid));
last:=t^._low;
lastrange := false;
end
@ -124,7 +124,7 @@ implementation
tcgppc(cg).a_jmp_cond(exprasmlist,jmp_lt,elselabel);
end;
gensub(longint(t^._high-t^._low));
tcgppc(cg).a_jmp_cond(exprasmlist,jmp_le,t^.statement);
tcgppc(cg).a_jmp_cond(exprasmlist,jmp_le,blocklabel(t^.blockid));
last:=t^._high;
lastrange := true;
end;
@ -156,7 +156,10 @@ begin
end.
{
$Log$
Revision 1.16 2004-10-25 15:36:47 peter
Revision 1.17 2004-11-30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.16 2004/10/25 15:36:47 peter
* save standard registers moved to tcgobj
Revision 1.15 2004/09/25 14:23:55 peter

93
compiler/pstatmnt.pas
View File

@ -115,65 +115,12 @@ implementation
function case_statement : tnode;
var
{ contains the label number of currently parsed case block }
aktcaselabel : tasmlabel;
firstlabel : boolean;
root : pcaserecord;
{ the typ of the case expression }
casedef : tdef;
procedure newcaselabel(l,h : TConstExprInt;first:boolean);
var
hcaselabel : pcaserecord;
procedure insertlabel(var p : pcaserecord);
begin
if p=nil then p:=hcaselabel
else
if (p^._low>hcaselabel^._low) and
(p^._low>hcaselabel^._high) then
if (hcaselabel^.statement = p^.statement) and
(p^._low = hcaselabel^._high + 1) then
begin
p^._low := hcaselabel^._low;
dispose(hcaselabel);
end
else
insertlabel(p^.less)
else
if (p^._high<hcaselabel^._low) and
(p^._high<hcaselabel^._high) then
if (hcaselabel^.statement = p^.statement) and
(p^._high+1 = hcaselabel^._low) then
begin
p^._high := hcaselabel^._high;
dispose(hcaselabel);
end
else
insertlabel(p^.greater)
else Message(parser_e_double_caselabel);
end;
begin
new(hcaselabel);
hcaselabel^.less:=nil;
hcaselabel^.greater:=nil;
hcaselabel^.statement:=aktcaselabel;
hcaselabel^.firstlabel:=first;
objectlibrary.getlabel(hcaselabel^._at);
hcaselabel^._low:=l;
hcaselabel^._high:=h;
insertlabel(root);
end;
var
code,caseexpr,p,instruc,elseblock : tnode;
blockid : longint;
hl1,hl2 : TConstExprInt;
casedeferror : boolean;
casenode : tcasenode;
begin
consume(_CASE);
caseexpr:=comp_expr(true);
@ -192,14 +139,12 @@ implementation
{ set error flag so no rangechecks are done }
casedeferror:=true;
end;
{ Create casenode }
casenode:=ccasenode.create(caseexpr);
consume(_OF);
root:=nil;
instruc:=nil;
{ Parse all case blocks }
blockid:=0;
repeat
objectlibrary.getlabel(aktcaselabel);
firstlabel:=true;
{ maybe an instruction has more case labels }
repeat
p:=expr;
@ -239,7 +184,7 @@ implementation
end
else
CGMessage(parser_e_case_mismatch);
newcaselabel(hl1,hl2,firstlabel);
casenode.addlabel(blockid,hl1,hl2);
end
else
begin
@ -249,22 +194,21 @@ implementation
hl1:=get_ordinal_value(p);
if not casedeferror then
testrange(casedef,hl1,false);
newcaselabel(hl1,hl1,firstlabel);
casenode.addlabel(blockid,hl1,hl1);
end;
p.free;
if token=_COMMA then
consume(_COMMA)
else
break;
firstlabel:=false;
until false;
consume(_COLON);
{ handles instruction block }
p:=clabelnode.createcase(aktcaselabel,statement);
{ add instruction block }
casenode.addblock(blockid,statement);
{ concats instruction }
instruc:=cstatementnode.create(p,instruc);
{ next block }
inc(blockid);
if not(token in [_ELSE,_OTHERWISE,_END]) then
consume(_SEMICOLON);
@ -274,7 +218,7 @@ implementation
begin
if not try_to_consume(_ELSE) then
consume(_OTHERWISE);
elseblock:=statements_til_end;
casenode.addelseblock(statements_til_end);
end
else
begin
@ -282,11 +226,7 @@ implementation
consume(_END);
end;
code:=ccasenode.create(caseexpr,instruc,root);
tcasenode(code).elseblock:=elseblock;
case_statement:=code;
result:=casenode;
end;
@ -1207,7 +1147,10 @@ implementation
end.
{
$Log$
Revision 1.145 2004-11-21 17:54:59 peter
Revision 1.146 2004-11-30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.145 2004/11/21 17:54:59 peter
* ttempcreatenode.create_reg merged into .create with parameter
whether a register is allowed
* funcret_paraloc renamed to funcretloc

7
compiler/symdef.pas
View File

@ -441,7 +441,7 @@ interface
maxparacount,
minparacount : byte;
{$ifdef i386}
fpu_used : byte; { how many stack fpu must be empty }
fpu_used : longint; { how many stack fpu must be empty }
{$endif i386}
funcretloc : array[tcallercallee] of TLocation;
has_paraloc_info : boolean; { paraloc info is available }
@ -6136,7 +6136,10 @@ implementation
end.
{
$Log$
Revision 1.279 2004-11-22 22:01:19 peter
Revision 1.280 2004-11-30 18:13:39 jonas
* patch from Peter to fix inlining of case statements
Revision 1.279 2004/11/22 22:01:19 peter
* fixed varargs
* replaced dynarray with tlist