paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-11 10:58:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* splitted cgi386

Browse Source
This commit is contained in:
peter 1998-06-05 17:44:10 +00:00
parent acc260ed78
commit 6f4cfe38eb
9 changed files with 6308 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1204
compiler/cg386add.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2197
compiler/cg386cal.pas Normal file
View File

File diff suppressed because it is too large Load Diff

127
compiler/cg386cnv.pas
View File

@ -26,9 +26,13 @@
unit cg386cnv;
interface
uses tree;
uses
tree;
procedure secondtypeconv(var p : ptree);
procedure secondas(var p : ptree);
procedure secondis(var p : ptree);
implementation
@ -37,17 +41,19 @@ implementation
symtable,aasm,i386,
cgi386,cgai386,tgeni386,hcodegen;
{ produces if necessary rangecheckcode }
{*****************************************************************************
SecondTypeConv
*****************************************************************************}
procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
{
produces if necessary rangecheckcode
}
var
hp : preference;
hregister : tregister;
neglabel,poslabel : plabel;
is_register : boolean;
begin
{ convert from p2 to p1 }
{ range check from enums is not made yet !!}
@ -947,10 +953,119 @@ implementation
secondconvert[p^.convtyp](p,p^.left,p^.convtyp)
end;
{*****************************************************************************
SecondIs
*****************************************************************************}
procedure secondis(var p : ptree);
var
pushed : tpushed;
begin
{ save all used registers }
pushusedregisters(pushed,$ff);
secondpass(p^.left);
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=F_NE;
{ push instance to check: }
case p^.left^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
S_L,p^.left^.location.register)));
ungetregister32(p^.left^.location.register);
end;
LOC_MEM,LOC_REFERENCE:
begin
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
S_L,newreference(p^.left^.location.reference))));
del_reference(p^.left^.location.reference);
end;
else internalerror(100);
end;
{ generate type checking }
secondpass(p^.right);
case p^.right^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
S_L,p^.right^.location.register)));
ungetregister32(p^.right^.location.register);
end;
LOC_MEM,LOC_REFERENCE:
begin
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
S_L,newreference(p^.right^.location.reference))));
del_reference(p^.right^.location.reference);
end;
else internalerror(100);
end;
emitcall('DO_IS',true);
exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_B,R_AL,R_AL)));
popusedregisters(pushed);
end;
{*****************************************************************************
SecondAs
*****************************************************************************}
procedure secondas(var p : ptree);
var
pushed : tpushed;
begin
secondpass(p^.left);
{ save all used registers }
pushusedregisters(pushed,$ff);
{ push instance to check: }
case p^.left^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
S_L,p^.left^.location.register)));
LOC_MEM,LOC_REFERENCE:
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
S_L,newreference(p^.left^.location.reference))));
else internalerror(100);
end;
{ we doesn't modifiy the left side, we check only the type }
set_location(p^.location,p^.left^.location);
{ generate type checking }
secondpass(p^.right);
case p^.right^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
exprasmlist^.concat(new(pai386,op_reg(A_PUSH,
S_L,p^.right^.location.register)));
ungetregister32(p^.right^.location.register);
end;
LOC_MEM,LOC_REFERENCE:
begin
exprasmlist^.concat(new(pai386,op_ref(A_PUSH,
S_L,newreference(p^.right^.location.reference))));
del_reference(p^.right^.location.reference);
end;
else internalerror(100);
end;
emitcall('DO_AS',true);
{ restore register, this restores automatically the }
{ result }
popusedregisters(pushed);
end;
end.
{
$Log$
Revision 1.3 1998-06-03 22:48:50 peter
Revision 1.4 1998-06-05 17:44:10 peter
* splitted cgi386
Revision 1.3 1998/06/03 22:48:50 peter
+ wordbool,longbool
* rename bis,von -> high,low
* moved some systemunit loading/creating to psystem.pas

157
compiler/cg386con.pas
View File

@ -23,23 +23,29 @@
unit cg386con;
interface
uses tree;
uses
tree;
procedure secondrealconst(var p : ptree);
procedure secondfixconst(var p : ptree);
procedure secondordconst(var p : ptree);
procedure secondniln(var p : ptree);
procedure secondstringconst(var p : ptree);
procedure secondsetcons(var p : ptree);
procedure secondniln(var p : ptree);
implementation
uses
cobjects,verbose,
symtable,aasm,i386,
hcodegen;
uses
cobjects,verbose,
symtable,aasm,i386,
hcodegen,cgai386,tgeni386,cgi386;
{*****************************************************************************
SecondRealConst
*****************************************************************************}
procedure secondrealconst(var p : ptree);
var
hp1 : pai;
lastlabel : plabel;
@ -96,8 +102,12 @@ implementation
p^.location.reference.symbol:=stringdup(constlabelnb2str(p^.labnumber,constreal));
end;
procedure secondfixconst(var p : ptree);
{*****************************************************************************
SecondFixConst
*****************************************************************************}
procedure secondfixconst(var p : ptree);
begin
{ an fix comma const. behaves as a memory reference }
p^.location.loc:=LOC_MEM;
@ -105,8 +115,12 @@ implementation
p^.location.reference.offset:=p^.valuef;
end;
procedure secondordconst(var p : ptree);
{*****************************************************************************
SecondOrdConst
*****************************************************************************}
procedure secondordconst(var p : ptree);
begin
{ an integer const. behaves as a memory reference }
p^.location.loc:=LOC_MEM;
@ -114,16 +128,12 @@ implementation
p^.location.reference.offset:=p^.value;
end;
procedure secondniln(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=0;
end;
{*****************************************************************************
SecondStringConst
*****************************************************************************}
procedure secondstringconst(var p : ptree);
var
hp1 : pai;
lastlabel : plabel;
@ -186,9 +196,9 @@ implementation
concat_constlabel(lastlabel,conststring);
{$ifdef UseAnsiString}
{$ifdef debug}
{$ifdef debug}
consts^.concat(new(pai_asm_comment,init('Header of ansistring')));
{$endif debug}
{$endif debug}
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(p^.length)));
consts^.concat(new(pai_const,init_32bit(-1)));
@ -209,10 +219,119 @@ implementation
p^.location.loc := LOC_MEM;
end;
{*****************************************************************************
SecondSetCons
*****************************************************************************}
procedure secondsetcons(var p : ptree);
var
l : plabel;
i : longint;
hp : ptree;
href,sref : treference;
{$ifdef TestSmallSet}
smallsetvalue : longint;
hr,hr2 : tregister;
{$endif TestSmallSet}
begin
{ this should be reimplemented for smallsets }
{ differently (PM) }
{ produce constant part }
{$ifdef TestSmallSet}
if psetdef(p^.resulttype)^.settype=smallset then
begin
smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2];
smallsetvalue:=(smallsetvalue*256+p^.constset^[1])*256+p^.constset^[0];
{consts^.concat(new(pai_const,init_32bit(smallsetvalue)));}
hr:=getregister32;
exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L,
smallsetvalue,hr)));
hp:=p^.left;
if assigned(hp) then
begin
while assigned(hp) do
begin
secondpass(hp^.left);
if codegenerror then
exit;
case hp^.left^.location.loc of
LOC_MEM,LOC_REFERENCE :
begin
hr2:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(hp^.left^.location.reference),hr2)));
exprasmlist^.concat(new(pai386,op_reg_reg(A_BTS,S_NO,
hr2,hr)));
ungetregister32(hr2);
end;
LOC_REGISTER,LOC_CREGISTER :
exprasmlist^.concat(new(pai386,op_reg_reg(A_BTS,S_NO,
hp^.left^.location.register,hr)));
else
internalerror(10567);
end;
hp:=hp^.right;
end;
end;
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hr;
end
else
{$endif TestSmallSet}
begin
href.symbol := Nil;
clear_reference(href);
getlabel(l);
stringdispose(p^.location.reference.symbol);
href.symbol:=stringdup(constlabel2str(l,constseta));
concat_constlabel(l,constseta);
for i:=0 to 31 do
consts^.concat(new(pai_const,init_8bit(p^.constset^[i])));
hp:=p^.left;
if assigned(hp) then
begin
sref.symbol:=nil;
gettempofsizereference(32,sref);
concatcopy(href,sref,32,false);
while assigned(hp) do
begin
secondpass(hp^.left);
if codegenerror then
exit;
pushsetelement(hp^.left);
emitpushreferenceaddr(sref);
{ register is save in subroutine }
emitcall('SET_SET_BYTE',true);
hp:=hp^.right;
end;
p^.location.reference:=sref;
end
else
p^.location.reference:=href;
end;
end;
{*****************************************************************************
SecondNilN
*****************************************************************************}
procedure secondniln(var p : ptree);
begin
p^.location.loc:=LOC_MEM;
p^.location.reference.isintvalue:=true;
p^.location.reference.offset:=0;
end;
end.
{
$Log$
Revision 1.2 1998-06-05 16:13:31 pierre
Revision 1.3 1998-06-05 17:44:11 peter
* splitted cgi386
Revision 1.2 1998/06/05 16:13:31 pierre
* fix for real and string consts inside inlined procs
Revision 1.1 1998/05/23 01:21:02 peter

596
compiler/cg386flw.pas Normal file
View File

@ -0,0 +1,596 @@
{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
Generate i386 assembler for nodes that influence the flow
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.
****************************************************************************
}
unit cg386flw;
interface
uses
tree;
procedure second_while_repeatn(var p : ptree);
procedure secondifn(var p : ptree);
procedure secondfor(var p : ptree);
procedure secondexitn(var p : ptree);
procedure secondbreakn(var p : ptree);
procedure secondcontinuen(var p : ptree);
procedure secondgoto(var p : ptree);
procedure secondlabel(var p : ptree);
procedure secondraise(var p : ptree);
procedure secondtryexcept(var p : ptree);
procedure secondtryfinally(var p : ptree);
procedure secondfail(var p : ptree);
implementation
uses
cobjects,verbose,globals,systems,
symtable,aasm,i386,types,
cgi386,cgai386,tgeni386,hcodegen;
{*****************************************************************************
Second_While_RepeatN
*****************************************************************************}
procedure second_while_repeatn(var p : ptree);
var
l1,l2,l3,oldclabel,oldblabel : plabel;
otlabel,oflabel : plabel;
begin
getlabel(l1);
getlabel(l2);
{ arrange continue and breaklabels: }
oldclabel:=aktcontinuelabel;
oldblabel:=aktbreaklabel;
if p^.treetype=repeatn then
begin
emitl(A_LABEL,l1);
aktcontinuelabel:=l1;
aktbreaklabel:=l2;
cleartempgen;
if assigned(p^.right) then
secondpass(p^.right);
otlabel:=truelabel;
oflabel:=falselabel;
truelabel:=l2;
falselabel:=l1;
cleartempgen;
secondpass(p^.left);
maketojumpbool(p^.left);
emitl(A_LABEL,l2);
truelabel:=otlabel;
falselabel:=oflabel;
end
else
begin
{ handling code at the end as it is much more efficient }
emitl(A_JMP,l2);
emitl(A_LABEL,l1);
cleartempgen;
getlabel(l3);
aktcontinuelabel:=l2;
aktbreaklabel:=l3;
if assigned(p^.right) then
secondpass(p^.right);
emitl(A_LABEL,l2);
otlabel:=truelabel;
oflabel:=falselabel;
truelabel:=l1;
falselabel:=l3;
cleartempgen;
secondpass(p^.left);
maketojumpbool(p^.left);
emitl(A_LABEL,l3);
truelabel:=otlabel;
falselabel:=oflabel;
end;
aktcontinuelabel:=oldclabel;
aktbreaklabel:=oldblabel;
end;
{*****************************************************************************
SecondIfN
*****************************************************************************}
procedure secondifn(var p : ptree);
var
hl,otlabel,oflabel : plabel;
begin
otlabel:=truelabel;
oflabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
cleartempgen;
secondpass(p^.left);
maketojumpbool(p^.left);
if assigned(p^.right) then
begin
emitl(A_LABEL,truelabel);
cleartempgen;
secondpass(p^.right);
end;
if assigned(p^.t1) then
begin
if assigned(p^.right) then
begin
getlabel(hl);
emitl(A_JMP,hl);
end;
emitl(A_LABEL,falselabel);
cleartempgen;
secondpass(p^.t1);
if assigned(p^.right) then
emitl(A_LABEL,hl);
end
else
emitl(A_LABEL,falselabel);
if not(assigned(p^.right)) then
emitl(A_LABEL,truelabel);
truelabel:=otlabel;
falselabel:=oflabel;
end;
{*****************************************************************************
SecondFor
*****************************************************************************}
procedure secondfor(var p : ptree);
var
l3,oldclabel,oldblabel : plabel;
omitfirstcomp,temptovalue : boolean;
hs : byte;
temp1 : treference;
hop : tasmop;
cmpreg,cmp32 : tregister;
opsize : topsize;
count_var_is_signed : boolean;
begin
oldclabel:=aktcontinuelabel;
oldblabel:=aktbreaklabel;
getlabel(aktcontinuelabel);
getlabel(aktbreaklabel);
getlabel(l3);
{ could we spare the first comparison ? }
omitfirstcomp:=false;
if p^.right^.treetype=ordconstn then
if p^.left^.right^.treetype=ordconstn then
omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value))
or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value));
{ only calculate reference }
cleartempgen;
secondpass(p^.t2);
if not(simple_loadn) then
Message(cg_e_illegal_count_var);
{ produce start assignment }
cleartempgen;
secondpass(p^.left);
count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype));
hs:=p^.t2^.resulttype^.size;
cmp32:=getregister32;
case hs of
1 : begin
opsize:=S_B;
cmpreg:=reg32toreg8(cmp32);
end;
2 : begin
opsize:=S_W;
cmpreg:=reg32toreg16(cmp32);
end;
4 : begin
opsize:=S_L;
cmpreg:=cmp32;
end;
end;
cleartempgen;
secondpass(p^.right);
{ calculate pointer value and check if changeable and if so }
{ load into temporary variable }
if p^.right^.treetype<>ordconstn then
begin
temp1.symbol:=nil;
gettempofsizereference(hs,temp1);
temptovalue:=true;
if (p^.right^.location.loc=LOC_REGISTER) or
(p^.right^.location.loc=LOC_CREGISTER) then
begin
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,p^.right^.location.register,
newreference(temp1))));
end
else
concatcopy(p^.right^.location.reference,temp1,hs,false);
end
else temptovalue:=false;
if temptovalue then
begin
if p^.t2^.location.loc=LOC_CREGISTER then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
p^.t2^.location.register)));
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference),
cmpreg)));
exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
cmpreg)));
end;
end
else
begin
if not(omitfirstcomp) then
begin
if p^.t2^.location.loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value,
p^.t2^.location.register)))
else
exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value,
newreference(p^.t2^.location.reference))));
end;
end;
if p^.backward then
if count_var_is_signed then
hop:=A_JL
else hop:=A_JB
else
if count_var_is_signed then
hop:=A_JG
else hop:=A_JA;
if not(omitfirstcomp) or temptovalue then
emitl(hop,aktbreaklabel);
emitl(A_LABEL,l3);
{ help register must not be in instruction block }
cleartempgen;
if assigned(p^.t1) then
secondpass(p^.t1);
emitl(A_LABEL,aktcontinuelabel);
{ makes no problems there }
cleartempgen;
{ demand help register again }
cmp32:=getregister32;
case hs of
1 : begin
opsize:=S_B;
cmpreg:=reg32toreg8(cmp32);
end;
2 : begin
opsize:=S_W;
cmpreg:=reg32toreg16(cmp32);
end;
4 : opsize:=S_L;
end;
{ produce comparison and the corresponding }
{ jump }
if temptovalue then
begin
if p^.t2^.location.loc=LOC_CREGISTER then
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
p^.t2^.location.register)));
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference),
cmpreg)));
exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1),
cmpreg)));
end;
end
else
begin
if p^.t2^.location.loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value,
p^.t2^.location.register)))
else
exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value,
newreference(p^.t2^.location.reference))));
end;
if p^.backward then
if count_var_is_signed then
hop:=A_JLE
else
hop :=A_JBE
else
if count_var_is_signed then
hop:=A_JGE
else
hop:=A_JAE;
emitl(hop,aktbreaklabel);
{ according to count direction DEC or INC... }
{ must be after the test because of 0to 255 for bytes !! }
if p^.backward then
hop:=A_DEC
else hop:=A_INC;
if p^.t2^.location.loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_reg(hop,opsize,p^.t2^.location.register)))
else
exprasmlist^.concat(new(pai386,op_ref(hop,opsize,newreference(p^.t2^.location.reference))));
emitl(A_JMP,l3);
{ this is the break label: }
emitl(A_LABEL,aktbreaklabel);
ungetregister32(cmp32);
if temptovalue then
ungetiftemp(temp1);
aktcontinuelabel:=oldclabel;
aktbreaklabel:=oldblabel;
end;
{*****************************************************************************
SecondExitN
*****************************************************************************}
procedure secondexitn(var p : ptree);
var
is_mem : boolean;
{op : tasmop;
s : topsize;}
otlabel,oflabel : plabel;
label
do_jmp;
begin
if assigned(p^.left) then
begin
otlabel:=truelabel;
oflabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
secondpass(p^.left);
case p^.left^.location.loc of
LOC_FPU : goto do_jmp;
LOC_MEM,LOC_REFERENCE : is_mem:=true;
LOC_CREGISTER,
LOC_REGISTER : is_mem:=false;
LOC_FLAGS : begin
exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,R_AL)));
goto do_jmp;
end;
LOC_JUMP : begin
emitl(A_LABEL,truelabel);
exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,1,R_AL)));
emitl(A_JMP,aktexit2label);
exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,R_AL,R_AL)));
goto do_jmp;
end;
else internalerror(2001);
end;
if (procinfo.retdef^.deftype=orddef) then
begin
case porddef(procinfo.retdef)^.typ of
s32bit,u32bit,bool32bit : if is_mem then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),R_EAX)))
else
emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX);
u8bit,s8bit,uchar,bool8bit : if is_mem then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B,
newreference(p^.left^.location.reference),R_AL)))
else
emit_reg_reg(A_MOV,S_B,p^.left^.location.register,R_AL);
s16bit,u16bit,bool16bit : if is_mem then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,
newreference(p^.left^.location.reference),R_AX)))
else
emit_reg_reg(A_MOV,S_W,p^.left^.location.register,R_AX);
end;
end
else
if (procinfo.retdef^.deftype in [pointerdef,enumdef,procvardef]) then
begin
if is_mem then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),R_EAX)))
else
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
p^.left^.location.register,R_EAX)));
end
else
if (procinfo.retdef^.deftype=floatdef) then
begin
if pfloatdef(procinfo.retdef)^.typ=f32bit then
begin
if is_mem then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),R_EAX)))
else
emit_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EAX);
end
else
if is_mem then
floatload(pfloatdef(procinfo.retdef)^.typ,p^.left^.location.reference);
end;
do_jmp:
truelabel:=otlabel;
falselabel:=oflabel;
emitl(A_JMP,aktexit2label);
end
else
begin
emitl(A_JMP,aktexitlabel);
end;
end;
{*****************************************************************************
SecondBreakN
*****************************************************************************}
procedure secondbreakn(var p : ptree);
begin
if aktbreaklabel<>nil then
emitl(A_JMP,aktbreaklabel)
else
Message(cg_e_break_not_allowed);
end;
{*****************************************************************************
SecondContinueN
*****************************************************************************}
procedure secondcontinuen(var p : ptree);
begin
if aktcontinuelabel<>nil then
emitl(A_JMP,aktcontinuelabel)
else
Message(cg_e_continue_not_allowed);
end;
{*****************************************************************************
SecondGoto
*****************************************************************************}
procedure secondgoto(var p : ptree);
begin
emitl(A_JMP,p^.labelnr);
end;
{*****************************************************************************
SecondLabel
*****************************************************************************}
procedure secondlabel(var p : ptree);
begin
emitl(A_LABEL,p^.labelnr);
cleartempgen;
secondpass(p^.left);
end;
{*****************************************************************************
SecondRaise
*****************************************************************************}
procedure secondraise(var p : ptree);
var
a : plabel;
begin
if assigned(p^.left) then
begin
{ generate the address }
if assigned(p^.right) then
begin
secondpass(p^.right);
if codegenerror then
exit;
end
else
begin
getlabel(a);
emitl(A_LABEL,a);
exprasmlist^.concat(new(pai386,
op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(a),0))));
end;
secondpass(p^.left);
if codegenerror then
exit;
case p^.left^.location.loc of
LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,
p^.left^.location.register)));
else Message(sym_e_type_mismatch);
end;
emitcall('DO_RAISE',true);
end
else
emitcall('DO_RERAISE',true);
end;
{*****************************************************************************
SecondTryExcept
*****************************************************************************}
procedure secondtryexcept(var p : ptree);
begin
end;
{*****************************************************************************
SecondTryFinally
*****************************************************************************}
procedure secondtryfinally(var p : ptree);
begin
end;
{*****************************************************************************
SecondFail
*****************************************************************************}
procedure secondfail(var p : ptree);
var
hp : preference;
begin
{if procinfo.exceptions then
aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E'))
else }
{ we should know if the constructor is called with a new or not,
how can we do that ???
exprasmlist^.concat(new(pai386,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0))));
}
exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI)));
{ also reset to zero in the stack }
new(hp);
reset_reference(hp^);
hp^.offset:=procinfo.ESI_offset;
hp^.base:=procinfo.framepointer;
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_ESI,hp)));
exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel)));
end;
end.
{
$Log$
Revision 1.1 1998-06-05 17:44:12 peter
* splitted cgi386
}

517
compiler/cg386ld.pas Normal file
View File

@ -0,0 +1,517 @@
{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
Generate i386 assembler for load/assignment nodes
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.
****************************************************************************
}
unit cg386ld;
interface
uses
tree,i386;
var
{ this is for open arrays and strings }
{ but be careful, this data is in the }
{ generated code destroyed quick, and also }
{ the next call of secondload destroys this }
{ data }
{ So be careful using the informations }
{ provided by this variables }
highframepointer : tregister;
highoffset : longint;
procedure secondload(var p : ptree);
procedure secondassignment(var p : ptree);
procedure secondfuncret(var p : ptree);
implementation
uses
cobjects,verbose,globals,
symtable,aasm,types,
cgi386,cgai386,tgeni386,hcodegen;
{*****************************************************************************
SecondLoad
*****************************************************************************}
procedure secondload(var p : ptree);
var
hregister : tregister;
symtabletype : tsymtabletype;
i : longint;
hp : preference;
begin
simple_loadn:=true;
reset_reference(p^.location.reference);
case p^.symtableentry^.typ of
{ this is only for toasm and toaddr }
absolutesym :
begin
stringdispose(p^.location.reference.symbol);
if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then
begin
if pabsolutesym(p^.symtableentry)^.absseg then
p^.location.reference.segment:=R_FS;
p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address;
end
else
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
end;
varsym :
begin
hregister:=R_NO;
symtabletype:=p^.symtable^.symtabletype;
{ in case it is a register variable: }
if pvarsym(p^.symtableentry)^.reg<>R_NO then
begin
p^.location.loc:=LOC_CREGISTER;
p^.location.register:=pvarsym(p^.symtableentry)^.reg;
unused:=unused-[pvarsym(p^.symtableentry)^.reg];
end
else
begin
{ first handle local and temporary variables }
if (symtabletype in [parasymtable,inlinelocalsymtable,
inlineparasymtable,localsymtable]) then
begin
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
if (symtabletype=localsymtable) or (symtabletype=inlinelocalsymtable) then
p^.location.reference.offset:=-p^.location.reference.offset;
if (symtabletype=parasymtable) or (symtabletype=inlineparasymtable) then
inc(p^.location.reference.offset,p^.symtable^.call_offset);
if (lexlevel>(p^.symtable^.symtablelevel)) then
begin
hregister:=getregister32;
{ make a reference }
hp:=new_reference(procinfo.framepointer,
procinfo.framepointer_offset);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
simple_loadn:=false;
i:=lexlevel-1;
while i>(p^.symtable^.symtablelevel) do
begin
{ make a reference }
hp:=new_reference(hregister,8);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
dec(i);
end;
p^.location.reference.base:=hregister;
end;
end
else
case symtabletype of
unitsymtable,globalsymtable,
staticsymtable : begin
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
if symtabletype=unitsymtable then
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end;
objectsymtable : begin
if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then
begin
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then
concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
end
else
begin
p^.location.reference.base:=R_ESI;
p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
end;
end;
withsymtable:
begin
hregister:=getregister32;
p^.location.reference.base:=hregister;
{ make a reference }
{ symtable datasize field
contains the offset of the temp
stored }
hp:=new_reference(procinfo.framepointer,
p^.symtable^.datasize);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
p^.location.reference.offset:=
pvarsym(p^.symtableentry)^.address;
end;
end;
{ in case call by reference, then calculate: }
if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
((pvarsym(p^.symtableentry)^.varspez=vs_const) and
dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) or
{ call by value open arrays are also indirect addressed }
is_open_array(pvarsym(p^.symtableentry)^.definition) then
begin
simple_loadn:=false;
if hregister=R_NO then
hregister:=getregister32;
if (p^.location.reference.base=procinfo.framepointer) then
begin
highframepointer:=p^.location.reference.base;
highoffset:=p^.location.reference.offset;
end
else
begin
highframepointer:=R_EDI;
highoffset:=p^.location.reference.offset;
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
p^.location.reference.base,R_EDI)));
end;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),
hregister)));
clear_reference(p^.location.reference);
p^.location.reference.base:=hregister;
end;
{
if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and
((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then
begin
simple_loadn:=false;
if hregister=R_NO then
hregister:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),
hregister)));
clear_reference(p^.location.reference);
p^.location.reference.base:=hregister;
end;
}
end;
end;
procsym:
begin
{!!!!! Be aware, work on virtual methods too }
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=
stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
end;
typedconstsym :
begin
stringdispose(p^.location.reference.symbol);
p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
end;
else internalerror(4);
end;
end;
{*****************************************************************************
SecondAssignment
*****************************************************************************}
procedure secondassignment(var p : ptree);
var
opsize : topsize;
otlabel,hlabel,oflabel : plabel;
hregister : tregister;
loc : tloc;
begin
otlabel:=truelabel;
oflabel:=falselabel;
getlabel(truelabel);
getlabel(falselabel);
{ calculate left sides }
if not(p^.concat_string) then
secondpass(p^.left);
if codegenerror then
exit;
case p^.left^.location.loc of
LOC_REFERENCE : begin
{ in case left operator uses to register }
{ but to few are free then LEA }
if (p^.left^.location.reference.base<>R_NO) and
(p^.left^.location.reference.index<>R_NO) and
(usablereg32<p^.right^.registers32) then
begin
del_reference(p^.left^.location.reference);
hregister:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(
p^.left^.location.reference),
hregister)));
clear_reference(p^.left^.location.reference);
p^.left^.location.reference.base:=hregister;
p^.left^.location.reference.index:=R_NO;
end;
loc:=LOC_REFERENCE;
end;
LOC_CREGISTER:
loc:=LOC_CREGISTER;
LOC_MMXREGISTER:
loc:=LOC_MMXREGISTER;
LOC_CMMXREGISTER:
loc:=LOC_CMMXREGISTER;
else
begin
Message(cg_e_illegal_expression);
exit;
end;
end;
{ lets try to optimize this (PM) }
{ define a dest_loc that is the location }
{ and a ptree to verify that it is the right }
{ place to insert it }
{$ifdef test_dest_loc}
if (aktexprlevel<4) then
begin
dest_loc_known:=true;
dest_loc:=p^.left^.location;
dest_loc_tree:=p^.right;
end;
{$endif test_dest_loc}
if (p^.right^.treetype=realconstn) then
begin
if p^.left^.resulttype^.deftype=floatdef then
begin
case pfloatdef(p^.left^.resulttype)^.typ of
s32real : p^.right^.realtyp:=ait_real_32bit;
s64real : p^.right^.realtyp:=ait_real_64bit;
s80real : p^.right^.realtyp:=ait_real_extended;
{ what about f32bit and s64bit }
end;
end;
end;
secondpass(p^.right);
if codegenerror then
exit;
{$ifdef test_dest_loc}
dest_loc_known:=false;
if in_dest_loc then
begin
truelabel:=otlabel;
falselabel:=oflabel;
in_dest_loc:=false;
exit;
end;
{$endif test_dest_loc}
if p^.left^.resulttype^.deftype=stringdef then
begin
{$ifdef UseAnsiString}
if is_ansistring(p^.left^.resulttype) then
begin
{ the source and destinations are released
in loadansistring, because an ansi string can
also be in a register
}
loadansistring(p);
end
else
{$endif UseAnsiString}
if not (p^.concat_string) then
begin
{ we do not need destination anymore }
del_reference(p^.left^.location.reference);
del_reference(p^.right^.location.reference);
loadstring(p);
ungetiftemp(p^.right^.location.reference);
end
else
begin
{ its the only thing we have to do }
del_reference(p^.right^.location.reference);
end
end
else case p^.right^.location.loc of
LOC_REFERENCE,
LOC_MEM : begin
{ handle ordinal constants trimmed }
if (p^.right^.treetype in [ordconstn,fixconstn]) or
(loc=LOC_CREGISTER) then
begin
case p^.left^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
end;
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
newreference(p^.right^.location.reference),
p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,
p^.right^.location.reference.offset,
newreference(p^.left^.location.reference))));
{exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,opsize,
p^.right^.location.reference.offset,
p^.left^.location)));}
end
else
begin
concatcopy(p^.right^.location.reference,
p^.left^.location.reference,p^.left^.resulttype^.size,false);
ungetiftemp(p^.right^.location.reference);
end;
end;
{$ifdef SUPPORT_MMX}
LOC_CMMXREGISTER,
LOC_MMXREGISTER:
begin
if loc=LOC_CMMXREGISTER then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO,
p^.right^.location.register,p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO,
p^.right^.location.register,newreference(p^.left^.location.reference))));
end;
{$endif SUPPORT_MMX}
LOC_REGISTER,
LOC_CREGISTER : begin
case p^.right^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
end;
{ simplified with op_reg_loc }
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,
p^.right^.location.register,
p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,
p^.right^.location.register,
newreference(p^.left^.location.reference))));
{exprasmlist^.concat(new(pai386,op_reg_loc(A_MOV,opsize,
p^.right^.location.register,
p^.left^.location))); }
end;
LOC_FPU : begin
if loc<>LOC_REFERENCE then
internalerror(10010)
else
floatstore(pfloatdef(p^.left^.resulttype)^.typ,
p^.left^.location.reference);
end;
LOC_JUMP : begin
getlabel(hlabel);
emitl(A_LABEL,truelabel);
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,
1,p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
1,newreference(p^.left^.location.reference))));
{exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B,
1,p^.left^.location)));}
emitl(A_JMP,hlabel);
emitl(A_LABEL,falselabel);
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,
p^.left^.location.register,
p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
0,newreference(p^.left^.location.reference))));
emitl(A_LABEL,hlabel);
end;
LOC_FLAGS : begin
if loc=LOC_CREGISTER then
exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,
p^.left^.location.register)))
else
exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_B,
newreference(p^.left^.location.reference))));
end;
end;
truelabel:=otlabel;
falselabel:=oflabel;
end;
{*****************************************************************************
SecondFuncRetN
*****************************************************************************}
procedure secondfuncret(var p : ptree);
var
hr : tregister;
{$ifdef TEST_FUNCRET}
hp : preference;
pp : pprocinfo;
hr_valid : boolean;
{$endif TEST_FUNCRET}
begin
clear_reference(p^.location.reference);
{$ifndef TEST_FUNCRET}
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=procinfo.retoffset;
if ret_in_param(procinfo.retdef) then
{$else TEST_FUNCRET}
hr_valid:=false;
if @procinfo<>pprocinfo(p^.funcretprocinfo) then
begin
hr:=getregister32;
hr_valid:=false;
hp:=new_reference(procinfo.framepointer,
pprocinfo(procinfo.framepointer_offset);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr)));
pp:=procinfo.parent;
while pp<>pprocinfo(p^.funcretprocinfo) do
begin
hp:=new_reference(hr,
pprocinfo(pp^.framepointer_offset);
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr)));
end;
p^.location.reference.base:=hr;
{ walk up the stack frame }
{ not done yet !! }
end
else
p^.location.reference.base:=procinfo.framepointer;
p^.location.reference.offset:=pprocinfo(p^.funcretprocinfo)^.retoffset;
if ret_in_param(p^.retdef) then
{$endif TEST_FUNCRET}
begin
{$ifdef TEST_FUNCRET}
if not hr_valid then
{$endif TEST_FUNCRET}
hr:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr)));
p^.location.reference.base:=hr;
p^.location.reference.offset:=0;
end;
end;
end.
{
$Log$
Revision 1.1 1998-06-05 17:44:12 peter
* splitted cgi386
}

189
compiler/cg386mat.pas
View File

@ -23,21 +23,27 @@
unit cg386mat;
interface
uses tree;
uses
tree;
procedure secondmoddiv(var p : ptree);
procedure secondshlshr(var p : ptree);
procedure secondumminus(var p : ptree);
procedure secondnot(var p : ptree);
implementation
uses
cobjects,verbose,globals,
symtable,aasm,i386,
types,cgi386,cgai386,tgeni386,hcodegen;
uses
cobjects,verbose,globals,
symtable,aasm,i386,
types,cgi386,cgai386,tgeni386,hcodegen;
{*****************************************************************************
SecondModDiv
*****************************************************************************}
procedure secondmoddiv(var p : ptree);
var
hreg1 : tregister;
pushed,popeax,popedx : boolean;
@ -159,13 +165,16 @@ implementation
p^.location.register:=hreg1;
end;
procedure secondshlshr(var p : ptree);
{*****************************************************************************
SecondShlShr
*****************************************************************************}
procedure secondshlshr(var p : ptree);
var
hregister1,hregister2,hregister3 : tregister;
pushed,popecx : boolean;
op : tasmop;
begin
popecx:=false;
@ -270,14 +279,17 @@ implementation
usedinproc:=usedinproc or ($80 shr byte(R_ECX));
end;
{*****************************************************************************
SecondUmMinus
*****************************************************************************}
procedure secondumminus(var p : ptree);
{$ifdef SUPPORT_MMX}
procedure do_mmx_neg;
var
op : tasmop;
begin
p^.location.loc:=LOC_MMXREGISTER;
if cs_mmx_saturation in aktswitches then
@ -382,10 +394,165 @@ implementation
{ emitoverflowcheck(p);}
end;
{*****************************************************************************
SecondNot
*****************************************************************************}
procedure secondnot(var p : ptree);
const
flagsinvers : array[F_E..F_BE] of tresflags =
(F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
F_A,F_AE,F_B,F_BE);
var
hl : plabel;
opsize : topsize;
begin
if (p^.resulttype^.deftype=orddef) and
(porddef(p^.resulttype)^.typ in [bool8bit,bool16bit,bool32bit]) then
begin
case porddef(p^.resulttype)^.typ of
bool8bit : opsize:=S_B;
bool16bit : opsize:=S_W;
bool32bit : opsize:=S_L;
end;
case p^.location.loc of
LOC_JUMP : begin
hl:=truelabel;
truelabel:=falselabel;
falselabel:=hl;
secondpass(p^.left);
maketojumpbool(p^.left);
hl:=truelabel;
truelabel:=falselabel;
falselabel:=hl;
end;
LOC_FLAGS : begin
secondpass(p^.left);
p^.location.resflags:=flagsinvers[p^.left^.location.resflags];
end;
LOC_REGISTER : begin
secondpass(p^.left);
p^.location.register:=p^.left^.location.register;
exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,opsize,1,p^.location.register)));
end;
LOC_CREGISTER : begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
case porddef(p^.resulttype)^.typ of
bool8bit : p^.location.register:=reg32toreg8(getregister32);
bool16bit : p^.location.register:=reg32toreg16(getregister32);
bool32bit : p^.location.register:=getregister32;
end;
emit_reg_reg(A_MOV,opsize,p^.left^.location.register,p^.location.register);
exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,opsize,1,p^.location.register)));
end;
LOC_REFERENCE,
LOC_MEM : begin
secondpass(p^.left);
del_reference(p^.left^.location.reference);
p^.location.loc:=LOC_REGISTER;
case porddef(p^.resulttype)^.typ of
bool8bit : p^.location.register:=reg32toreg8(getregister32);
bool16bit : p^.location.register:=reg32toreg16(getregister32);
bool32bit : p^.location.register:=getregister32;
end;
if p^.left^.location.loc=LOC_CREGISTER then
emit_reg_reg(A_MOV,opsize,p^.left^.location.register,p^.location.register)
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
newreference(p^.left^.location.reference),p^.location.register)));
exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,opsize,1,p^.location.register)));
end;
end;
end
{$ifdef SUPPORT_MMX}
else if (cs_mmx in aktswitches) and is_mmx_able_array(p^.left^.resulttype) then
begin
secondpass(p^.left);
p^.location.loc:=LOC_MMXREGISTER;
{ prepare EDI }
exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L,$ffffffff,R_EDI)));
{ load operand }
case p^.left^.location.loc of
LOC_MMXREGISTER:
p^.location:=p^.left^.location;
LOC_CMMXREGISTER:
begin
p^.location.register:=getregistermmx;
emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register,
p^.location.register);
end;
LOC_REFERENCE,LOC_MEM:
begin
del_reference(p^.left^.location.reference);
p^.location.register:=getregistermmx;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
end;
{ load mask }
emit_reg_reg(A_MOV,S_D,R_EDI,R_MM7);
{ lower 32 bit }
emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register);
{ shift mask }
exprasmlist^.concat(new(pai386,op_const_reg(A_PSLLQ,S_NO,
32,R_MM7)));
{ higher 32 bit }
emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register);
end
{$endif SUPPORT_MMX}
else
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
case p^.left^.location.loc of
LOC_REGISTER : begin
p^.location.register:=p^.left^.location.register;
exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
end;
LOC_CREGISTER : begin
p^.location.register:=getregister32;
emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
p^.location.register);
exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
end;
LOC_REFERENCE,LOC_MEM :
begin
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));
end;
end;
{if p^.left^.location.loc=loc_register then
p^.location.register:=p^.left^.location.register
else
begin
del_locref(p^.left^.location);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_loc_reg(A_MOV,S_L,
p^.left^.location,
p^.location.register)));
end;
exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));}
end;
end;
end.
{
$Log$
Revision 1.2 1998-06-02 17:02:59 pierre
Revision 1.3 1998-06-05 17:44:12 peter
* splitted cgi386
Revision 1.2 1998/06/02 17:02:59 pierre
* with node corrected for objects
* small bugs for SUPPORT_MMX fixed

585
compiler/cg386mem.pas Normal file
View File

@ -0,0 +1,585 @@
{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
Generate i386 assembler for in memory related nodes
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.
****************************************************************************
}
unit cg386mem;
interface
uses
tree;
procedure secondloadvmt(var p : ptree);
procedure secondhnewn(var p : ptree);
procedure secondnewn(var p : ptree);
procedure secondhdisposen(var p : ptree);
procedure secondsimplenewdispose(var p : ptree);
procedure secondaddr(var p : ptree);
procedure seconddoubleaddr(var p : ptree);
procedure secondderef(var p : ptree);
procedure secondsubscriptn(var p : ptree);
procedure secondvecn(var p : ptree);
procedure secondselfn(var p : ptree);
procedure secondwith(var p : ptree);
implementation
uses
cobjects,verbose,globals,systems,
symtable,aasm,i386,types,
cgi386,cgai386,tgeni386,hcodegen;
{*****************************************************************************
SecondLoadVMT
*****************************************************************************}
procedure secondloadvmt(var p : ptree);
begin
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,
S_L,newcsymbol(pobjectdef(pclassrefdef(p^.resulttype)^.definition)^.vmt_mangledname,0),
p^.location.register)));
end;
{*****************************************************************************
SecondHNewN
*****************************************************************************}
procedure secondhnewn(var p : ptree);
begin
end;
{*****************************************************************************
SecondNewN
*****************************************************************************}
procedure secondnewn(var p : ptree);
begin
secondpass(p^.left);
if codegenerror then
exit;
p^.location.register:=p^.left^.location.register;
end;
{*****************************************************************************
SecondDisposeN
*****************************************************************************}
procedure secondhdisposen(var p : ptree);
begin
secondpass(p^.left);
if codegenerror then
exit;
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
p^.location.reference.index:=getregister32;
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
p^.left^.location.register,
p^.location.reference.index)));
end;
LOC_MEM,LOC_REFERENCE :
begin
del_reference(p^.left^.location.reference);
p^.location.reference.index:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
p^.location.reference.index)));
end;
end;
end;
{*****************************************************************************
SecondNewDispose
*****************************************************************************}
procedure secondsimplenewdispose(var p : ptree);
var
pushed : tpushed;
begin
secondpass(p^.left);
if codegenerror then
exit;
pushusedregisters(pushed,$ff);
{ determines the size of the mem block }
push_int(ppointerdef(p^.left^.resulttype)^.definition^.size);
{ push pointer adress }
case p^.left^.location.loc of
LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,
p^.left^.location.register)));
LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference);
end;
{ call the mem handling procedures }
case p^.treetype of
simpledisposen:
emitcall('FREEMEM',true);
simplenewn:
emitcall('GETMEM',true);
end;
popusedregisters(pushed);
{ may be load ESI }
maybe_loadesi;
end;
{*****************************************************************************
SecondAddr
*****************************************************************************}
procedure secondaddr(var p : ptree);
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
{@ on a procvar means returning an address to the procedure that
is stored in it.}
{ yes but p^.left^.symtableentry can be nil
for example on @self !! }
{ symtableentry can be also invalid, if left is no tree node }
if (p^.left^.treetype=loadn) and
assigned(p^.left^.symtableentry) and
(p^.left^.symtableentry^.typ=varsym) and
(pvarsym(p^.left^.symtableentry)^.definition^.deftype=procvardef) then
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
newreference(p^.left^.location.reference),
p^.location.register)))
else
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
{ for use of other segments }
if p^.left^.location.reference.segment<>R_DEFAULT_SEG then
p^.location.segment:=p^.left^.location.reference.segment;
end;
{*****************************************************************************
SecondDoubleAddr
*****************************************************************************}
procedure seconddoubleaddr(var p : ptree);
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
del_reference(p^.left^.location.reference);
p^.location.register:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),
p^.location.register)));
end;
{*****************************************************************************
SecondDeRef
*****************************************************************************}
procedure secondderef(var p : ptree);
var
hr : tregister;
begin
secondpass(p^.left);
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER:
p^.location.reference.base:=p^.left^.location.register;
LOC_CREGISTER:
begin
{ ... and reserve one for the pointer }
hr:=getregister32;
emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
end;
else
begin
{ free register }
del_reference(p^.left^.location.reference);
{ ...and reserve one for the pointer }
hr:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(
A_MOV,S_L,newreference(p^.left^.location.reference),
hr)));
p^.location.reference.base:=hr;
end;
end;
end;
{*****************************************************************************
SecondSubScriptN
*****************************************************************************}
procedure secondsubscriptn(var p : ptree);
var
hr : tregister;
begin
secondpass(p^.left);
if codegenerror then
exit;
{ classes must be dereferenced implicit }
if (p^.left^.resulttype^.deftype=objectdef) and
pobjectdef(p^.left^.resulttype)^.isclass then
begin
clear_reference(p^.location.reference);
case p^.left^.location.loc of
LOC_REGISTER:
p^.location.reference.base:=p^.left^.location.register;
LOC_CREGISTER:
begin
{ ... and reserve one for the pointer }
hr:=getregister32;
emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr);
p^.location.reference.base:=hr;
end;
else
begin
{ free register }
del_reference(p^.left^.location.reference);
{ ... and reserve one for the pointer }
hr:=getregister32;
exprasmlist^.concat(new(pai386,op_ref_reg(
A_MOV,S_L,newreference(p^.left^.location.reference),
hr)));
p^.location.reference.base:=hr;
end;
end;
end
else
set_location(p^.location,p^.left^.location);
inc(p^.location.reference.offset,p^.vs^.address);
end;
{*****************************************************************************
SecondVecN
*****************************************************************************}
procedure secondvecn(var p : ptree);
var
pushed : boolean;
ind,hr : tregister;
_p : ptree;
function get_mul_size:longint;
begin
if p^.memindex then
get_mul_size:=1
else
get_mul_size:=p^.resulttype^.size;
end;
procedure calc_emit_mul;
var
l1,l2 : longint;
begin
l1:=get_mul_size;
case l1 of
1,2,4,8 : p^.location.reference.scalefactor:=l1;
else
begin
if ispowerof2(l1,l2) then
exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,l2,ind)))
else
exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,l1,ind)));
end;
end;
end;
var
extraoffset : longint;
t : ptree;
hp : preference;
tai : Pai386;
begin
secondpass(p^.left);
set_location(p^.location,p^.left^.location);
{ in ansistrings S[1] is pchar(S)[0] !! }
if is_ansistring(p^.left^.resulttype) then
dec(p^.location.reference.offset);
{ offset can only differ from 0 if arraydef }
if p^.left^.resulttype^.deftype=arraydef then
dec(p^.location.reference.offset,
get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
if p^.right^.treetype=ordconstn then
begin
{ offset can only differ from 0 if arraydef }
if (p^.left^.resulttype^.deftype=arraydef) then
begin
if not(is_open_array(p^.left^.resulttype)) then
begin
if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
(p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
Message(parser_e_range_check_error);
dec(p^.left^.location.reference.offset,
get_mul_size*parraydef(p^.left^.resulttype)^.lowrange);
end
else
begin
{ range checking for open arrays }
end;
end;
inc(p^.left^.location.reference.offset,
get_mul_size*p^.right^.value);
if p^.memseg then
p^.left^.location.reference.segment:=R_FS;
p^.left^.resulttype:=p^.resulttype;
disposetree(p^.right);
_p:=p^.left;
putnode(p);
p:=_p;
end
else
begin
{ quick hack, to overcome Delphi 2 }
if (cs_maxoptimieren in aktswitches) and
(p^.left^.resulttype^.deftype=arraydef) then
begin
extraoffset:=0;
if (p^.right^.treetype=addn) then
begin
if p^.right^.right^.treetype=ordconstn then
begin
extraoffset:=p^.right^.right^.value;
t:=p^.right^.left;
putnode(p^.right);
putnode(p^.right^.right);
p^.right:=t
end
else if p^.right^.left^.treetype=ordconstn then
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
end;
end
else if (p^.right^.treetype=subn) then
begin
if p^.right^.right^.treetype=ordconstn then
begin
extraoffset:=p^.right^.right^.value;
t:=p^.right^.left;
putnode(p^.right);
putnode(p^.right^.right);
p^.right:=t
end
else if p^.right^.left^.treetype=ordconstn then
begin
extraoffset:=p^.right^.left^.value;
t:=p^.right^.right;
putnode(p^.right);
putnode(p^.right^.left);
p^.right:=t
end;
end;
inc(p^.location.reference.offset,
get_mul_size*extraoffset);
end;
{ calculate from left to right }
if (p^.location.loc<>LOC_REFERENCE) and
(p^.location.loc<>LOC_MEM) then
Message(cg_e_illegal_expression);
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
case p^.right^.location.loc of
LOC_REGISTER:
begin
ind:=p^.right^.location.register;
case p^.right^.resulttype^.size of
1:
begin
hr:=reg8toreg32(ind);
emit_reg_reg(A_MOVZX,S_BL,ind,hr);
ind:=hr;
end;
2:
begin
hr:=reg16toreg32(ind);
emit_reg_reg(A_MOVZX,S_WL,ind,hr);
ind:=hr;
end;
end;
end;
LOC_CREGISTER:
begin
ind:=getregister32;
case p^.right^.resulttype^.size of
1:
emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind);
2:
emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind);
4:
emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind);
end;
end;
LOC_FLAGS:
begin
ind:=getregister32;
exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,reg32toreg8(ind))));
emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
end
else
begin
del_reference(p^.right^.location.reference);
ind:=getregister32;
{ Booleans are stored in an 8 bit memory location, so
the use of MOVL is not correct }
case p^.right^.resulttype^.size of
1:
tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind));
2:
tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind));
4:
tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind));
end;
exprasmlist^.concat(tai);
end;
end;
{ produce possible range check code: }
if cs_rangechecking in aktswitches then
begin
if p^.left^.resulttype^.deftype=arraydef then
begin
hp:=new_reference(R_NO,0);
parraydef(p^.left^.resulttype)^.genrangecheck;
hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp)));
end;
end;
if p^.location.reference.index=R_NO then
begin
p^.location.reference.index:=ind;
calc_emit_mul;
end
else
begin
if p^.location.reference.base=R_NO then
begin
case p^.location.reference.scalefactor of
2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index)));
4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index)));
8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index)));
end;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end
else
begin
exprasmlist^.concat(new(pai386,op_ref_reg(
A_LEA,S_L,newreference(p^.location.reference),
p^.location.reference.index)));
ungetregister32(p^.location.reference.base);
{ the symbol offset is loaded, }
{ so release the symbol name and set symbol }
{ to nil }
stringdispose(p^.location.reference.symbol);
p^.location.reference.offset:=0;
calc_emit_mul;
p^.location.reference.base:=p^.location.reference.index;
p^.location.reference.index:=ind;
end;
end;
if p^.memseg then
p^.location.reference.segment:=R_FS;
end;
end;
{*****************************************************************************
SecondSelfN
*****************************************************************************}
procedure secondselfn(var p : ptree);
begin
clear_reference(p^.location.reference);
if (p^.resulttype^.deftype=classrefdef) or
((p^.resulttype^.deftype=objectdef)
and pobjectdef(p^.resulttype)^.isclass
) then
p^.location.register:=R_ESI
else
p^.location.reference.base:=R_ESI;
end;
{*****************************************************************************
SecondWithN
*****************************************************************************}
procedure secondwith(var p : ptree);
var
ref : treference;
symtable : psymtable;
i : longint;
begin
if assigned(p^.left) then
begin
secondpass(p^.left);
ref.symbol:=nil;
gettempofsizereference(4,ref);
exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,
newreference(p^.left^.location.reference),R_EDI)));
exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,
R_EDI,newreference(ref))));
del_reference(p^.left^.location.reference);
{ the offset relative to (%ebp) is only needed here! }
symtable:=p^.withsymtable;
for i:=1 to p^.tablecount do
begin
symtable^.datasize:=ref.offset;
symtable:=symtable^.next;
end;
{ p^.right can be optimize out !!! }
if p^.right<>nil then
secondpass(p^.right);
{ clear some stuff }
ungetiftemp(ref);
end;
end;
end.
{
$Log$
Revision 1.1 1998-06-05 17:44:13 peter
* splitted cgi386
}

772
compiler/cg386set.pas Normal file
View File

@ -0,0 +1,772 @@
{
$Id$
Copyright (c) 1993-98 by Florian Klaempfl
Generate i386 assembler for in set/case nodes
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.
****************************************************************************
}
unit cg386set;
interface
uses
tree;
procedure secondin(var p : ptree);
procedure secondcase(var p : ptree);
implementation
uses
cobjects,verbose,globals,systems,
symtable,aasm,i386,types,
cgi386,cgai386,tgeni386,hcodegen;
const
bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L);
{*****************************************************************************
SecondIn
*****************************************************************************}
procedure secondin(var p : ptree);
type
Tsetpart=record
range:boolean; {Part is a range.}
start,stop:byte; {Start/stop when range; Stop=element when an element.}
end;
var
pushed,ranges : boolean;
hr,pleftreg : tregister;
opsize : topsize;
setparts:array[1..8] of Tsetpart;
i,numparts:byte;
href,href2:Treference;
l,l2 : plabel;
function analizeset(Aset:Pconstset):boolean;
type
byteset=set of byte;
var
compares,maxcompares:word;
i:byte;
begin
analizeset:=false;
ranges:=false;
numparts:=0;
compares:=0;
{Lots of comparisions take a lot of time, so do not allow
too much comparisions. 8 comparisions are, however, still
smalller than emitting the set.}
maxcompares:=5;
if cs_littlesize in aktswitches then
maxcompares:=8;
for i:=0 to 255 do
if i in byteset(Aset^) then
begin
if (numparts=0) or
(i<>setparts[numparts].stop+1) then
begin
{Set element is a separate element.}
inc(compares);
if compares>maxcompares then
exit;
inc(numparts);
setparts[numparts].range:=false;
setparts[numparts].stop:=i;
end
else
{Set element is part of a range.}
if not setparts[numparts].range then
begin
{Transform an element into a range.}
setparts[numparts].range:=true;
setparts[numparts].start:=
setparts[numparts].stop;
setparts[numparts].stop:=i;
inc(compares);
if compares>maxcompares then
exit;
end
else
begin
{Extend a range.}
setparts[numparts].stop:=i;
{A range of two elements can better
be checked as two separate ones.
When extending a range, our range
becomes larger than two elements.}
ranges:=true;
end;
end;
analizeset:=true;
end;
begin
if psetdef(p^.right^.resulttype)^.settype=smallset then
begin
if p^.left^.treetype=ordconstn then
begin
{ only compulsory }
secondpass(p^.left);
secondpass(p^.right);
if codegenerror then
exit;
p^.location.resflags:=F_NE;
case p^.right^.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
exprasmlist^.concat(new(pai386,op_const_reg(
A_TEST,S_L,1 shl (p^.left^.value and 31),
p^.right^.location.register)));
ungetregister32(p^.right^.location.register);
end
else
begin
exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_L,1 shl (p^.left^.value and 31),
newreference(p^.right^.location.reference))));
del_reference(p^.right^.location.reference);
end;
end;
end
else
begin
{ calculate both operators }
{ the complex one first }
firstcomplex(p);
secondpass(p^.left);
{ are too few registers free? }
pushed:=maybe_push(p^.right^.registers32,p^.left);
secondpass(p^.right);
if pushed then
restore(p^.left);
{ of course not commutative }
if p^.swaped then
swaptree(p);
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
hr:=p^.left^.location.register;
case p^.left^.location.register of
R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
begin
hr:=reg16toreg32(p^.left^.location.register);
ungetregister32(hr);
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,
p^.left^.location.register,hr)));
end;
R_AL,R_BL,R_CL,R_DL :
begin
hr:=reg8toreg32(p^.left^.location.register);
ungetregister32(hr);
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,
p^.left^.location.register,hr)));
end;
end;
end;
else
begin
{ the set element isn't never samller than a byte }
{ and because it's a small set we need only 5 bits }
{ but 8 bits are eaiser to load }
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,
newreference(p^.left^.location.reference),R_EDI)));
hr:=R_EDI;
del_reference(p^.left^.location.reference);
end;
end;
case p^.right^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
exprasmlist^.concat(new(pai386,op_reg_reg(A_BT,S_L,hr,
p^.right^.location.register)));
else
begin
exprasmlist^.concat(new(pai386,op_reg_ref(A_BT,S_L,hr,
newreference(p^.right^.location.reference))));
del_reference(p^.right^.location.reference);
end;
end;
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=F_C;
end;
end
else
begin
if p^.left^.treetype=ordconstn then
begin
{ only compulsory }
secondpass(p^.left);
secondpass(p^.right);
if codegenerror then
exit;
p^.location.resflags:=F_NE;
inc(p^.right^.location.reference.offset,p^.left^.value shr 3);
exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_B,1 shl (p^.left^.value and 7),
newreference(p^.right^.location.reference))));
del_reference(p^.right^.location.reference);
end
else
begin
if (p^.right^.treetype=setconstrn) and
analizeset(p^.right^.constset) then
begin
{It gives us advantage to check for the set elements
separately instead of using the SET_IN_BYTE procedure.
To do: Build in support for LOC_JUMP.}
secondpass(p^.left);
{We won't do a second pass on p^.right, because
this will emit the constant set.}
{If register is used, use only lower 8 bits}
if p^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
pleftreg:=p^.left^.location.register;
if pleftreg in [R_AL..R_DH] then
begin
exprasmlist^.concat(new(pai386,op_const_reg(
A_AND,S_B,255,pleftreg)));
opsize:=S_B;
end
else
begin
exprasmlist^.concat(new(pai386,op_const_reg(
A_AND,S_L,255,pleftreg)));
if pleftreg in [R_EAX..R_EDI] then
opsize:=S_L
else
opsize:=S_W;
end;
end;
{Get a label to jump to the end.}
p^.location.loc:=LOC_FLAGS;
{It's better to use the zero flag when there are
no ranges.}
if ranges then
p^.location.resflags:=F_C
else
p^.location.resflags:=F_E;
href.symbol := nil;
clear_reference(href);
getlabel(l);
href.symbol:=stringdup(lab2str(l));
for i:=1 to numparts do
if setparts[i].range then
begin
{Check if left is in a range.}
{Get a label to jump over the check.}
href2.symbol := nil;
clear_reference(href2);
getlabel(l2);
href.symbol:=stringdup(lab2str(l2));
if setparts[i].start=setparts[i].stop-1 then
begin
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER :
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,
setparts[i].start,pleftreg)));
else
exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
setparts[i].start,newreference(p^.left^.location.reference))));
end;
{Result should be in carry flag when ranges are used.}
if ranges then
exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO)));
{If found, jump to end.}
emitl(A_JE,l);
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,
setparts[i].stop,pleftreg)));
else
exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
setparts[i].stop,newreference(p^.left^.location.reference))));
end;
{Result should be in carry flag when ranges are used.}
if ranges then
exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO)));
{If found, jump to end.}
emitl(A_JE,l);
end
else
begin
if setparts[i].start<>0 then
begin
{ We only check for the lower bound if it is > 0, because
set elements lower than 0 do nt exist.}
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER :
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,
setparts[i].start,pleftreg)));
else
exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
setparts[i].start,newreference(p^.left^.location.reference))));
end;
{If lower, jump to next check.}
emitl(A_JB,l2);
end;
{ We only check for the high bound if it is < 255, because
set elements higher than 255 do nt exist, the its always true,
so only a JMP is generated }
if setparts[i].stop<>255 then
begin
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER :
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,
setparts[i].stop+1,pleftreg)));
else
exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
setparts[i].stop+1,newreference(p^.left^.location.reference))));
end;
{If higher, element is in set.}
emitl(A_JB,l);
end
else
begin
exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO)));
emitl(A_JMP,l);
end;
end;
{Emit the jump over label.}
exprasmlist^.concat(new(pai_label,init(l2)));
end
else
begin
{Emit code to check if left is an element.}
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,
setparts[i].stop,pleftreg)));
else
exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B,
setparts[i].stop,newreference(p^.left^.location.reference))));
end;
{Result should be in carry flag when ranges are used.}
if ranges then
exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO)));
{If found, jump to end.}
emitl(A_JE,l);
end;
if ranges then
exprasmlist^.concat(new(pai386,op_none(A_CLC,S_NO)));
{To compensate for not doing a second pass.}
stringdispose(p^.right^.location.reference.symbol);
{Now place the end label.}
exprasmlist^.concat(new(pai_label,init(l)));
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
ungetregister32(pleftreg);
else
del_reference(p^.left^.location.reference);
end;
end
else
begin
{ calculate both operators }
{ the complex one first }
firstcomplex(p);
secondpass(p^.left);
{ are too few registers free? }
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
{ of course not commutative }
if p^.swaped then
swaptree(p);
pushsetelement(p^.left);
emitpushreferenceaddr(p^.right^.location.reference);
del_reference(p^.right^.location.reference);
{ registers need not be save. that happens in SET_IN_BYTE }
{ (EDI is changed) }
emitcall('SET_IN_BYTE',true);
{ ungetiftemp(p^.right^.location.reference); }
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=F_C;
end;
end;
end;
end;
{*****************************************************************************
SecondCase
*****************************************************************************}
procedure secondcase(var p : ptree);
var
with_sign : boolean;
opsize : topsize;
jmp_gt,jmp_le,jmp_lee : tasmop;
hp : ptree;
{ register with case expression }
hregister : tregister;
endlabel,elselabel : plabel;
{ true, if we can omit the range check of the jump table }
jumptable_no_range : boolean;
{ where to put the jump table }
jumpsegment : paasmoutput;
procedure gentreejmp(p : pcaserecord);
var
lesslabel,greaterlabel : plabel;
begin
emitl(A_LABEL,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
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister)));
if greaterlabel=lesslabel then
begin
emitl(A_JNE,lesslabel);
end
else
begin
emitl(jmp_le,lesslabel);
emitl(jmp_gt,greaterlabel);
end;
emitl(A_JMP,p^.statement);
end
else
begin
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister)));
emitl(jmp_le,lesslabel);
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._high,hregister)));
emitl(jmp_gt,greaterlabel);
emitl(A_JMP,p^.statement);
end;
if assigned(p^.less) then
gentreejmp(p^.less);
if assigned(p^.greater) then
gentreejmp(p^.greater);
end;
procedure genlinearlist(hp : pcaserecord);
var
first : boolean;
last : longint;
{helplabel : longint;}
procedure genitem(t : pcaserecord);
begin
if assigned(t^.less) then
genitem(t^.less);
if t^._low=t^._high then
begin
if t^._low-last=1 then
exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister)))
else if t^._low-last=0 then
exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize,hregister,hregister)))
else
exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last,hregister)));
last:=t^._low;
emitl(A_JZ,t^.statement);
end
else
begin
{ it begins with the smallest label, if the value }
{ is even smaller then jump immediately to the }
{ ELSE-label }
if first then
begin
if t^._low-1=1 then
exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,
hregister)))
else if t^._low-1=0 then
exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize,
hregister,hregister)))
else
exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,
t^._low-1,hregister)));
{ work around: if the lower range=0 and we
do the subtraction we have to take care
of the sign!
}
if t^._low=0 then
emitl(A_JLE,elselabel)
else
emitl(jmp_lee,elselabel);
end
{ if there is no unused label between the last and the }
{ present label then the lower limit can be checked }
{ immediately. else check the range in between: }
else if (t^._low-last>1)then
begin
if t^._low-last-1=1 then
exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister)))
else
exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister)));
emitl(jmp_lee,elselabel);
end;
exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister)));
emitl(jmp_lee,t^.statement);
last:=t^._high;
end;
first:=false;
if assigned(t^.greater) then
genitem(t^.greater);
end;
var
hr : tregister;
begin
{ case register is modified by the list evalution }
if (p^.left^.location.loc=LOC_CREGISTER) then
begin
hr:=getregister32;
case opsize of
S_B : hregister:=reg32toreg8(hr);
S_W : hregister:=reg32toreg16(hr);
S_L : hregister:=hr;
end;
end;
last:=0;
first:=true;
genitem(hp);
emitl(A_JMP,elselabel);
end;
procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
var
table : plabel;
last : longint;
hr : preference;
procedure genitem(t : pcaserecord);
var
i : longint;
begin
if assigned(t^.less) then
genitem(t^.less);
{ fill possible hole }
for i:=last+1 to t^._low-1 do
jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
(elselabel)))));
for i:=t^._low to t^._high do
jumpsegment^.concat(new(pai_const,init_symbol(strpnew(lab2str
(t^.statement)))));
last:=t^._high;
if assigned(t^.greater) then
genitem(t^.greater);
end;
begin
if not(jumptable_no_range) then
begin
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,min_,hregister)));
{ case expr less than min_ => goto elselabel }
emitl(jmp_le,elselabel);
exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,max_,hregister)));
emitl(jmp_gt,elselabel);
end;
getlabel(table);
{ extend with sign }
if opsize=S_W then
begin
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,hregister,
reg16toreg32(hregister))));
hregister:=reg16toreg32(hregister);
end
else if opsize=S_B then
begin
exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister,
reg8toreg32(hregister))));
hregister:=reg8toreg32(hregister);
end;
new(hr);
reset_reference(hr^);
hr^.symbol:=stringdup(lab2str(table));
hr^.offset:=(-min_)*4;
hr^.index:=hregister;
hr^.scalefactor:=4;
exprasmlist^.concat(new(pai386,op_ref(A_JMP,S_NO,hr)));
{ !!!!! generate tables
if not(cs_littlesize in aktswitches^ ) then
jumpsegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
}
jumpsegment^.concat(new(pai_label,init(table)));
last:=min_;
genitem(hp);
{ !!!!!!!
if not(cs_littlesize in aktswitches^ ) then
exprasmlist^.concat(new(pai386,op_const(A_ALIGN,S_NO,4)));
}
end;
var
lv,hv,min_label,max_label,labels : longint;
max_linear_list : longint;
begin
getlabel(endlabel);
getlabel(elselabel);
if (cs_smartlink in aktswitches) then
jumpsegment:=procinfo.aktlocaldata
else
jumpsegment:=datasegment;
with_sign:=is_signed(p^.left^.resulttype);
if with_sign then
begin
jmp_gt:=A_JG;
jmp_le:=A_JL;
jmp_lee:=A_JLE;
end
else
begin
jmp_gt:=A_JA;
jmp_le:=A_JB;
jmp_lee:=A_JBE;
end;
cleartempgen;
secondpass(p^.left);
{ determines the size of the operand }
{ determines the size of the operand }
opsize:=bytes2Sxx[p^.left^.resulttype^.size];
{ copy the case expression to a register }
{ copy the case expression to a register }
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
hregister:=p^.left^.location.register;
LOC_MEM,LOC_REFERENCE : begin
del_reference(p^.left^.location.reference);
hregister:=getregister32;
case opsize of
S_B : hregister:=reg32toreg8(hregister);
S_W : hregister:=reg32toreg16(hregister);
end;
exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(
p^.left^.location.reference),hregister)));
end;
else internalerror(2002);
end;
{ now generate the jumps }
if cs_optimize in aktswitches then
begin
{ procedures are empirically passed on }
{ consumption can also be calculated }
{ but does it pay on the different }
{ processors? }
{ moreover can the size only be appro- }
{ ximated as it is not known if rel8, }
{ rel16 or rel32 jumps are used }
min_label:=case_get_min(p^.nodes);
max_label:=case_get_max(p^.nodes);
labels:=case_count_labels(p^.nodes);
{ can we omit the range check of the jump table }
getrange(p^.left^.resulttype,lv,hv);
jumptable_no_range:=(lv=min_label) and (hv=max_label);
{ optimize for size ? }
if cs_littlesize in aktswitches then
begin
if (labels<=2) or ((max_label-min_label)>3*labels) then
{ a linear list is always smaller than a jump tree }
genlinearlist(p^.nodes)
else
{ if the labels less or more a continuum then }
genjumptable(p^.nodes,min_label,max_label);
end
else
begin
if jumptable_no_range then
max_linear_list:=4
else
max_linear_list:=2;
{ a jump table crashes the pipeline! }
if aktoptprocessor=i486 then
inc(max_linear_list,3);
if aktoptprocessor=pentium then
inc(max_linear_list,6);
if aktoptprocessor>=pentiumpro then
inc(max_linear_list,9);
if (labels<=max_linear_list) then
genlinearlist(p^.nodes)
else
begin
if ((max_label-min_label)>4*labels) then
begin
if labels>16 then
gentreejmp(p^.nodes)
else
genlinearlist(p^.nodes);
end
else
genjumptable(p^.nodes,min_label,max_label);
end;
end;
end
else
{ it's always not bad }
genlinearlist(p^.nodes);
{ now generate the instructions }
hp:=p^.right;
while assigned(hp) do
begin
cleartempgen;
secondpass(hp^.right);
emitl(A_JMP,endlabel);
hp:=hp^.left;
end;
emitl(A_LABEL,elselabel);
{ ...and the else block }
if assigned(p^.elseblock) then
begin
cleartempgen;
secondpass(p^.elseblock);
end;
emitl(A_LABEL,endlabel);
end;
end.
{
$Log$
Revision 1.1 1998-06-05 17:44:13 peter
* splitted cgi386
}