{$ifdef tp}
{E+,N+}
{$endif}
{****************************************************************************
Copyright (c) 1993,96 by Florian Klämpfl
****************************************************************************}
unit codegen;
interface
uses
cobjects,systems,globals,tree,asmgen,symtable,tempad,types,strings,
i386,pass_1,hcodegen;
{ erzeugt für den durch p übergebenen Ausdruck Assembler }
{ und erzeugt am Ende eine Assembler-Node }
procedure generatecode(var p : ptree);
{ erzeugt den eigentlichen Code }
function do_secondpass(var p : ptree) : boolean;
{ initilisiert bzw beendet den Codegenerator }
procedure codegeninit;
procedure codegendone;
{ erzeugt bei bool'schen Ausdrücken die Sprünge zu true bzw falselabel }
procedure maketojumpbool(p : ptree);
procedure concatcopy(source,dest : treferenz;size : longint;delsource : boolean);
{ siehe Implementation }
procedure maybe_loadesi;
implementation
procedure secondpass(var p : ptree);forward;
procedure error(const t : errorconst);
begin
if not(codegenerror) then
globals.error(t);
codegenerror:=true;
end;
type
secondpassproc = procedure(var p : ptree);
function ispowerof2(value : longint;var power : longint) : boolean;
var
hl : longint;
i : longint;
begin
hl:=1;
ispowerof2:=true;
for i:=0 to 31 do
begin
if hl=value then
begin
power:=i;
exit;
end;
hl:=hl shl 1;
end;
ispowerof2:=false;
end;
procedure emit(i : tasmop;s : topsize;const t : string);
var
p : pasmrec;
b : array[0..255] of char;
begin
if (i=PUSH) or (i=PUSHAD) then pushgened:=true;
{$ifdef tp}
if use_big then
p:=hasmrec
else
{$endif}
new(p);
p^.linenr:=inputstack^.line_no;
p^.infile:=inputstack;
p^.instruc:=i;
p^.disposing:=D_STRING;
p^.opsize:=s;
{$ifdef tp}
if use_big then
begin
strpcopy(b,t);
p^.t:=pchar(symbolstream.size);
symbolstream.seek(longint(p^.t));
symbolstream.strwrite(b);
end
else
{$endif}
p^.t:=strpnew(t);
p^.next:=nil;
{$ifdef tp}
if use_big then
begin
p:=pasmrec(symbolstream.size);
symbolstream.seek(symbolstream.size);
symbolstream.write(hasmrec^,sizeof(tasmrec));
if exprasmlist.wurzel=nil then
exprasmlist.wurzel:=p
else setnext(exprasmlist.last,p);
exprasmlist.last:=p;
end
else
{$endif}
begin
if exprasmlist.wurzel=nil then exprasmlist.wurzel:=p
else exprasmlist.last^.next:=p;
exprasmlist.last:=p;
end;
end;
procedure emitl(i : tasmop;l : longint);
var
p : pasmrec;
begin
{$ifdef tp}
if use_big then
p:=hasmrec
else
{$endif}
new(p);
{ if jumpoptimize then
begin
if i<>A_LABEL then registerused(p,l)
else getinforec(l)^.defined:=p;
end; }
p^.linenr:=inputstack^.line_no;
p^.infile:=inputstack;
p^.instruc:=i;
p^.opsize:=S_NO;
p^.disposing:=D_LABEL;
p^.l:=l;
p^.next:=nil;
{$ifdef tp}
if use_big then
begin
p:=pasmrec(symbolstream.size);
symbolstream.seek(symbolstream.size);
symbolstream.write(hasmrec^,sizeof(tasmrec));
if exprasmlist.wurzel=nil then
exprasmlist.wurzel:=p
else setnext(exprasmlist.last,p);
exprasmlist.last:=p;
end
else
{$endif}
begin
if exprasmlist.wurzel=nil then exprasmlist.wurzel:=p
else exprasmlist.last^.next:=p;
exprasmlist.last:=p;
end;
end;
procedure emit_reg_reg(i : tasmop;s : topsize;reg1,reg2 : tregister);
begin
if (reg1<>reg2) or (i<>MOV) then
emit(i,s,regid2str[reg1]+','+regid2str[reg2]);
end;
procedure maketojumpbool(p : ptree);
begin
if p^.error then
exit;
if (p^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.resulttype)^.typ=bool8bit) then
begin
if is_constboolnode(p) then
begin
if p^.value<>0 then
emitl(JMP,truelabel)
else emitl(JMP,falselabel);
end
else
begin
case p^.location.loc of
LOC_CREGISTER,LOC_REGISTER : begin
emit(A_OR,S_B,regid2str[p^.location.register]+
','+regid2str[p^.location.register]);
emitl(JNZ,truelabel);
emitl(JMP,falselabel);
end;
LOC_MEM,LOC_REFERENZ : begin
emit(CMP,S_B,'$0,'+getreferenzstring(p^.location.referenz));
emitl(JNZ,truelabel);
emitl(JMP,falselabel);
end;
LOC_FLAGS : begin
emitl(flag_2_jmp[p^.location.resflags],truelabel);
emitl(JMP,falselabel);
end;
end;
end;
end
else
error(type_mismatch);
end;
procedure emitoverflowcheck;
var
hl : longint;
begin
if cs_check_overflow in aktswitches then
begin
hl:=getlabel;
emitl(JNO,hl);
emit(CALL,S_NO,'RE_OVERFLOW');
emitl(A_LABEL,hl);
end;
end;
procedure emitpushreferenzaddr(const ref : treferenz);
begin
if ref.isintvalue then
emit(PUSH,S_L,'$'+tostr(ref.offset))
else
begin
if (ref.base=R_NO) and (ref.index=R_NO) then
emit(PUSH,S_L,'$'+getreferenzstring(ref))
else if (ref.base=R_NO) and (ref.index<>R_NO) and
(ref.offset=0) and (ref.scalefactor=0) and (ref.symbol=nil) then
emit(PUSH,S_L,regid2str[ref.index])
else if (ref.base<>R_NO) and (ref.index=R_NO) and
(ref.offset=0) and (ref.symbol=nil) then
emit(PUSH,S_L,regid2str[ref.base])
else
begin
emit(LEA,S_L,getreferenzstring(ref)+',%edi');
emit(PUSH,S_L,'%edi');
end;
end;
end;
{ lädt falls notwendig, ESI nach einem Call neu }
procedure maybe_loadesi;
begin
if assigned(procinfo._class) then
emit(MOV,S_NO,tostr(procinfo.ESI_offset)+'(%ebp),%esi');
end;
type
tpushed = array[R_EAX..R_EBX] of boolean;
procedure pushusedregisters(var pushed : tpushed;b : byte);
var
r : tregister;
begin
for r:=R_EAX to R_EBX do
begin
pushed[r]:=false;
{ wenn das Register von dem aufgerufenen Unterprogramm }
{ verwendet wird: }
if ((b and ($80 shr byte(r)))<>0) then
begin
{ und momentan belegt ist }
if not(r in unused) then
begin
{ dann retten... }
emit(PUSH,S_L,regid2str[r]);
unused:=unused+[r];
pushed[r]:=true;
end;
end;
end;
end;
procedure genconstadd(size : topsize;l : longint;const str : string);
begin
if l=0 then
else if l=1 then
emit(A_INC,size,str)
else if l=-1 then
emit(A_INC,size,str)
else
emit(ADD,size,'$'+tostr(l)+','+str);
end;
procedure popusedregisters(const pushed : tpushed);
var
r : tregister;
begin
for r:=R_EBX downto R_EAX do
if pushed[r] then
begin
emit(POP,S_L,regid2str[r]);
unused:=unused-[r];
end;
end;
procedure concatcopy(source,dest : treferenz;size : longint;delsource : boolean);
var
ecxpushed : boolean;
helpsize : longint;
i : byte;
reg8,reg32 : tregister;
swap : boolean;
begin
if delsource then
del_referenz(source);
{ ab 12 Bytes wird movs verwendet }
if (size<=8) or (not(cs_littlesize in aktswitches ) and (size<=12)) then
begin
helpsize:=size div 4;
for i:=1 to helpsize do
begin
emit(MOV,S_L,getreferenzstring(source)+',%edi');
emit(MOV,S_L,'%edi,'+getreferenzstring(dest));
inc(source.offset,4);
inc(dest.offset,4);
dec(size,4);
end;
if size>1 then
begin
emit(MOV,S_W,getreferenzstring(source)+',%di');
emit(MOV,S_W,'%di,'+getreferenzstring(dest));
inc(source.offset,2);
inc(dest.offset,2);
dec(size,2);
end;
if size>0 then
begin
{ nun ein 8-Bit Register suchen }
swap:=false;
if R_EAX in unused then reg8:=R_AL
else if R_EBX in unused then reg8:=R_BL
else if R_ECX in unused then reg8:=R_CL
else if R_EDX in unused then reg8:=R_DL
else
begin
swap:=true;
{ wir müssen nur 3 Register untersuchen, da dann }
{ immer eines nicht Index oder Base ist }
if (dest.base<>R_EAX) and (dest.index<>R_EAX) then
begin
reg8:=R_AL;
reg32:=R_EAX;
end
else if (dest.base<>R_EBX) and (dest.index<>R_EBX) then
begin
reg8:=R_BL;
reg32:=R_EBX;
end
else if (dest.base<>R_ECX) and (dest.index<>R_ECX) then
begin
reg8:=R_CL;
reg32:=R_ECX;
end;
end;
if swap then
{ war früher XCHG, natürlich Quatsch }
emit_reg_reg(MOV,S_L,reg32,R_EDI);
emit(MOV,S_B,getreferenzstring(source)+','+regid2str[reg8]);
emit(MOV,S_B,regid2str[reg8]+','+getreferenzstring(dest));
if swap then
emit_reg_reg(MOV,S_L,R_EDI,reg32);
end;
end
else
begin
emit(LEA,S_L,getreferenzstring(source)+',%esi');
emit(LEA,S_L,getreferenzstring(dest)+',%edi');
del_referenz(dest);
if not(R_ECX in unused) then
begin
emit(PUSH,S_L,'%ecx');
ecxpushed:=true;
end
else ecxpushed:=false;
emit(CLD,S_NO,'');
if cs_littlesize in aktswitches then
begin
if size mod 4=0 then
begin
emit(MOV,S_L,'$'+tostr(size div 4)+',%ecx');
emit(REP,S_NO,'');
emit(MOVS,S_L,'');
end
else if size mod 2=0 then
begin
emit(MOV,S_L,'$'+tostr(size div 2)+',%ecx');
emit(REP,S_NO,'');
emit(MOVS,S_W,'');
end
else
begin
emit(MOV,S_L,'$'+tostr(size)+',%ecx');
emit(REP,S_NO,'');
emit(MOVS,S_B,'');
end;
end
else
begin
helpsize:=size-size mod 4;
size:=size mod 4;
emit(MOV,S_L,'$'+tostr(helpsize div 4)+',%ecx');
emit(REP,S_NO,'');
emit(MOVS,S_L,'');
if size>1 then
begin
dec(size,2);
emit(MOVS,S_W,'');
end;
if size=1 then
emit(MOVS,S_B,'');
end;
if ecxpushed then
emit(POP,S_L,'%ecx');
{ SELF-Referenz wieder laden }
if assigned(procinfo._class) then
emit(MOV,S_NO,tostr(procinfo.ESI_offset)+'(%ebp),%esi');
end;
end;
procedure copystring(const dref,sref : treferenz;len : byte);
var
pushed : tpushed;
begin
pushusedregisters(pushed,$ff);
emitpushreferenzaddr(dref);
emitpushreferenzaddr(sref);
emit(PUSH,S_L,'$'+tostr(len));
emit(CALL,S_NO,'STRCOPY');
maybe_loadesi;
popusedregisters(pushed);
end;
procedure restore(p : ptree);
var
hregister : tregister;
begin
hregister:=getregister32;
emit(POP,S_L,regid2str[hregister]);
if (p^.location.loc=LOC_REGISTER) or (p^.location.loc=LOC_CREGISTER) then
begin
p^.location.register:=hregister;
end
else
begin
clear_referenz(p^.location.referenz);
p^.location.referenz.index:=hregister;
end;
end;
function maybe_push(needed : byte;p : ptree) : boolean;
var
pushed : boolean;
hregister : tregister;
begin
if needed>usablereg32 then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
begin
pushed:=true;
emit(PUSH,S_L,regid2str[p^.location.register]);
ungetregister32(p^.location.register);
end
else if ((p^.location.loc=LOC_MEM) or
(p^.location.loc=LOC_REFERENZ)
) and
((p^.location.referenz.base<>R_NO) or
(p^.location.referenz.index<>R_NO)
) then
begin
del_referenz(p^.location.referenz);
hregister:=getregister32;
emit(LEA,S_L,getreferenzstring(p^.location.referenz)+','
+regid2str[hregister]);
emit(PUSH,S_L,regid2str[hregister]);
ungetregister32(hregister);
pushed:=true;
end
else pushed:=false;
end
else pushed:=false;
maybe_push:=pushed;
end;
procedure seconderror(var p : ptree);far;
begin
p^.error:=true;
codegenerror:=true;
end;
procedure secondload(var p : ptree);far;
var
hregister : tregister;
symtabletype,i : longint;
begin
simple_loadn:=true;
clear_referenz(p^.location.referenz);
case p^.symtableentry^.typ of
varsym :
begin
hregister:=R_NO;
symtabletype:=p^.symtable^.symtabletype;
{ falls es sich um eine Registervariable handelt: }
if pvarsym(p^.symtableentry)^.reg<>R_NO then
begin
p^.location.loc:=LOC_CREGISTER;
p^.location.register:=pvarsym(p^.symtableentry)^.reg;
end
else
begin
{ erst lokale und Uebergabevariablen behandeln }
if (symtabletype and $c000)<>0 then
begin
p^.location.referenz.base:=R_EBP;
p^.location.referenz.offset:=pvarsym(p^.symtableentry)^.adresse;
if (symtabletype and $8000<>0) then
p^.location.referenz.offset:=-p^.location.referenz.offset;
if (symtabletype and $4000<>0) then
inc(p^.location.referenz.offset,longint(p^.symtable^.name));
if (lexlevel>(p^.symtable^.symtabletype and $3fff)) then
begin
hregister:=getregister32;
emit(MOV,S_L,tostr(procinfo.framepointer)+'(%ebp),'+regid2str[hregister]);
simple_loadn:=false;
i:=lexlevel-1;
while i>(p^.symtable^.symtabletype and $3fff) do
begin
if procinfo.exceptions then
emit(MOV,S_L,'12('+regid2str[hregister]+'),'+regid2str[hregister])
else
emit(MOV,S_L,'8('+regid2str[hregister]+'),'+regid2str[hregister]);
dec(i);
end;
p^.location.referenz.base:=hregister;
end;
end
else
case p^.symtable^.symtabletype of
staticsymtable : begin
p^.location.referenz.symbol:=stringdup('_'+p^.symtableentry^.name);
end;
unitsymtable,globalsymtable : begin
p^.location.referenz.symbol:=stringdup('U_'+
p^.symtable^.name^+'_'+p^.symtableentry^.name);
end;
objectsymtable : begin
p^.location.referenz.base:=R_ESI;
p^.location.referenz.offset:=pvarsym(p^.symtableentry)^.adresse;
end;
withsymtable : begin
hregister:=getregister32;
p^.location.referenz.base:=hregister;
emit(MOV,S_L,tostr(p^.symtable^.datasize)+'(%ebp),'+
regid2str[hregister]);
p^.location.referenz.offset:=
pvarsym(p^.symtableentry)^.adresse;
end;
end;
{ falls Call by Referenz, dann berechenen: }
if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
((pvarsym(p^.symtableentry)^.varspez=vs_const) and
(
(pvarsym(p^.symtableentry)^.definition^.deftype=stringdef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=arraydef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=recorddef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=classdef) or
(pvarsym(p^.symtableentry)^.definition^.deftype=setdef)
)
) then
begin
simple_loadn:=false;
if hregister=R_NO then
hregister:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.location.referenz)+','+regid2str[hregister]);
clear_referenz(p^.location.referenz);
p^.location.referenz.base:=hregister;
end;
end;
end;
procsym:
begin
{!!!!! Vorsicht, auch virtuelle Methoden bearbeiten}
p^.location.referenz.symbol:=
stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
end;
typedconstsym :
begin
p^.location.referenz.symbol:=stringdup(
'TC_'+ptypedconstsym(p^.symtableentry)^.prefix^+'_'+
+p^.symtableentry^.name);
end;
else internalerror(4);
end;
end;
procedure firstcomplex(p : ptree);
var
hp : ptree;
begin
{ boolsches AND und OR immer von links nach rechts auswerten }
if ((p^.treetype=orn) or (p^.treetype=andn)) and
(p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=bool8bit) then
exit;
if (p^.left^.registers32<p^.right^.registers32)
{ folgende Abfrage ist sinnvoll, da }
{ selten alle 4 Register gebraucht werden und }
{ damit erreicht wird, daß der zusätzliche Code }
{ bei vertauschten nichtkommutativen Operatoren }
{ entfällt }
and (p^.right^.registers32<=4) then
begin
hp:=p^.left;
p^.left:=p^.right;
p^.right:=hp;
p^.swaped:=true;
end
else p^.swaped:=false;
end;
procedure secondadd(var p : ptree);far;
{ (wird auch für xor,and,"mul","sub",or und Vergleichsoperatoren }
{ verwendet) }
var
swapp : ptree;
hregister : tregister;
pushed,mboverflow,cmpop : boolean;
op : tasmop;
swapl : tlocation;
pushedregs : tpushed;
flags : tresflags;
otl,ofl,power : longint;
href : treferenz;
opsize : topsize;
{ true, falls vorzeichenlose Typen verglichen werden }
unsigned : boolean;
begin
unsigned:=false;
opsize:=S_L;
{ den komplexeren Operanden berechnen }
firstcomplex(p);
{ bool'sche Ausdruecke extra behandeln: }
if ((p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=bool8bit)) then
{ ((p^.right^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.right^.resulttype)^.typ=bool8bit)) then }
begin
if (p^.treetype=andn) or (p^.treetype=orn) then
begin
p^.location.loc:=LOC_JUMP;
cmpop:=false;
case p^.treetype of
andn : begin
otl:=truelabel;
truelabel:=getlabel;
secondpass(p^.left);
maketojumpbool(p^.left);
emitl(A_LABEL,truelabel);
truelabel:=otl;
end;
orn : begin
ofl:=falselabel;
falselabel:=getlabel;
secondpass(p^.left);
maketojumpbool(p^.left);
emitl(A_LABEL,falselabel);
falselabel:=ofl;
end;
else error(type_mismatch);
end;
secondpass(p^.right);
maketojumpbool(p^.right);
end
{ else if (p^.treetype=unequaln) or (p^.treetype=equaln) then
begin
opsize:=S_B;
if p^.left^.treetype=boolconstn then
begin
swapp:=p^.right;
p^.right:=p^.left;
p^.left:=swapp;
p^.swaped:=not(p^.swaped);
end;
secondpass(p^.left);
p^.location:=p^.left^.location;
(* sind zuwenig Register frei? *)
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
goto do_normal;
end }
else error(type_mismatch);
end
{ Stringooperationen auch seperat behandeln }
else if (p^.left^.resulttype^.deftype=stringdef) then
begin
{ String-Operationen sind nicht kommutativ }
if p^.swaped then
begin
swapp:=p^.left;
p^.left:=p^.right;
p^.right:=swapp;
{ wegen der Sprungerzeugung bei Vergleichen unten: }
p^.swaped:=not(p^.swaped);
end;
case p^.treetype of
addn : begin
cmpop:=false;
secondpass(p^.left);
if (p^.left^.treetype<>addn) then
begin
{ kann nur Referenz sein }
{ String in Register wäre komisch }
{ also einen temporären String erzeugen }
del_referenz(p^.left^.location.referenz);
pushusedregisters(pushedregs,$ff);
clear_referenz(href);
href.offset:=gettempofsize(256);
href.base:=R_EBP;
emitpushreferenzaddr(href);
emitpushreferenzaddr(p^.left^.location.referenz);
emit(PUSH,S_L,'$255');
emit(CALL,S_NO,'STRCOPY');
maybe_loadesi;
popusedregisters(pushedregs);
{ schadet nicht: }
p^.left^.location.loc:=LOC_MEM;
p^.left^.location.referenz:=href;
end;
secondpass(p^.right);
{ Rechts brauchen wir die Register auch nicht mehr }
del_referenz(p^.right^.location.referenz);
pushusedregisters(pushedregs,$ff);
emitpushreferenzaddr(p^.left^.location.referenz);
emitpushreferenzaddr(p^.right^.location.referenz);
emit(CALL,S_NO,'STRCONCAT');
p^.location:=p^.left^.location;
maybe_loadesi;
popusedregisters(pushedregs);
end;
ltn,lten,gtn,gten,
equaln,unequaln :
begin
secondpass(p^.left);
{ sind zuwenig Register frei? }
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
cmpop:=true;
del_referenz(p^.right^.location.referenz);
del_referenz(p^.left^.location.referenz);
pushusedregisters(pushedregs,$ff);
emitpushreferenzaddr(p^.left^.location.referenz);
emitpushreferenzaddr(p^.right^.location.referenz);
emit(CALL,S_NO,'STRCMP');
maybe_loadesi;
popusedregisters(pushedregs);
end;
else error(type_mismatch);
end;
end
else
begin
{ falls eine Konstante dabei, so kommt diese nach rechts }
if p^.left^.treetype=ordconstn then
begin
swapp:=p^.right;
p^.right:=p^.left;
p^.left:=swapp;
p^.swaped:=not(p^.swaped);
end;
secondpass(p^.left);
p^.location:=p^.left^.location;
{ sind zuwenig Register frei? }
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
if (p^.left^.resulttype^.deftype=pointerdef) or
(p^.right^.resulttype^.deftype=pointerdef) or
(p^.left^.resulttype^.deftype=procvardef) or
(p^.left^.resulttype^.deftype=aufzaehldef) or
((p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=s32bit)) or
((p^.right^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.right^.resulttype)^.typ=s32bit)) then
begin
{ do_normal: }
mboverflow:=false;
cmpop:=false;
if (p^.left^.resulttype^.deftype=pointerdef) or
(p^.right^.resulttype^.deftype=pointerdef) then
unsigned:=true;
case p^.treetype of
addn : begin
op:=ADD;
mboverflow:=true;
end;
muln : begin
op:=IMUL;
mboverflow:=true;
end;
subn : begin
op:=SUB;
mboverflow:=true;
end;
ltn,lten,gtn,gten,
equaln,unequaln :
begin
op:=CMP;
cmpop:=true;
end;
xorn : op:=A_XOR;
orn : op:=A_OR;
andn : op:=A_AND;
slashn : begin
op:=SUB;
error(use_int_div_int_op);
end;
else error(type_mismatch);
end;
{ links und rechts kein Register ? }
{ dann muß eins angefordert werden }
if (p^.location.loc<>LOC_REGISTER) and
(p^.right^.location.loc<>LOC_REGISTER) then
begin
{ Registervariable ? }
if (p^.location.loc=LOC_CREGISTER) then
begin
if cmpop then
begin
{ zerstört das Register nicht }
hregister:=p^.location.register;
end
else
begin
case opsize of
S_L : hregister:=getregister32;
S_B : hregister:=reg32toreg8(getregister32);
end;
emit_reg_reg(MOV,opsize,p^.location.register,
hregister);
end
end
else
begin
del_referenz(p^.location.referenz);
{ erst freigeben, dann neues Register anfordern }
case opsize of
S_L : hregister:=getregister32;
S_B : hregister:=reg32toreg8(getregister32);
end;
emit(MOV,opsize,getreferenzstring(p^.location.referenz)+','
+regid2str[hregister]);
end;
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister;
end
else
{ wenn rechts das Register, dann vertauschen }
if (p^.right^.location.loc=LOC_REGISTER) then
begin
swapl:=p^.location;
p^.location:=p^.right^.location;
p^.right^.location:=swapl;
{ erneut vertauscht, also swaped-Flag neu setzten }
p^.swaped:=not(p^.swaped);
end;
if p^.right^.location.loc<>LOC_REGISTER then
begin
if (p^.treetype=subn) and p^.swaped then
begin
if p^.right^.location.loc=LOC_CREGISTER then
begin
emit_reg_reg(MOV,opsize,p^.right^.location.register,R_EDI);
emit_reg_reg(SUB,opsize,p^.location.register,R_EDI);
emit_reg_reg(MOV,opsize,R_EDI,p^.location.register);
end
else
begin
emit(MOV,opsize,getreferenzstring(p^.right^.location.referenz)+',%edi');
emit(SUB,opsize,regid2str[p^.location.register]+',%edi');
emit(MOV,opsize,'%edi,'+regid2str[p^.location.register]);
del_referenz(p^.right^.location.referenz);
end;
end
else
begin
if (p^.right^.treetype=ordconstn) and
(op=CMP) and
(p^.right^.value=0) then
begin
emit(A_TEST,opsize,
regid2str[p^.location.register]+','
+regid2str[p^.location.register]);
end
else if (p^.right^.treetype=ordconstn) and
(op=ADD) and
(p^.right^.value=1) then
begin
emit(A_INC,opsize,
regid2str[p^.location.register]);
end
else if (p^.right^.treetype=ordconstn) and
(op=SUB) and
(p^.right^.value=1) then
begin
emit(A_DEC,opsize,
regid2str[p^.location.register]);
end
else if (p^.right^.treetype=ordconstn) and
(op=IMUL) and
(ispowerof2(p^.right^.value,power)) then
begin
emit(A_SHL,opsize,'$'+tostr(power)+','+
+regid2str[p^.location.register]);
end
else
begin
if (p^.right^.location.loc=LOC_CREGISTER) then
begin
emit_reg_reg(op,opsize,p^.right^.location.register,
p^.location.register);
end
else
begin
emit(op,opsize,getreferenzstring(
p^.right^.location.referenz)+','
+regid2str[p^.location.register]);
del_referenz(p^.right^.location.referenz);
end;
end;
end;
end
else
begin
{ wenn vertauscht, anderes Ergebnis-Register }
if (p^.treetype=subn) and p^.swaped then
begin
emit(SUB,opsize,
regid2str[p^.location.register]+','+
regid2str[p^.right^.location.register]);
swapl:=p^.location;
p^.location:=p^.right^.location;
p^.right^.location:=swapl;
{ erneut vertauscht, also swaped-Flag }
{ neu setzten (nur der Ordnung halber) }
p^.swaped:=not(p^.swaped);
end
else
begin
emit(op,opsize,
regid2str[p^.right^.location.register]+','
+regid2str[p^.location.register]);
end;
case opsize of
S_L : ungetregister32(p^.right^.location.register);
S_B : ungetregister32(reg8toreg32(p^.right^.location.register));
end;
end;
if cmpop then
case opsize of
S_L : ungetregister32(p^.location.register);
S_B : ungetregister32(reg8toreg32(p^.location.register));
end;
{ Nur wenn Overflow verdächtige Operation }
{ Overflow-Code erzeugen }
if mboverflow then
emitoverflowcheck;
end
else if ((p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=uchar)) then
begin
case p^.treetype of
ltn,lten,gtn,gten,
equaln,unequaln :
cmpop:=true;
else error(type_mismatch);
end;
unsigned:=true;
{ links und rechts kein Register ? }
{ dann muß eins angefordert werden }
if (p^.location.loc<>LOC_REGISTER) and
(p^.right^.location.loc<>LOC_REGISTER) then
begin
if p^.location.loc=LOC_CREGISTER then
begin
if cmpop then
{ zerstört kein Register }
hregister:=p^.location.register
else
begin
hregister:=reg32toreg8(getregister32);
emit_reg_reg(MOV,S_B,p^.location.register,
hregister);
end;
end
else
begin
del_referenz(p^.location.referenz);
{ erst freigeben, dann neues Register anfordern }
hregister:=reg32toreg8(getregister32);
emit(MOV,S_B,getreferenzstring(p^.location.referenz)+','
+regid2str[hregister]);
end;
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister;
end;
{ nun p nun auf jeden Fall Register }
if (p^.right^.location.loc=LOC_REGISTER) and
(p^.location.loc<>LOC_REGISTER) then
begin
swapl:=p^.location;
p^.location:=p^.right^.location;
p^.right^.location:=swapl;
{ erneut vertauscht, also swaped-Flag neu setzten }
p^.swaped:=not(p^.swaped);
end;
if p^.right^.location.loc<>LOC_REGISTER then
begin
if p^.right^.location.loc=LOC_CREGISTER then
begin
emit_reg_reg(CMP,S_B,
p^.right^.location.register,p^.location.register);
end
else
begin
emit(CMP,S_B,getreferenzstring(
p^.right^.location.referenz)+','
+regid2str[p^.location.register]);
del_referenz(p^.right^.location.referenz);
end;
end
else
begin
emit_reg_reg(CMP,S_L,p^.right^.location.register,
p^.location.register);
ungetregister32(reg8toreg32(p^.right^.location.register));
end;
ungetregister32(reg8toreg32(p^.location.register));
end
else if ((p^.left^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.left^.resulttype)^.typ=s64real)) then
begin
{ Realkonstante nach rechts }
if p^.left^.treetype=realconstn then
begin
swapp:=p^.right;
p^.right:=p^.left;
p^.left:=swapp;
p^.swaped:=not(p^.swaped);
end;
cmpop:=false;
case p^.treetype of
addn : op:=FADDP;
muln : op:=FMULP;
subn : op:=FSUBP;
slashn : op:=FDIVP;
ltn,lten,gtn,gten,
equaln,unequaln : begin
op:=FCOMPP;
cmpop:=true;
end;
else error(type_mismatch);
end;
{ links nicht auf dem Stack, dann laden }
if (p^.left^.location.loc<>LOC_FPUSTACK) then
emit(FLD,S_L,getreferenzstring(p^.left^.location.referenz));
if (p^.right^.location.loc<>LOC_FPUSTACK) then
emit(FLD,S_L,getreferenzstring(p^.right^.location.referenz));
if p^.swaped then
begin
if (p^.treetype=slashn) then
op:=FDIVRP;
if (p^.treetype=subn) then
op:=FSUBRP;
end;
{
if (op=FDIVP) and (opt_processors=pentium) then
emit(CALL,S_NO,'EMUL_FDIVP')
else
}
emit(op,S_NO,'');
{ bei Vergleich Flags laden }
if cmpop then
begin
if not(R_EAX in unused) then
emit_reg_reg(MOV,S_L,R_EAX,R_EDI);
emit(FNSTS,S_W,'%ax');
emit(SAHF,S_NO,'');
if not(R_EAX in unused) then
emit_reg_reg(MOV,S_L,R_EDI,R_EAX);
if p^.swaped then
case p^.treetype of
equaln : flags:=F_E;
unequaln : flags:=F_NE;
ltn : flags:=F_B;
lten : flags:=F_AE;
gtn : flags:=F_B;
gten : flags:=F_AE;
end
else
case p^.treetype of
equaln : flags:=F_E;
unequaln : flags:=F_NE;
ltn : flags:=F_A;
lten : flags:=F_AE;
gtn : flags:=F_B;
gten : flags:=F_BE;
end;
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=flags;
cmpop:=false;
end
else
p^.location.loc:=LOC_FPUSTACK;
end
else if (p^.left^.resulttype^.deftype=setdef) then
begin
{ nicht kommutativ }
if p^.swaped then
begin
swapp:=p^.left;
p^.left:=p^.right;
p^.right:=swapp;
{ wegen der Sprungerzeugung bei Vergleichen }
p^.swaped:=not(p^.swaped);
end;
case p^.treetype of
addn,subn,muln : begin
cmpop:=false;
del_referenz(p^.left^.location.referenz);
del_referenz(p^.right^.location.referenz);
clear_referenz(href);
href.offset:=gettempofsize(32);
href.base:=R_EBP;
emitpushreferenzaddr(href);
pushusedregisters(pushedregs,$ff);
emitpushreferenzaddr(p^.right^.location.referenz);
emitpushreferenzaddr(p^.left^.location.referenz);
case p^.treetype of
subn : emit(CALL,S_NO,'SET_SUB_SETS');
addn : emit(CALL,S_NO,'SET_ADD_SETS');
muln : emit(CALL,S_NO,'SET_MUL_SETS');
end;
maybe_loadesi;
popusedregisters(pushedregs);
p^.location.loc:=LOC_MEM;
p^.location.referenz:=href;
end;
else error(type_mismatch);
end;
end
else error(type_mismatch);
end;
{ Sollte es ein Vergleichsoperator sein, dann Ergebnis in den Flags }
if cmpop then
begin
if not(unsigned) then
begin
if p^.swaped then
case p^.treetype of
equaln : flags:=F_E;
unequaln : flags:=F_NE;
ltn : flags:=F_G;
lten : flags:=F_GE;
gtn : flags:=F_L;
gten : flags:=F_LE;
end
else
case p^.treetype of
equaln : flags:=F_E;
unequaln : flags:=F_NE;
ltn : flags:=F_L;
lten : flags:=F_LE;
gtn : flags:=F_G;
gten : flags:=F_GE;
end;
end
else
begin
if p^.swaped then
case p^.treetype of
equaln : flags:=F_E;
unequaln : flags:=F_NE;
ltn : flags:=F_A;
lten : flags:=F_AE;
gtn : flags:=F_B;
gten : flags:=F_BE;
end
else
case p^.treetype of
equaln : flags:=F_E;
unequaln : flags:=F_NE;
ltn : flags:=F_B;
lten : flags:=F_BE;
gtn : flags:=F_A;
gten : flags:=F_AE;
end;
end;
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=flags;
end;
end;
procedure secondmoddiv(var p : ptree);far;
var
hreg1 : tregister;
pushed,popeax,popedx : boolean;
power,hl : longint;
begin
secondpass(p^.left);
p^.location:=p^.left^.location;
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
{ Zaehler in Register bringen }
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
hreg1:=getregister32;
emit_reg_reg(MOV,S_L,p^.left^.location.register,hreg1);
end
else
begin
del_referenz(p^.left^.location.referenz);
hreg1:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)+','+
regid2str[hreg1]);
end;
p^.left^.location.loc:=LOC_REGISTER;
p^.left^.location.register:=hreg1;
end
else hreg1:=p^.left^.location.register;
if (p^.treetype=divn) and (p^.right^.treetype=ordconstn) and
ispowerof2(p^.right^.value,power) then
begin
emit(A_OR,S_L,regid2str[hreg1]+','+
regid2str[hreg1]);
hl:=getlabel;
emitl(JNS,hl);
if power=1 then
emit(A_INC,S_L,regid2str[hreg1])
else emit(ADD,S_L,'$'+tostr(p^.right^.value-1)+','+regid2str[hreg1]);
emitl(A_LABEL,hl);
emit(SAR,S_L,'$'+tostr(power)+','+regid2str[hreg1]);
end
else
begin
{ Nenner nach EDI bringen }
if (p^.right^.location.loc<>LOC_REGISTER) and
(p^.right^.location.loc<>LOC_CREGISTER) then
begin
del_referenz(p^.right^.location.referenz);
p^.left^.location.loc:=LOC_REGISTER;
emit(MOV,S_L,getreferenzstring(p^.right^.location.referenz)+',%edi');
end
else
begin
ungetregister32(p^.right^.location.register);
emit_reg_reg(MOV,S_L,p^.right^.location.register,R_EDI);
end;
popedx:=false;
popeax:=false;
if hreg1=R_EDX then
begin
if not(R_EAX in unused) then
begin
emit(PUSH,S_L,'%eax');
popeax:=true;
end;
emit_reg_reg(MOV,S_L,R_EDX,R_EAX);
end
else
begin
if not(R_EDX in unused) then
begin
emit(PUSH,S_L,'%edx');
popedx:=true;
end;
if hreg1<>R_EAX then
begin
if not(R_EAX in unused) then
begin
emit(PUSH,S_L,'%eax');
popeax:=true;
end;
emit_reg_reg(MOV,S_L,hreg1,R_EAX);
end;
end;
emit(CLTD,S_NO,'');
emit(IDIV,S_L,'%edi');
if p^.treetype=divn then
begin
{ wenn das Ergebnisregister belegt ist, dann umkopieren }
if popeax then
begin
if hreg1=R_EAX then
internalerror(112);
emit_reg_reg(MOV,S_L,R_EAX,hreg1)
end
else
if hreg1<>R_EAX then
emit_reg_reg(MOV,S_L,R_EAX,hreg1);
end
else
begin
if popedx then
begin
if hreg1=R_EDX then
internalerror(112);
emit_reg_reg(MOV,S_L,R_EDX,hreg1)
end
else
if hreg1<>R_EDX then
emit_reg_reg(MOV,S_L,R_EDX,hreg1);
end;
if popeax then
emit(POP,S_L,'%eax');
if popedx then
emit(POP,S_L,'%edx');
end;
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hreg1;
end;
procedure secondshlshr(var p : ptree);far;
var
hregister1,hregister2,hregister3 : tregister;
pushed,popecx : boolean;
op : tasmop;
begin
popecx:=false;
secondpass(p^.left);
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
{ linken Operanden in ein Register laden }
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
hregister1:=getregister32;
emit_reg_reg(MOV,S_L,p^.left^.location.register,
hregister1);
end
else
begin
del_referenz(p^.left^.location.referenz);
hregister1:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)+
','+regid2str[hregister1]);
end;
end
else hregister1:=p^.left^.location.register;
{ Operator feststellen }
if p^.treetype=shln then
op:=A_SHL
else
op:=A_SHR;
{ Verschiebung mit einer Konstante direkt auscodieren: }
if (p^.right^.treetype=ordconstn) then
begin
emit(op,S_L,'$'+tostr(p^.right^.location.referenz.offset mod 32)
+','+regid2str[hregister1]);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister1;
end
else
begin
{ rechten Operanden in ein Register laden }
if p^.right^.location.loc<>LOC_REGISTER then
begin
if p^.right^.location.loc=LOC_CREGISTER then
begin
hregister2:=getregister32;
emit_reg_reg(MOV,S_L,p^.right^.location.register,
hregister2);
end
else
begin
del_referenz(p^.right^.location.referenz);
hregister2:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.right^.location.referenz)+
','+regid2str[hregister2]);
end;
end
else hregister2:=p^.right^.location.register;
{ linker Operand ist schon in einem Register }
{ also sind beide in einem Register }
{ handelt es sich dabei um ECX ? }
if (hregister1=R_ECX) then
begin
{ dann nur vertauschen }
emit(XCHG,S_L,regid2str[hregister1]+','+
regid2str[hregister2]);
hregister3:=hregister1;
hregister1:=hregister2;
hregister2:=hregister3;
end
{ wenn zweiter Operand nicht in ECX ? }
else if (hregister2<>R_ECX) then
begin
{ ECX nicht belegt, dann mit rechtem Register austauschen }
if R_ECX in unused then
begin
emit_reg_reg(MOV,S_L,hregister2,R_ECX);
ungetregister32(hregister2);
end
else
begin
{ ansonsten ECX retten und dann umkopieren }
popecx:=true;
emit(PUSH,S_L,'%ecx');
emit_reg_reg(MOV,S_L,hregister2,R_ECX);
ungetregister32(hregister2);
end;
end;
{ rechter Operand ist in ECX }
emit_reg_reg(op,S_L,R_CL,hregister1);
{ vielleicht ECX zurück }
if popecx then
emit(POP,S_L,'%ecx');
p^.location.register:=hregister1;
end;
end;
procedure secondrealconst(var p : ptree);far;
begin
clear_referenz(p^.location.referenz);
if p^.labnumber=-1 then
begin
p^.labnumber:=getlabel;
constsegment.insert(gennasmrec(A_DOUBLE,S_NO,double2str(p^.valued)));
constsegment.insert(genlasmrec(A_LABEL,p^.labnumber));
end;
p^.location.referenz.symbol:=stringdup(tolabel(p^.labnumber));
end;
procedure secondordconst(var p : ptree);far;
begin
{ eine Intconst. tut so, als ob sie eine Memoryreferenz wäre }
p^.location.loc:=LOC_MEM;
p^.location.referenz.isintvalue:=true;
p^.location.referenz.offset:=p^.value;
end;
procedure secondniln(var p : ptree);far;
begin
p^.location.loc:=LOC_MEM;
p^.location.referenz.isintvalue:=true;
p^.location.referenz.offset:=0;
end;
procedure secondstringconst(var p : ptree);far;
var
l : longint;
begin
clear_referenz(p^.location.referenz);
l:=getconstlabel;
p^.location.referenz.symbol:=stringdup('L'+tostr(l));
constsegment.concat(gennasmrec(DIRECT,S_NO,'L'+tostr(l)+':'));
constsegment.concat(gennasmrec(ASCII,S_NO,'"'+ibm2ascii(char(length(p^.values^))+p^.values^)+'\0"'));
end;
procedure secondumminus(var p : ptree);far;
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;
emit(NEG,S_L,regid2str[p^.location.register]);
end;
LOC_CREGISTER : begin
p^.location.register:=getregister32;
emit_reg_reg(MOV,S_L,p^.location.register,
p^.location.register);
emit(NEG,S_L,regid2str[p^.location.register]);
end;
LOC_REFERENZ,LOC_MEM :
begin
del_referenz(p^.left^.location.referenz);
if pgrunddef(p^.left^.resulttype)^.typ=s64real then
begin
p^.location.loc:=LOC_FPUSTACK;
emit(FLD,S_NO,getreferenzstring(p^.left^.location.referenz));
emit(FCHS,S_NO,'');
end
else
begin
p^.location.register:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)+
','+regid2str[p^.location.register]);
emit(NEG,S_L,regid2str[p^.location.register]);
end;
end;
LOC_FPUSTACK : begin
p^.location.loc:=LOC_FPUSTACK;
emit(FCHS,S_NO,'');
end;
end;
emitoverflowcheck;
end;
procedure secondaddr(var p : ptree);far;
begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
del_referenz(p^.left^.location.referenz);
p^.location.register:=getregister32;
emit(LEA,S_L,getreferenzstring(p^.left^.location.referenz)+','+
regid2str[p^.location.register]);
end;
procedure secondnot(var p : ptree);far;
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 : longint;
begin
if (p^.resulttype^.deftype=grunddef) and
(pgrunddef(p^.resulttype)^.typ=bool8bit) then
begin
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;
emit(A_XOR,S_B,'$1,'+regid2str[p^.location.register]);
end;
LOC_CREGISTER : begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=reg32toreg8(getregister32);
emit_reg_reg(MOV,S_B,p^.left^.location.register,
p^.location.register);
emit(A_XOR,S_B,'$1,'+regid2str[p^.location.register]);
end;
LOC_REFERENZ,LOC_MEM : begin
secondpass(p^.left);
del_referenz(p^.left^.location.referenz);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=reg32toreg8(getregister32);
emit(MOV,S_B,getreferenzstring(p^.left^.location.referenz)+
','+regid2str[p^.location.register]);
emit(A_XOR,S_B,'$1,'+regid2str[p^.location.register]);
end;
end;
end
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;
emit(A_NOT,S_L,regid2str[p^.location.register]);
end;
LOC_CREGISTER : begin
p^.location.register:=getregister32;
emit_reg_reg(MOV,S_L,p^.left^.location.register,
p^.location.register);
emit(A_NOT,S_L,regid2str[p^.location.register]);
end;
LOC_REFERENZ,LOC_MEM :
begin
del_referenz(p^.left^.location.referenz);
p^.location.register:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)+
','+regid2str[p^.location.register]);
emit(A_NOT,S_L,regid2str[p^.location.register]);
end;
end;
end;
end;
procedure secondnothing(var p : ptree);far;
begin
end;
procedure secondassignment(var p : ptree);far;
var
opsize : topsize;
pushed,withresult : boolean;
otlabel,hlabel,oflabel : longint;
lstr : string;
hregister : tregister;
begin
otlabel:=truelabel;
oflabel:=falselabel;
truelabel:=getlabel;
falselabel:=getlabel;
withresult:=not(aktexprlevel<4);
{ linke Seite berechnen }
secondpass(p^.left);
case p^.left^.location.loc of
LOC_REFERENZ : begin
{ falls der linke Operand zwei Register benötigt, }
{ aber zu wenige frei sind, dann LEA }
if (p^.left^.location.referenz.base<>R_NO) and
(p^.left^.location.referenz.index<>R_NO) and
(usablereg32<p^.right^.registers32) then
begin
del_referenz(p^.left^.location.referenz);
hregister:=getregister32;
emit(LEA,S_L,getreferenzstring(
p^.left^.location.referenz)+','+
regid2str[hregister]);
p^.left^.location.referenz.base:=hregister;
p^.left^.location.referenz.index:=R_NO;
end;
lstr:=getreferenzstring(p^.left^.location.referenz);
end;
LOC_CREGISTER : lstr:=regid2str[p^.left^.location.register];
else
begin
error(error_in_expression);
exit;
end;
end;
secondpass(p^.right);
if p^.right^.resulttype^.deftype=stringdef then
begin
{ das Ziel brauchen wir sicher nicht mehr }
del_referenz(p^.left^.location.referenz);
{ die Quelle nur, wenn withresult gesetzt: }
if not(withresult) then
del_referenz(p^.right^.location.referenz);
copystring(p^.left^.location.referenz,p^.right^.location.referenz,
min(pstringdef(p^.right^.resulttype)^.len,pstringdef(p^.left^.resulttype)^.len));
end
else case p^.right^.location.loc of
LOC_REFERENZ,
LOC_MEM : begin
{ ordinale Konstanten getrennt bearbeiten }
if (p^.right^.treetype=ordconstn) or
(p^.left^.location.loc=LOC_CREGISTER) then
begin
case p^.left^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
end;
emit(MOV,opsize,
getreferenzstring(p^.right^.location.referenz)+','+
lstr);
end
else
begin
concatcopy(p^.right^.location.referenz,
p^.left^.location.referenz,p^.left^.resulttype^.size,
withresult);
end;
end;
LOC_REGISTER,
LOC_CREGISTER : begin
case p^.right^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
end;
emit(MOV,opsize,
regid2str[p^.right^.location.register]+','+
lstr);
end;
LOC_FPUSTACK : emit(FSTP,S_L,lstr);
LOC_JUMP : begin
hlabel:=getlabel;
emitl(A_LABEL,truelabel);
emit(MOV,S_B,'$1,'+lstr);
emitl(JMP,hlabel);
emitl(A_LABEL,falselabel);
emit(MOV,S_B,'$0,'+lstr);
emitl(A_LABEL,hlabel);
end;
LOC_FLAGS : emit(flag_2_set[p^.right^.location.resflags],S_NO,lstr);
end;
truelabel:=otlabel;
falselabel:=oflabel;
end;
procedure secondderef(var p : ptree);far;
var
hr : tregister;
begin
secondpass(p^.left);
clear_referenz(p^.location.referenz);
case p^.left^.location.loc of
LOC_REGISTER : p^.location.referenz.base:=p^.left^.location.register;
LOC_CREGISTER : begin
{ ...und eines für den Pointer reservieren }
hr:=getregister32;
emit_reg_reg(MOV,S_L,p^.left^.location.register,hr);
p^.location.referenz.base:=hr;
end;
else
begin
{ Register freigeben }
del_referenz(p^.left^.location.referenz);
{ ...und eines für den Pointer reservieren }
hr:=getregister32;
emit(
MOV,S_L,getreferenzstring(p^.left^.location.referenz)+','+
regid2str[hr]);
p^.location.referenz.base:=hr;
end;
end;
end;
procedure secondvecn(var p : ptree);far;
var
pushed : boolean;
ind : tregister;
_p : ptree;
procedure calc_emit_mul;
var
l1,l2 : longint;
begin
l1:=p^.resulttype^.size;
case l1 of
1,2,4,8 : p^.location.referenz.scalefactor:=l1;
else
begin
if ispowerof2(l1,l2) then
emit(A_SHL,S_L,'$'+tostr(l2)+','+regid2str[ind])
else
emit(IMUL,S_L,'$'+tostr(l1)+','+regid2str[ind]);
end;
end;
end;
var
extraoffset : longint;
t : ptree;
begin
secondpass(p^.left);
p^.location:=p^.left^.location;
{ Offset kann nur ungleich 0 sein, wenn arraydef }
if p^.left^.resulttype^.deftype=arraydef then
dec(p^.location.referenz.offset,
p^.resulttype^.size*
parraydef(p^.left^.resulttype)^.lowrange);
if p^.right^.treetype=ordconstn then
begin
{ Offset kann nur ungleich 0, wenn arraydef }
if p^.left^.resulttype^.deftype=arraydef then
begin
if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or
(p^.right^.value<parraydef(p^.left^.resulttype)^.lowrange) then
error(range_check_error);
dec(p^.left^.location.referenz.offset,
p^.resulttype^.size*parraydef(p^.left^.resulttype)^.lowrange);
end;
inc(p^.left^.location.referenz.offset,
p^.right^.value*p^.resulttype^.size);
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^.right^.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.referenz.offset,
p^.resulttype^.size*extraoffset);
end;
{ von links nach rechts rechnen }
if (p^.location.loc<>LOC_REFERENZ) and
(p^.location.loc<>LOC_MEM) then
error(error_in_expression);
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
case p^.right^.location.loc of
LOC_REGISTER : ind:=p^.right^.location.register;
LOC_CREGISTER : begin
ind:=getregister32;
emit_reg_reg(MOV,S_L,p^.right^.location.register,ind);
end;
else
begin
del_referenz(p^.right^.location.referenz);
ind:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.right^.location.referenz)+
','+regid2str[ind]);
end;
end;
{ moeglichen Rangecheckcode erzeugen: }
if cs_rangechecking in aktswitches then
begin
if p^.left^.resulttype^.deftype=arraydef then
begin
parraydef(p^.left^.resulttype)^.genrangecheck;
emit(A_BOUND,S_L,regid2str[ind]+
',R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr));
end;
end;
if p^.location.referenz.index=R_NO then
begin
p^.location.referenz.index:=ind;
calc_emit_mul;
end
else
begin
if p^.location.referenz.base=R_NO then
begin
calc_emit_mul;
p^.location.referenz.base:=p^.location.referenz.index;
p^.location.referenz.index:=ind;
end
else
begin
emit(
LEA,S_L,getreferenzstring(p^.location.referenz)+','+
regid2str[p^.location.referenz.index]);
ungetregister32(p^.location.referenz.base);
stringdispose(p^.location.referenz.symbol);
p^.location.referenz.offset:=0;
calc_emit_mul;
p^.location.referenz.base:=p^.location.referenz.index;
p^.location.referenz.index:=ind;
end;
end;
end;
end;
{ *************** Typekonvertierungen **************** }
{ erzeugt, falls noetig Rangecheckcode }
procedure maybe_rangechecking(p : ptree;p2,p1 : pdef);
var
hregister : tregister;
begin
if (cs_rangechecking in aktswitches) and
((pgrunddef(p1)^.von>pgrunddef(p2)^.von) or
(pgrunddef(p1)^.bis<pgrunddef(p2)^.bis)) then
begin
pgrunddef(p1)^.genrangecheck;
if pgrunddef(p1)^.typ=u8bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
emit(MOVZX,S_BL,regid2str[p^.location.register]+',%edi')
else
emit(MOVZX,S_BL,getreferenzstring(p^.location.referenz)+',%edi');
hregister:=R_EDI;
end
else if pgrunddef(p1)^.typ=s8bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
emit(MOVSX,S_BL,regid2str[p^.location.register]+',%edi')
else
emit(MOVSX,S_BL,getreferenzstring(p^.location.referenz)+',%edi');
hregister:=R_EDI;
end
else if pgrunddef(p1)^.typ=s32bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
hregister:=p^.location.register
else
begin
emit(MOV,S_L,getreferenzstring(p^.location.referenz)+',%edi');
hregister:=R_EDI;
end;
end
else if pgrunddef(p1)^.typ=u16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
emit(MOVZX,S_WL,regid2str[p^.location.register]+',%edi')
else
emit(MOVZX,S_WL,getreferenzstring(p^.location.referenz)+',%edi');
hregister:=R_EDI;
end
else if pgrunddef(p1)^.typ=s16bit then
begin
if (p^.location.loc=LOC_REGISTER) or
(p^.location.loc=LOC_CREGISTER) then
emit(MOVSX,S_WL,regid2str[p^.location.register]+',%edi')
else
emit(MOVSX,S_WL,getreferenzstring(p^.location.referenz)+',%edi');
hregister:=R_EDI;
end
else internalerror(6);
emit(A_BOUND,S_L,regid2str[hregister]+',R_'+tostr(pgrunddef(p1)^.rangenr))
end;
end;
type
tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype);
procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype);far;
begin
maybe_rangechecking(p,hp^.resulttype,p^.resulttype);
end;
procedure second_bigger(p,hp : ptree;convtyp : tconverttype);far;
var
hregister : tregister;
opsize : topsize;
op : tasmop;
is_register : boolean;
begin
is_register:=p^.left^.location.loc=LOC_REGISTER;
if not(is_register) and (p^.left^.location.loc<>LOC_CREGISTER) then
del_referenz(p^.left^.location.referenz);
case convtyp of
tc_u8bit_2_s32bit :
begin
if is_register then
hregister:=reg8toreg32(p^.left^.location.register)
else hregister:=getregister32;
op:=MOVZX;
opsize:=S_BL;
end;
tc_s8bit_2_s32bit :
begin
if is_register then
hregister:=reg8toreg32(p^.left^.location.register)
else hregister:=getregister32;
op:=MOVSX;
opsize:=S_BL;
end;
tc_u16bit_2_s32bit :
begin
if is_register then
hregister:=reg16toreg32(p^.left^.location.register)
else hregister:=getregister32;
op:=MOVZX;
opsize:=S_WL;
end;
tc_s16bit_2_s32bit :
begin
if is_register then
hregister:=reg16toreg32(p^.left^.location.register)
else hregister:=getregister32;
op:=MOVSX;
opsize:=S_WL;
end;
tc_s8bit_2_u16bit,
tc_u8bit_2_s16bit,
tc_u8bit_2_u16bit :
begin
if is_register then
hregister:=reg8toreg16(p^.left^.location.register)
else hregister:=reg32toreg16(getregister32);
op:=MOVZX;
opsize:=S_BW;
end;
tc_s8bit_2_s16bit :
begin
if is_register then
hregister:=reg8toreg16(p^.left^.location.register)
else hregister:=reg32toreg16(getregister32);
op:=MOVSX;
opsize:=S_BW;
end;
end;
if is_register then
begin
emit_reg_reg(op,opsize,p^.left^.location.register,hregister);
end
else
begin
if p^.left^.location.loc=LOC_CREGISTER then
emit_reg_reg(op,opsize,p^.left^.location.register,hregister)
else emit(op,opsize,
getreferenzstring(p^.left^.location.referenz)+','+regid2str[hregister]);
end;
maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=hregister;
end;
procedure second_string_string(p,hp : ptree;convtyp : tconverttype);far;
var
pushedregs : tpushed;
begin
clear_referenz(p^.location.referenz);
p^.location.referenz.base:=R_EBP;
p^.location.referenz.offset:=gettempofsize(p^.resulttype^.size);
del_referenz(p^.left^.location.referenz);
pushusedregisters(pushedregs,$ff);
emitpushreferenzaddr(p^.location.referenz);
emitpushreferenzaddr(p^.left^.location.referenz);
emit(PUSH,S_L,'$'+tostr(pstringdef(p^.resulttype)^.len));
emit(CALL,S_NO,'STRCOPY');
maybe_loadesi;
popusedregisters(pushedregs);
end;
procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype);far;
begin
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
inc(p^.left^.location.referenz.offset);
emit(LEA,S_L,getreferenzstring(p^.left^.location.referenz)+
','+regid2str[p^.location.register]);
end;
procedure second_cchar_charpointer(p,hp : ptree;convtyp : tconverttype);far;
begin
{!!!!}
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
inc(p^.left^.location.referenz.offset);
emit(LEA,S_L,getreferenzstring(p^.left^.location.referenz)+
','+regid2str[p^.location.register]);
end;
procedure second_cstring_chararray(p,hp : ptree;convtyp : tconverttype);far;
begin
p^.location.referenz:=p^.left^.location.referenz;
inc(p^.location.referenz.offset);
end;
procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype);far;
begin
del_referenz(p^.left^.location.referenz);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
emit(LEA,S_L,getreferenzstring(p^.left^.location.referenz)+','+
regid2str[p^.location.register]);
end;
procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype);far;
begin
p^.location.loc:=LOC_REFERENZ;
clear_referenz(p^.location.referenz);
if p^.left^.location.loc=LOC_REGISTER then
p^.location.referenz.base:=p^.left^.location.register
else
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
p^.location.referenz.base:=getregister32;
emit_reg_reg(MOV,S_L,p^.left^.location.register,
p^.location.referenz.base);
end
else
begin
del_referenz(p^.left^.location.referenz);
p^.location.referenz.base:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)+','+
regid2str[p^.location.referenz.base]);
end;
end;
end;
procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype);far;
begin
clear_referenz(p^.location.referenz);
p^.location.referenz.offset:=gettempofsize(256);
p^.location.referenz.base:=R_EBP;
if p^.left^.treetype=ordconstn { eigentlich charconst } then
emit(MOV,S_W,'$'+tostr(p^.left^.value*256+1)+','+getreferenzstring(p^.location.referenz))
else
begin
{ nicht so elegant (ging besser mit extra Register }
if (p^.left^.location.loc=LOC_REGISTER) or
(p^.left^.location.loc=LOC_CREGISTER) then
begin
emit(MOVZX,S_BW,regid2str[p^.left^.location.register]+',%di');
ungetregister32(reg8toreg32(p^.left^.location.register));
end
else
begin
emit(MOVZX,S_BW,getreferenzstring(p^.left^.location.referenz)+',%di');
del_referenz(p^.left^.location.referenz);
end;
emit(A_SHL,S_W,'$8,%di');
emit(A_OR,S_W,'$1,%di');
emit(MOV,S_W,'%di,'+getreferenzstring(p^.location.referenz));
end;
end;
procedure second_int_real(p,hp : ptree;convtyp : tconverttype);far;
var
hs : string;
begin
if (p^.left^.location.loc=LOC_REGISTER) or
(p^.left^.location.loc=LOC_CREGISTER) then
begin
hs:=regid2str[p^.left^.location.register];
ungetregister(p^.left^.location.register);
end
else
begin
hs:=getreferenzstring(p^.left^.location.referenz);
del_referenz(p^.left^.location.referenz);
end;
hs:=hs+',%edi';
case pgrunddef(p^.left^.resulttype)^.typ of
s8bit : emit(MOVSX,S_BL,hs);
u8bit : emit(MOVZX,S_BL,hs);
s16bit : emit(MOVSX,S_WL,hs);
u16bit : emit(MOVZX,S_WL,hs);
s32bit : emit(MOV,S_L,hs);
end;
emit(PUSH,S_L,'%edi');
emit(FILD,S_L,'(%esp)');
emit(ADD,S_L,'$4,%esp');
p^.location.loc:=LOC_FPUSTACK;
end;
procedure second_smaller(p,hp : ptree;convtyp : tconverttype);far;
var
destregister : tregister;
opsize : topsize;
ref : boolean;
begin
{ !!!!!!!! Rangechecking }
ref:=false;
if (p^.left^.location.loc=LOC_REGISTER) or
(p^.left^.location.loc=LOC_CREGISTER) then
begin
destregister:=p^.location.register;
case convtyp of
tc_s32bit_2_s8bit,
tc_s32bit_2_u8bit : destregister:=reg32toreg8(destregister);
tc_s32bit_2_s16bit,
tc_s32bit_2_u16bit : destregister:=reg32toreg16(destregister);
tc_s16bit_2_s8bit,
tc_s16bit_2_u8bit,
tc_u16bit_2_s8bit,
tc_u16bit_2_u8bit : destregister:=reg16toreg8(destregister);
end;
p^.location.register:=destregister;
end;
end;
procedure secondtypeconv(var p : ptree);far;
const
secondconvert : array[tc_u8bit_2_s32bit..tc_int_2_real] of
tsecondconvproc = (second_bigger,second_only_rangecheck,
second_bigger,second_bigger,second_bigger,
second_smaller,second_smaller,
second_smaller,second_string_string,
second_cstring_charpointer,second_cstring_chararray,
second_array_to_pointer,second_pointer_to_array,
second_char_to_string,second_bigger,
second_bigger,second_bigger,
second_smaller,second_smaller,
second_smaller,second_smaller,
second_bigger,second_smaller,
second_int_real); {,second_cchar_charpointer); }
begin
secondpass(p^.left);
p^.location:=p^.left^.location;
if p^.convtyp<>tc_equal then
secondconvert[p^.convtyp](p,p,p^.convtyp)
end;
{ speichert die Größe der gepushten Parameter }
var
pushedparasize : longint;
procedure secondcallparan(var p : ptree;defcoll : pdefcoll);
var
regstr : string[3];
size : longint;
stackref : treferenz;
otlabel,hlabel,oflabel : longint;
{ Temporäre Variablen: }
tempdeftype : tdeftype;
tempreferenz : treferenz;
begin
otlabel:=truelabel;
oflabel:=falselabel;
truelabel:=getlabel;
falselabel:=getlabel;
secondpass(p^.left);
{ in codegen.handleread.. wird defcoll^.data auf nil }
{ gesetzt }
if assigned(defcoll^.data) and
(defcoll^.data^.deftype=formaldef) then
begin
if (p^.left^.location.loc<>LOC_REFERENZ) and
(p^.left^.location.loc<>LOC_MEM) then
error(type_mismatch);
emitpushreferenzaddr(p^.left^.location.referenz);
del_referenz(p^.left^.location.referenz);
inc(pushedparasize,4);
end
else if (defcoll^.paratyp=vs_var) then
begin
if (p^.left^.location.loc<>LOC_REFERENZ) then
error(var_must_be_referenz);
del_referenz(p^.left^.location.referenz);
emitpushreferenzaddr(p^.left^.location.referenz);
inc(pushedparasize,4);
end
else
begin
tempdeftype:=p^.resulttype^.deftype;
if tempdeftype=filedef then
error(file_must_call_by_referenz);
if (defcoll^.paratyp=vs_const) and
(
(tempdeftype=stringdef) or
(tempdeftype=arraydef) or
(tempdeftype=recorddef) or
(tempdeftype=classdef) or
(tempdeftype=setdef)
) then
begin
emitpushreferenzaddr(p^.left^.location.referenz);
del_referenz(p^.left^.location.referenz);
inc(pushedparasize,4);
end
else
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
case p^.left^.location.register of
R_EAX,R_EBX,R_ECX,R_EDX,R_ESI,
R_EDI,R_ESP,R_EBP :
begin
emit(PUSH,S_L,regid2str[p^.left^.location.register]);
inc(pushedparasize,4);
ungetregister32(p^.left^.location.register);
end;
R_AX,R_BX,R_CX,R_DX,R_SI,R_DI : begin
emit(PUSH,S_W,regid2str[p^.left^.location.register]);
inc(pushedparasize,2);
ungetregister32(reg16toreg32(p^.left^.location.register));
end;
R_AL,R_BL,R_CL,R_DL:
begin
{ hier etwas Schnipseln um die 8-Bit }
{ Register auf den Stack zu bringen: }
regstr:=regid2str[p^.left^.location.register];
emit(PUSH,S_W,'%'+regstr[2]+'x');
inc(pushedparasize,2);
ungetregister32(reg8toreg32(p^.left^.location.register));
end;
end;
end;
LOC_FPUSTACK : begin
inc(pushedparasize,8);
emit(SUB,S_L,'$8,%esp');
emit(FSTP,S_L,'(%esp)');
end;
LOC_REFERENZ,LOC_MEM :
begin
del_referenz(p^.left^.location.referenz);
tempreferenz:=p^.left^.location.referenz;
case p^.resulttype^.deftype of
grunddef : begin
case pgrunddef(p^.resulttype)^.typ of
s32bit :
begin
emit(PUSH,S_L,getreferenzstring(tempreferenz));
inc(pushedparasize,4);
end;
s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : begin
emit(PUSH,S_W,getreferenzstring(tempreferenz));
inc(pushedparasize,2);
end;
s64real : begin
inc(tempreferenz.offset,4);
emit(PUSH,S_L,getreferenzstring(tempreferenz));
dec(tempreferenz.offset,4);
emit(PUSH,S_L,getreferenzstring(tempreferenz));
inc(pushedparasize,8);
end;
end;
end;
pointerdef,procvardef,aufzaehldef : begin
emit(PUSH,S_L,getreferenzstring(tempreferenz));
inc(pushedparasize,4);
end;
arraydef,recorddef,stringdef,setdef,classdef :
begin
size:=p^.resulttype^.size;
{ Alignment }
{
if (size>=4) and ((size and 3)<>0) then
inc(size,4-(size and 3))
else if (size>=2) and ((size and 1)<>0) then
inc(size,2-(size and 1))
else
if size=1 then size:=2;
}
{ Stackraum schaffen }
emit(SUB,S_L,'$'+tostr(size)+',%esp');
inc(pushedparasize,size);
{ Stackreferenz erstellen }
clear_referenz(stackref);
stackref.base:=R_ESP;
{ Kopie erzeugen }
if p^.resulttype^.deftype=stringdef then
begin
copystring(stackref,p^.left^.location.referenz,
pstringdef(p^.resulttype)^.len);
end
else
begin
concatcopy(p^.left^.location.referenz,
stackref,p^.resulttype^.size,true);
end;
end;
else error(error_in_expression);
end;
end;
LOC_JUMP : begin
hlabel:=getlabel;
inc(pushedparasize,2);
emitl(A_LABEL,truelabel);
emit(PUSH,S_W,'$1');
emitl(JMP,hlabel);
emitl(A_LABEL,falselabel);
emit(PUSH,S_W,'$0');
emitl(A_LABEL,hlabel);
end;
LOC_FLAGS : begin
if not(R_EAX in unused) then
emit(MOV,S_L,'%eax,%edi');
emit(A_XOR,S_W,'%ax,%ax');
emit(flag_2_set[p^.left^.location.resflags],S_NO,
'%al');
inc(pushedparasize,2);
emit(PUSH,S_W,'%ax');
if not(R_EAX in unused) then
emit(MOV,S_L,'%edi,%eax');
end;
end;
end;
truelabel:=otlabel;
falselabel:=oflabel;
{ von rechts nach links pushen }
if assigned(p^.right) then
secondcallparan(p^.right,defcoll^.next);
end;
procedure pushexceptlabel;
begin
if not(procinfo.exceptions) then
error(proc_must_handleexceptions);
emit(PUSH,S_L,'$'+tolabel(aktexceptlabel));
end;
procedure secondcalln(var p : ptree);far;
var
unusedregisters : tregisterset;
asmrec : pasmrec;
pushed : tpushed;
funcretref : treferenz;
hregister : tregister;
oldpushedparasize : longint;
{ true, wenn ESI nach dem Unterprogramm neu geladen werden muß }
loadesi : boolean;
{ true, wenn eine virtueller Methode direkt aufgerufen werden soll }
no_virtual_call : boolean;
{ true, wenn wir in einen Call für einen Kon- oder Destruktor erzeugen }
is_con_or_destructor : boolean;
{ true, wenn ein Konstruktor von new aufgerufen wird }
extended_new : boolean;
{ Adresse, die bei einem I/O-Error angegeben wird }
iolabel : longint;
begin
extended_new:=false;
loadesi:=true;
no_virtual_call:=false;
unusedregisters:=unused;
{ only if no proc var }
if not(assigned(p^.right)) then
is_con_or_destructor:=((p^.procdefinition^.options and poconstructor)<>0)
or ((p^.procdefinition^.options and podestructor)<>0);
{ proc variables destroy all registers }
if (p^.right=nil) and
{ virtual methods too }
((p^.procdefinition^.options and povirtualmethod)=0) then
begin
if ((p^.procdefinition^.options and poiocheck)<>0)
and (cs_iocheck in aktswitches) then
begin
iolabel:=getlabel;
emitl(A_LABEL,iolabel);
end
else iolabel:=0;
{ alle benutzen Register pushen: }
pushusedregisters(pushed,p^.procdefinition^.usedregisters);
{ benutzte Register durchreichen: }
usedinproc:=usedinproc or p^.procdefinition^.usedregisters;
end
else
begin
pushusedregisters(pushed,$ff);
usedinproc:=$ff;
{ natürlich keine I/O-Überprüfung }
iolabel:=0;
end;
{ Parameter berechnen und pushen }
oldpushedparasize:=pushedparasize;
if assigned(p^.left) then
begin
pushedparasize:=0;
{ bei Prozedurvariablen sind die Definitionen woanders }
{ zu finden }
if assigned(p^.right) then
secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1)
else
secondcallparan(p^.left,p^.procdefinition^.para1);
end;
if (p^.resulttype<>pdef(voiddef)) and
((p^.resulttype^.deftype=arraydef) or
(p^.resulttype^.deftype=stringdef) or
(p^.resulttype^.deftype=classdef) or
(p^.resulttype^.deftype=recorddef) or
(p^.resulttype^.deftype=setdef)) then
begin
clear_referenz(funcretref);
funcretref.base:=R_EBP;
funcretref.offset:=gettempofsize(p^.procdefinition^.retdef^.size);
emitpushreferenzaddr(funcretref);
inc(pushedparasize,4);
end;
if (p^.right=nil) then
begin
{ self pushen }
if (p^.symtable^.symtabletype and $3fff)=objectsymtable then
begin
if assigned(p^.methodpointer) then
begin
{ direkter Aufruf einer vererbten Methode }
case p^.methodpointer^.treetype of
typen : begin
{ keinen virtuellen Aufruf erzeugen }
no_virtual_call:=true;
{ Memberaufruf, also ESI nicht verändern }
loadesi:=false;
emit(PUSH,S_L,'%esi');
{ sollte ein vererbter Con- oder Destructor nicht }
{ in einem Con- oder Destructor aufgerufen werden, }
{ so wird eine Warnung ausgegeben }
if is_con_or_destructor and
not(
(((aktprocsym^.definition^.options and poconstructor)<>0) and
((p^.procdefinition^.options and poconstructor)<>0)) or
(((aktprocsym^.definition^.options and podestructor)<>0) and
((p^.procdefinition^.options and podestructor)<>0))) then
warning(member_cd_call_from_method);
{ bei Kon- oder Destructoraufrufen wird noch ein Zeiger }
{ auf eine VMT erwartet... }
if is_con_or_destructor then
begin
{ ...der allerdings in diesem Kontext einen Sch... interessiert}
emit(PUSH,S_L,'$0');
end;
end;
hnewn : begin
{ Constructor mit erweitertem Syntax von New aufrufen }
{ ESI muß schon gelöscht sein }
emit(A_XOR,S_L,'%esi,%esi');
emit(PUSH,S_L,'%esi');
emit(PUSH,S_L,'$VMT_'+pclassdef(p^.methodpointer^.resulttype)^.name^);
extended_new:=true;
end;
hdisposen : begin
secondpass(p^.methodpointer);
{ Destruktor mit erweitertem Syntax von Dispose aufrufen }
{ hdisposen liefert immer LOC_REFERENZ }
emit(LEA,S_L,getreferenzstring(p^.methodpointer^.location.referenz)+',%esi');
del_referenz(p^.methodpointer^.location.referenz);
emit(PUSH,S_L,'%esi');
emit(PUSH,S_L,'$VMT_'+pclassdef(p^.methodpointer^.resulttype)^.name^)
end;
else
begin
{ irgendein Methodenaufruf }
secondpass(p^.methodpointer);
{ %esi gleich laden (wegen virtuellen Methoden) }
case p^.methodpointer^.location.loc of
LOC_REGISTER : begin
ungetregister32(p^.methodpointer^.location.register);
emit_reg_reg(MOV,S_L,p^.methodpointer^.location.register,R_ESI);
end;
else begin
emit(LEA,S_L,getreferenzstring(p^.methodpointer^.location.referenz)+',%esi');
del_referenz(p^.methodpointer^.location.referenz);
end;
end;
emit(PUSH,S_L,'%esi');
if is_con_or_destructor then
begin
if ((p^.procdefinition^.options and poconstructor)<>0) then
{ hier muß die VMT natürlich eingetragen werden }
emit(PUSH,S_L,'$VMT_'+pclassdef(p^.methodpointer^.resulttype)^.name^)
{ beim Destruktor Objekt nicht! löschen }
else emit(PUSH,S_L,'$0');
end;
end;
end;
end
else
begin
{ Memberaufruf, also ESI nicht verändern }
loadesi:=false;
emit(PUSH,S_L,'%esi');
{ aber ein Kon- oder Destruktor wäre hier wohl fast immer }
{ fehl am Platze }
if is_con_or_destructor then
begin
warning(member_cd_call_from_method);
{ VMT-Zeiger nicht eintragen }
emit(PUSH,S_L,'$0');
end;
end;
end;
{ Basepointer ?}
if (lexlevel>0) and assigned(pprocdef(p^.procdefinition)^.parast) and
((p^.procdefinition^.parast^.symtabletype and $3fff)>1) then
begin
if (lexlevel=(p^.procdefinition^.parast^.symtabletype and $3fff)) then
emit(PUSH,S_L,tostr(procinfo.framepointer)+'(%ebp)')
else if lexlevel<(p^.procdefinition^.parast^.symtabletype and $3fff) then
emit(PUSH,S_L,'%ebp');
end;
{ Exceptionadresse pushen }
if ((p^.procdefinition^.options and poexceptions)<>0) then
begin
pushexceptlabel;
inc(pushedparasize,4);
end;
if (p^.procdefinition^.options and poexports)<>0 then
error(dont_call_exported_direct);
if ((p^.procdefinition^.options and povirtualmethod)<>0) and
not(no_virtual_call) then
begin
emit(MOV,S_L,'(%esi),%edi');
emit(CALL,S_NO,tostr(p^.procdefinition^.extnumber*4+12)+'(%edi)');
end
else
emit(CALL,S_NO,p^.procdefinition^.mangledname);
if ((p^.procdefinition^.options and poclearstack)<>0) then
emit(ADD,S_L,'$'+tostr(pushedparasize)+',%esp');
end
else
begin
{ Exceptionadresse pushen (Prozedurvariable) }
if ((pprocvardef(p^.right^.resulttype)^.options and poexceptions)<>0) then
begin
pushexceptlabel;
inc(pushedparasize,4);
end;
secondpass(p^.right);
case p^.right^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
emit(CALL,S_NO,regid2str[p^.right^.location.register]);
ungetregister32(p^.right^.location.register);
end
else
begin
emit(CALL,S_NO,'*'+getreferenzstring(p^.right^.location.referenz));
del_referenz(p^.right^.location.referenz);
end;
end;
end;
pushedparasize:=oldpushedparasize;
unused:=unusedregisters;
{ Register restaurieren }
if p^.resulttype<>pdef(voiddef) then
begin
if (p^.right=nil) and
((p^.procdefinition^.options and poconstructor)<>0) then
begin
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=F_NE;
if extended_new then
begin
{ sollte EAX belegt sein, dann umkopieren }
hregister:=getregister32;
emit_reg_reg(MOV,S_L,R_EAX,hregister);
p^.location.register:=hregister;
end;
end
else if ((p^.resulttype^.deftype=arraydef) or
(p^.resulttype^.deftype=stringdef) or
(p^.resulttype^.deftype=classdef) or
(p^.resulttype^.deftype=recorddef) or
(p^.resulttype^.deftype=setdef)) then
begin
p^.location.loc:=LOC_MEM;
p^.location.referenz:=funcretref;
end
else
begin
p^.location.loc:=LOC_REGISTER;
hregister:=getregister32;
if (p^.resulttype^.deftype=grunddef) then
begin
case pgrunddef(p^.resulttype)^.typ of
s32bit : begin
emit_reg_reg(MOV,S_L,R_EAX,hregister);
p^.location.register:=hregister;
end;
uchar,u8bit,bool8bit,s8bit : begin
emit_reg_reg(MOV,S_B,R_AL,reg32toreg8(hregister));
p^.location.register:=reg32toreg8(hregister);
end;
s16bit,u16bit : begin
emit_reg_reg(MOV,S_W,R_AX,reg32toreg16(hregister));
p^.location.register:=reg32toreg16(hregister);
end;
s64real : p^.location.loc:=LOC_FPUSTACK;
else internalerror(7);
end
end
else
begin
emit_reg_reg(MOV,S_L,R_EAX,hregister);
p^.location.register:=hregister;
end;
end;
end;
{ vielleicht I/O-Check ? }
if iolabel<>0 then
begin
emit(PUSH,S_L,tolabel(iolabel));
emit(CALL,S_NO,'IOCHECK');
end;
popusedregisters(pushed);
if loadesi then
maybe_loadesi;
end;
procedure secondfuncret(var p : ptree);far;
var
hregister : tregister;
begin
clear_referenz(p^.location.referenz);
p^.location.referenz.base:=R_EBP;
p^.location.referenz.offset:=procinfo.retoffset;
if (procinfo.retdef^.deftype=arraydef) or
(procinfo.retdef^.deftype=stringdef) or
(procinfo.retdef^.deftype=classdef) or
(procinfo.retdef^.deftype=recorddef) or
(procinfo.retdef^.deftype=setdef) then
begin
hregister:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.location.referenz)+','+regid2str[hregister]);
p^.location.referenz.base:=hregister;
p^.location.referenz.offset:=0;
end;
end;
{ dreht die Parameterliste um }
function reversparameter(p : ptree) : ptree;
var
hp1,hp2 : ptree;
begin
hp1:=nil;
while assigned(p) do
begin
{ Aushaengen }
hp2:=p;
p:=p^.right;
{ Neu Einhaengen }
hp2^.right:=hp1;
hp1:=hp2;
end;
reversparameter:=hp1;
end;
procedure secondinline(var p : ptree);far;
var
aktfile : treferenz;
ft : tfiletyp;
pushed : tpushed;
{ Behandelt die Codeerzeugung für READ(LN) und WRITE(LN) }
procedure handlereadwrite(doread,callwriteln : boolean);
procedure loadstream;
begin
if doread then
emit(LEA,S_L,'U_'+target_info.system_unit+'_INPUT,%edi')
else emit(LEA,S_L,'U_'+target_info.system_unit+'_OUTPUT,%edi');
end;
var
node,hp : ptree;
typedtyp,pararesult : pdef;
doflush : boolean;
dummycoll : tdefcoll;
iolabel : longint;
begin
{ I/O-Prüfung ? }
if cs_iocheck in aktswitches then
begin
iolabel:=getlabel;
emitl(A_LABEL,iolabel);
end
else iolabel:=0;
{ kein automatischer Aufruf von Flush }
doflush:=false;
{ temporären Zeiger auf Dateivariable reservieren }
gettempofsizereferenz(4,aktfile);
{ erst einmal Textdatei angeben }
ft:=ft_text;
{ auch ein Parameter angegeben ? }
if p^.left=nil then
begin
{ Bildschirmausgabe, also gleich ausgeben }
doflush:=true;
{ die folgenden Anweisungen sind für "writeln;" }
loadstream;
{ @Dateivariable in temp. Var. abspeichern }
emit(MOV,S_L,'%edi,'+getreferenzstring(aktfile));
end
else
begin
{ Parameter umdrehen ! }
node:=reversparameter(p^.left);
{ Dateivariable berechnen }
{ erster Parameter ein Filetyp ? }
if node^.left^.resulttype^.deftype=filedef then
begin
ft:=pfiledef(node^.left^.resulttype)^.filetyp;
if ft=ft_typed then
typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as;
secondpass(node^.left);
if codegenerror then
exit;
{ Referenz in temporäre Variable retten }
if node^.left^.location.loc<>LOC_REFERENZ then
begin
error(error_in_expression);
exit;
end;
emit(LEA,S_L,getreferenzstring(node^.left^.location.referenz)+',%edi');
{ erster Parameter ist behandelt, also löschen }
node:=node^.right;
end
else
begin
{ Bildschirmausgabe, also gleich ausgeben }
doflush:=true;
loadstream;
end;
{ @Dateivariable in temp. Var. abspeichern }
emit(MOV,S_L,'%edi,'+getreferenzstring(aktfile));
if doread then
{ Paramter an READ werden Call by Referenz übergeben }
dummycoll.paratyp:=vs_var
{ an WRITE Call by "Const" }
else dummycoll.paratyp:=vs_const;
{ wegen secondcallparan, welches sonst daraufzugreift }
dummycoll.data:=nil;
while node<>nil do
begin
pushusedregisters(pushed,$ff);
hp:=node;
node:=node^.right;
hp^.right:=nil;
if hp^.is_colon_para then
error(ill_colon_qualifier);
secondcallparan(hp,@dummycoll);
if codegenerror then
exit;
emit(PUSH,S_L,getreferenzstring(aktfile));
if (ft=ft_typed) then
begin
{!!!!!!!}
end
else
begin
pararesult:=hp^.left^.resulttype;
{ mögliche Feldbreitenangabe bearbeiten }
{ natürlich nur bei write(ln) }
if not doread then
begin
if assigned(node) and node^.is_colon_para then
begin
hp:=node;
node:=node^.right;
hp^.right:=nil;
secondcallparan(hp,@dummycoll);
if codegenerror then
exit;
end
else
emit(PUSH,S_L,'$0');
end;
{ keine Exceptions mehr in der RTL pushexceptlabel; }
case hp^.left^.resulttype^.deftype of
stringdef : begin
if doread then
emit(CALL,S_NO,'READ_TEXT_STRING')
else emit(CALL,S_NO,'WRITE_TEXT_STRING');
end;
pointerdef : begin
if (ppointerdef(pararesult)^.definition^.deftype=grunddef)
and (pgrunddef(ppointerdef(pararesult)^.definition)^.typ=uchar) then
begin
if doread then
emit(CALL,S_NO,'READ_TEXT_PCHAR_AS_POINTER')
else emit(CALL,S_NO,'WRITE_TEXT_PCHAR_AS_POINTER');
end
else error(no_para_match);
end;
arraydef : begin
if (parraydef(pararesult)^.lowrange=0)
and (parraydef(pararesult)^.definition^.deftype=grunddef)
and (pgrunddef(parraydef(pararesult)^.definition)^.typ=uchar) then
begin
if doread then
emit(CALL,S_NO,'READ_TEXT_PCHAR_AS_ARRAY')
else emit(CALL,S_NO,'WRITE_TEXT_PCHAR_AS_ARRAY');
end
else error(no_para_match);
end;
grunddef : begin
case pgrunddef(pararesult)^.typ of
s32bit : if doread then
emit(CALL,S_NO,'READ_TEXT_LONGINT')
else emit(CALL,S_NO,'WRITE_TEXT_LONGINT');
uchar : if doread then
emit(CALL,S_NO,'READ_TEXT_CHAR')
else emit(CALL,S_NO,'WRITE_TEXT_CHAR');
s64real : if doread then
emit(CALL,S_NO,'READ_TEXT_REAL')
else
begin
{ Fixkommaangabe auf den Stack kopieren }
if assigned(node) and node^.is_colon_para then
begin
hp:=node;
node:=node^.right;
hp^.right:=nil;
secondcallparan(hp,@dummycoll);
if codegenerror then
exit;
end
else
emit(PUSH,S_L,'$-1');
emit(CALL,S_NO,'WRITE_TEXT_REAL');
end;
else error(no_para_match);
end;
end;
else error(no_para_match);
end;
end;
{ in Methoden ESI neu laden }
popusedregisters(pushed);
maybe_loadesi;
end;
end;
if callwriteln then
begin
pushusedregisters(pushed,$ff);
emit(PUSH,S_L,getreferenzstring(aktfile));
{ pushexceptlabel; }
if ft<>ft_text then
error(no_para_match);
emit(CALL,S_NO,'WRITELN_TEXT');
popusedregisters(pushed);
maybe_loadesi;
end;
if doflush and not(doread) then
begin
pushusedregisters(pushed,$ff);
{ pushexceptlabel; }
emit(CALL,S_NO,'FLUSH_STDOUT');
popusedregisters(pushed);
maybe_loadesi;
end;
if iolabel<>0 then
begin
{ registers are saved in the procedure }
emit(PUSH,S_L,tolabel(iolabel));
emit(CALL,S_NO,'IOCHECK');
end;
end;
procedure handle_str;
var
hp,node : ptree;
dummycoll : tdefcoll;
is_real : boolean;
begin
pushusedregisters(pushed,$ff);
node:=p^.left;
while assigned(node) do
begin
hp:=node;
node:=node^.right;
hp^.right:=nil;
if hp^.left^.resulttype^.deftype=stringdef then
dummycoll.paratyp:=vs_var
else
dummycoll.paratyp:=vs_const;
{ wenn irgendwo ein Realparameter vorkommt, dann }
{ REALSTR aufrufen }
if (hp^.left^.resulttype^.deftype=grunddef)
and (pgrunddef(hp^.left^.resulttype)^.typ=s64real) then
is_real:=true;
secondcallparan(hp,@dummycoll);
if codegenerror then
exit;
end;
popusedregisters(pushed);
end;
begin
case p^.inlinenumber of
in_lo_word,
in_hi_word : begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
p^.location.register:=reg32toreg16(getregister32);
emit_reg_reg(MOV,S_W,p^.left^.location.register,
p^.location.register);
end
else
begin
del_referenz(p^.left^.location.referenz);
p^.location.register:=reg32toreg16(getregister32);
emit(MOV,S_W,getreferenzstring(p^.left^.location.referenz)
+','+regid2str[p^.location.register]);
end;
end
else p^.location.register:=p^.left^.location.register;
if p^.inlinenumber=in_hi_word then
emit(A_SHR,S_W,'$8,'+regid2str[p^.location.register]);
p^.location.register:=reg16toreg8(p^.location.register);
end;
in_sizeof_x,
in_typeof_x : begin
secondpass(p^.left);
del_referenz(p^.left^.location.referenz);
p^.location.loc:=LOC_REGISTER;
p^.location.register:=getregister32;
{ VMT-Zeiger laden }
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)+
+','+regid2str[p^.location.register]);
if p^.inlinenumber=in_sizeof_x then
begin
emit(MOV,S_L,'('+regid2str[p^.location.register]+'),'+
regid2str[p^.location.register]);
end;
end;
in_lo_long,
in_hi_long : begin
secondpass(p^.left);
p^.location.loc:=LOC_REGISTER;
if p^.left^.location.loc<>LOC_REGISTER then
begin
if p^.left^.location.loc=LOC_CREGISTER then
begin
p^.location.register:=getregister32;
emit_reg_reg(MOV,S_L,p^.left^.location.register,
p^.location.register);
end
else
begin
del_referenz(p^.left^.location.referenz);
p^.location.register:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)
+','+regid2str[p^.location.register]);
end;
end
else p^.location.register:=p^.left^.location.register;
if p^.inlinenumber=in_hi_long then
emit(A_SHR,S_L,'$16,'+regid2str[p^.location.register]);
p^.location.register:=reg32toreg16(p^.location.register);
end;
in_ord_char,
in_chr_byte,
in_length_string : begin
secondpass(p^.left);
p^.location:=p^.left^.location;
end;
in_inc_dword : begin
secondpass(p^.left);
emit(A_INC,S_L,getreferenzstring(p^.left^.location.referenz));
emitoverflowcheck;
end;
in_inc_word : begin
secondpass(p^.left);
emit(A_INC,S_W,getreferenzstring(p^.left^.location.referenz));
emitoverflowcheck;
end;
in_inc_byte : begin
secondpass(p^.left);
emit(A_INC,S_B,getreferenzstring(p^.left^.location.referenz));
emitoverflowcheck;
end;
in_dec_dword : begin
secondpass(p^.left);
emit(A_DEC,S_L,getreferenzstring(p^.left^.location.referenz));
emitoverflowcheck;
end;
in_dec_word : begin
secondpass(p^.left);
emit(A_DEC,S_W,getreferenzstring(p^.left^.location.referenz));
emitoverflowcheck;
end;
in_dec_byte : begin
secondpass(p^.left);
emit(A_DEC,S_B,getreferenzstring(p^.left^.location.referenz));
emitoverflowcheck;
end;
in_assigned_x : begin
secondpass(p^.left^.left);
p^.location.loc:=LOC_FLAGS;
if (p^.left^.left^.location.loc=LOC_REGISTER) or
(p^.left^.left^.location.loc=LOC_CREGISTER) then
begin
emit(A_OR,S_L,regid2str[p^.left^.left^.location.register]+','+
regid2str[p^.left^.left^.location.register]);
ungetregister32(p^.left^.left^.location.register);
end
else
begin
emit(CMP,S_L,'$0,'+getreferenzstring(p^.left^.left^.location.referenz));
del_referenz(p^.left^.left^.location.referenz);
end;
p^.location.resflags:=F_NE;
end;
in_write_x : handlereadwrite(false,false);
in_writeln_x : handlereadwrite(false,true);
in_read_x : handlereadwrite(true,false);
in_readln_x : begin
handlereadwrite(true,false);
pushusedregisters(pushed,$ff);
emit(PUSH,S_L,getreferenzstring(aktfile));
{ pushexceptlabel; }
if ft<>ft_text then
error(no_para_match);
emit(CALL,S_NO,'READLN_TEXT');
popusedregisters(pushed);
maybe_loadesi;
end;
in_str_x_string : begin
handle_str;
maybe_loadesi;
end;
else internalerror(9);
end;
end;
procedure secondsubscriptn(var p : ptree);far;
begin
secondpass(p^.left);
if codegenerror then
exit;
p^.location:=p^.left^.location;
inc(p^.location.referenz.offset,p^.vs^.adresse);
end;
procedure secondselfn(var p : ptree);far;
begin
clear_referenz(p^.location.referenz);
p^.location.referenz.base:=R_ESI;
end;
procedure secondhdisposen(var p : ptree);far;
begin
secondpass(p^.left);
if codegenerror then
exit;
clear_referenz(p^.location.referenz);
case p^.left^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
p^.location.referenz.index:=getregister32;
emit(MOV,S_L,
regid2str[p^.left^.location.register]+','+
regid2str[p^.location.referenz.index]);
end;
LOC_MEM,LOC_REFERENZ :
begin
del_referenz(p^.left^.location.referenz);
p^.location.referenz.index:=getregister32;
emit(MOV,S_L,getreferenzstring(p^.left^.location.referenz)+','+
regid2str[p^.location.referenz.index]);
end;
end;
end;
procedure secondhnewn(var p : ptree);far;
begin
end;
procedure secondnewn(var p : ptree);far;
begin
secondpass(p^.left);
if codegenerror then
exit;
p^.location.register:=p^.left^.location.register;
end;
procedure secondsimplenewdispose(var p : ptree);far;
begin
secondpass(p^.left);
if codegenerror then
exit;
{ determines the size of the mem block }
emit(PUSH,S_L,
'$'+tostr(ppointerdef(p^.left^.resulttype)^.definition^.size));
{ push pointer adress }
case p^.left^.location.loc of
LOC_CREGISTER : emit(PUSH,S_L,
regid2str[p^.left^.location.register]);
LOC_REFERENZ : emitpushreferenzaddr(p^.left^.location.referenz);
end;
{ call the mem handling procedures }
case p^.treetype of
simpledisposen : emit(CALL,S_NO,'FREEMEM');
simplenewn : emit(CALL,S_NO,'GETMEM');
end;
{ may be load ESI }
maybe_loadesi;
end;
{ kopiert p als Setelement auf den Stack }
procedure pushsetelement(var p : ptree);
var
hr : tregister;
begin
{ das Element auf den Stack kopieren, etwas kompliziert }
case p^.location.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
hr:=p^.location.register;
case hr of
R_EAX,R_EBX,R_ECX,R_EDX,R_EDI,R_ESI,R_ESP :
begin
ungetregister32(hr);
emit(PUSH,S_W,regid2str[reg32toreg16(hr)]);
end;
R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP :
begin
ungetregister32(reg16toreg32(hr));
emit(PUSH,S_W,regid2str[hr]);
end;
R_AL,R_BL,R_CL,R_DL :
begin
ungetregister32(reg8toreg32(hr));
emit(PUSH,S_W,regid2str[reg8toreg16(hr)]);
end;
end;
end;
else
begin
emit(PUSH,S_W,getreferenzstring(p^.location.referenz));
del_referenz(p^.location.referenz);
end;
end;
end;
procedure secondsetcons(var p : ptree);far;
var
l,i : longint;
hp : ptree;
href,sref : treferenz;
begin
{ konstanten Teil erzeugen }
clear_referenz(href);
l:=getconstlabel;
href.symbol:=stringdup('L'+tostr(l));
constsegment.concat(gennasmrec(DIRECT,S_NO,'L'+tostr(l)+':'));
for i:=0 to 31 do
constsegment.concat(gennasmrec(A_BYTE,S_NO,tostr(p^.constset^[i])));
hp:=p^.left;
if assigned(hp) then
begin
gettempofsizereferenz(32,sref);
concatcopy(href,sref,32,false);
while assigned(hp) do
begin
secondpass(hp^.left);
if codegenerror then
exit;
pushsetelement(hp^.left);
emitpushreferenzaddr(sref);
{ Register werden im Unterprogramm gerettet }
emit(CALL,S_NO,'SET_SET_BYTE');
hp:=hp^.right;
end;
p^.location.referenz:=sref;
end
else p^.location.referenz:=href;
end;
{ ließe sich auch in secondadd einbauen }
{ aber es soll ja übersichtlich bleiben }
procedure secondin(var p : ptree);far;
var
pushed : boolean;
swapp : ptree;
begin
if p^.left^.treetype=ordconstn then
begin
{ nur obligatorisch }
secondpass(p^.left);
secondpass(p^.right);
if codegenerror then
exit;
p^.location.resflags:=F_NE;
inc(p^.right^.location.referenz.offset,p^.left^.value div 8);
emit(A_TEST,S_B,'$'+tostr(1 shl (p^.left^.value mod 8))+
','+getreferenzstring(p^.right^.location.referenz));
del_referenz(p^.right^.location.referenz);
end
else
begin
{ beide Operanden berechnen }
{ den schwierigeren zuerst }
firstcomplex(p);
secondpass(p^.left);
p^.location:=p^.left^.location;
{ sind zuwenig Register frei? }
pushed:=maybe_push(p^.right^.registers32,p);
secondpass(p^.right);
if pushed then restore(p);
{ natürlich nicht kommutativ }
if p^.swaped then
begin
swapp:=p^.left;
p^.left:=p^.right;
p^.right:=swapp;
p^.swaped:=not(p^.swaped);
end;
pushsetelement(p^.left);
emitpushreferenzaddr(p^.right^.location.referenz);
del_referenz(p^.right^.location.referenz);
{ Register müssen keine gerettet werden, das geschieht in }
{ SET_IN_BYTE (EDI wird verändert) }
emit(CALL,S_NO,'SET_IN_BYTE');
p^.location.loc:=LOC_FLAGS;
p^.location.resflags:=F_C;
end;
end;
procedure secondexpr(var p : ptree);far;
begin
secondpass(p^.left);
end;
procedure secondblockn(var p : ptree);far;
var
hp : ptree;
begin
hp:=p^.left;
while assigned(hp) do
begin
{ Anweisungen können wegoptimiert sein }
if assigned(hp^.right) then
begin
cleartempgen;
secondpass(hp^.right);
end;
hp:=hp^.left;
end;
end;
procedure second_while_repeatn(var p : ptree);far;
var
l1,l2,l3,oldclabel,oldblabel : longint;
begin
l1:=getlabel;
l2:=getlabel;
{ Continue und Breaklabels einrichten: }
oldclabel:=aktcontinuelabel;
oldblabel:=aktbreaklabel;
if p^.treetype=repeatn then
begin
aktcontinuelabel:=l1;
aktbreaklabel:=l2;
emitl(A_LABEL,l1);
cleartempgen;
secondpass(p^.right);
truelabel:=l2;
falselabel:=l1;
cleartempgen;
secondpass(p^.left);
maketojumpbool(p^.left);
emitl(A_LABEL,l2);
end
else
begin
l3:=getlabel;
aktcontinuelabel:=l1;
aktbreaklabel:=l3;
{ Bedingungscode kommt ans Ende, da dies meist effizienter ist }
emitl(JMP,l2);
emitl(A_LABEL,l1);
cleartempgen;
secondpass(p^.right);
emitl(A_LABEL,l2);
truelabel:=l1;
falselabel:=l3;
cleartempgen;
secondpass(p^.left);
maketojumpbool(p^.left);
emitl(A_LABEL,l3);
end;
aktcontinuelabel:=oldclabel;
aktbreaklabel:=oldblabel;
end;
procedure secondifn(var p : ptree);far;
var
l1,l2,hl : longint;
begin
l1:=getlabel;
l2:=getlabel;
truelabel:=l1;
falselabel:=l2;
cleartempgen;
secondpass(p^.left);
maketojumpbool(p^.left);
if assigned(p^.right) then
begin
emitl(A_LABEL,l1);
cleartempgen;
secondpass(p^.right);
end;
if assigned(p^.t1) then
begin
if assigned(p^.right) then
begin
hl:=getlabel;
emitl(JMP,hl);
end;
emitl(A_LABEL,l2);
cleartempgen;
secondpass(p^.t1);
if assigned(p^.right) then
emitl(A_LABEL,hl);
end
else
emitl(A_LABEL,l2);
if not(assigned(p^.right)) then
emitl(A_LABEL,l1);
end;
procedure secondbreakn(var p : ptree);far;
begin
if aktbreaklabel<>0 then
emitl(JMP,aktbreaklabel)
else
error(break_not_allowed);
end;
procedure secondcontinuen(var p : ptree);far;
begin
if aktcontinuelabel<>0 then
emitl(JMP,aktcontinuelabel)
else
error(continue_not_allowed);
end;
procedure secondfor(var p : ptree);far;
var
l1,l2,oldclabel,oldblabel : longint;
omitfirstcomp,temptovalue : boolean;
hs : byte;
temp1 : treferenz;
hop : tasmop;
cmpreg,cmp32 : tregister;
opsize : topsize;
begin
oldclabel:=aktcontinuelabel;
oldblabel:=aktbreaklabel;
l1:=getlabel;
l2:=getlabel;
aktbreaklabel:=l2;
aktcontinuelabel:=l1;
{ können wir uns den ersten Vergleich sparen ? }
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));
{ nur Referenz berechnen }
cleartempgen;
secondpass(p^.t2);
if not(simple_loadn) then
error(invalid_for_var);
{ Startzuweisung erzeugen }
cleartempgen;
secondpass(p^.left);
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);
{ Zielwert berechnen und prüfen ob vielleicht veränderlich }
{ falls dem so ist, in temporäre Variable laden }
if p^.right^.treetype<>ordconstn then
begin
gettempofsizereferenz(hs,temp1);
temptovalue:=true;
if (p^.right^.location.loc=LOC_REGISTER) or
(p^.right^.location.loc=LOC_CREGISTER) then
begin
emit(MOV,opsize,regid2str[p^.right^.location.register]
+','+getreferenzstring(temp1));
end
else
concatcopy(p^.right^.location.referenz,temp1,hs,false);
end
else temptovalue:=false;
if temptovalue then
begin
if p^.t2^.location.loc=LOC_CREGISTER then
emit(MOV,opsize,regid2str[p^.t2^.location.register]+','+
regid2str[cmpreg])
else
emit(MOV,opsize,getreferenzstring(p^.t2^.location.referenz)+','+
regid2str[cmpreg]);
emit(CMP,opsize,getreferenzstring(temp1)+','+
regid2str[cmpreg]);
end
else
begin
if not(omitfirstcomp) then
begin
if p^.t2^.location.loc=LOC_CREGISTER then
emit(CMP,opsize,'$'+tostr(p^.right^.value)+','+
regid2str[p^.t2^.location.register])
else
emit(CMP,opsize,'$'+tostr(p^.right^.value)+','+
getreferenzstring(p^.t2^.location.referenz));
end;
end;
if p^.backward then
hop:=JL
else hop:=JG;
if not(omitfirstcomp) or temptovalue then
emitl(hop,aktbreaklabel);
emitl(A_LABEL,aktcontinuelabel);
{ Hilfsregister darf im Anweisungsblock nicht belegt sein }
cleartempgen;
if assigned(p^.t1) then
secondpass(p^.t1);
{ schadet hier absolut nicht }
cleartempgen;
{ Hilfsregister wieder anfordern }
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;
{ je nach Zählrichtung DEC oder INC...}
if p^.backward then
hop:=A_DEC
else hop:=A_INC;
if p^.t2^.location.loc=LOC_CREGISTER then
emit(hop,opsize,regid2str[p^.t2^.location.register])
else
emit(hop,opsize,getreferenzstring(p^.t2^.location.referenz));
{ Vergleich erzeugen und den entsprechenden }
{ Sprung }
if temptovalue then
begin
if p^.t2^.location.loc=LOC_CREGISTER then
emit(MOV,opsize,regid2str[p^.t2^.location.register]+','+
regid2str[cmpreg])
else
emit(MOV,opsize,getreferenzstring(p^.t2^.location.referenz)+','+
regid2str[cmpreg]);
emit(CMP,opsize,getreferenzstring(temp1)+','+
regid2str[cmpreg]);
end
else
begin
if p^.t2^.location.loc=LOC_CREGISTER then
emit(CMP,opsize,'$'+tostr(p^.right^.value)+','+
regid2str[p^.t2^.location.register])
else
emit(CMP,opsize,'$'+tostr(p^.right^.value)+','+
getreferenzstring(p^.t2^.location.referenz));
end;
if p^.backward then
hop:=JGE
else hop:=JLE;
emitl(hop,aktcontinuelabel);
{ break-Label: }
emitl(A_LABEL,aktbreaklabel);
ungetregister32(cmp32);
aktcontinuelabel:=oldclabel;
aktbreaklabel:=oldblabel;
end;
var
hs : string;
procedure secondexitn(var p : ptree);far;
label
do_jmp;
begin
if assigned(p^.left) then
begin
truelabel:=getlabel;
falselabel:=getlabel;
secondpass(p^.left);
case p^.left^.location.loc of
LOC_MEM,LOC_REFERENZ : hs:=getreferenzstring(p^.left^.location.referenz);
LOC_CREGISTER,
LOC_REGISTER : hs:=regid2str[p^.left^.location.register];
LOC_FLAGS : begin
emit(flag_2_set[p^.right^.location.resflags],S_NO,'%al');
goto do_jmp;
end;
LOC_JUMP : begin
emitl(A_LABEL,truelabel);
emit(MOV,S_B,'$1,%al');
emitl(JMP,aktexit2label);
emit(A_XOR,S_B,'%al,%al');
goto do_jmp;
end;
else internalerror(2001);
end;
if (procinfo.retdef^.deftype=grunddef) then
begin
case pgrunddef(procinfo.retdef)^.typ of
s32bit : emit(MOV,S_L,hs+',%eax');
u8bit,s8bit,uchar,bool8bit :
emit(MOV,S_B,hs+',%al');
s16bit,u16bit :
emit(MOV,S_W,hs+',%ax');
s64real :
emit(FLD,S_L,hs);
end;
end
else
if (procinfo.retdef^.deftype=pointerdef) or
(procinfo.retdef^.deftype=aufzaehldef) or
(procinfo.retdef^.deftype=procvardef) then
emit(MOV,S_L,hs+',%eax');
do_jmp:
emitl(JMP,aktexit2label);
end
else
begin
emitl(JMP,aktexitlabel);
end;
end;
procedure secondgoto(var p : ptree);far;
begin
emitl(JMP,p^.labelnr);
end;
procedure secondlabel(var p : ptree);far;
begin
emitl(A_LABEL,p^.labelnr);
cleartempgen;
secondpass(p^.left);
end;
procedure secondasm(var p : ptree);far;
begin
exprasmlist.concatlist(p^.p_asm);
end;
procedure secondcase(var p : ptree);far;
var
with_sign : boolean;
opsize : topsize;
jmp_gt,jmp_le,jmp_lee : tasmop;
hp : ptree;
{ register with case expression }
hregister : tregister;
endlabel,elselabel : longint;
procedure gentreejmp(p : pcaserecord);
var
lesslabel,greaterlabel : longint;
begin
emitl(A_LABEL,p^.at);
{ Labels für links und rechts berechnen }
if (p^.less=nil) then
lesslabel:=elselabel
else
lesslabel:=p^.less^.at;
if (p^.greater=nil) then
greaterlabel:=elselabel
else
greaterlabel:=p^.greater^.at;
{ keine Bereichslabel :}
if p^.low=p^.high then
begin
emit(CMP,opsize,'$'+tostr(p^.low)+','+regid2str[hregister]);
if greaterlabel=lesslabel then
begin
emitl(JNE,lesslabel);
end
else
begin
emitl(jmp_le,lesslabel);
emitl(jmp_gt,greaterlabel);
end;
emitl(JMP,p^.anweisung);
end
else
{ Bereichslabel: }
begin
emit(CMP,opsize,'$'+tostr(p^.low)+','+regid2str[hregister]);
emitl(jmp_le,lesslabel);
emit(CMP,opsize,'$'+tostr(p^.high)+','+regid2str[hregister]);
emitl(jmp_gt,greaterlabel);
emitl(JMP,p^.anweisung);
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
emit(A_DEC,opsize,regid2str[hregister])
else if t^.low-last=0 then
emit(A_OR,opsize,regid2str[hregister]+','+regid2str[hregister])
else
emit(SUB,opsize,'$'+tostr(t^.low-last)+','+regid2str[hregister]);
last:=t^.low;
emitl(JZ,t^.anweisung);
end
else
begin
{ es wird mit dem kleinsten Label angefangen, }
{ sollte der Wert noch kleiner sein, dann gleich }
{ zum ELSE-Label springen }
if first then
begin
if t^.low-1=1 then
emit(A_DEC,opsize,regid2str[hregister])
else if t^.low-1=0 then
emit(A_OR,opsize,regid2str[hregister]+','+regid2str[hregister])
else
emit(SUB,opsize,'$'+tostr(t^.low-1)+','+regid2str[hregister]);
emitl(jmp_lee,elselabel);
end
{ ist zwischen dem letzten und dem aktuellen Label }
{ keine Lücke, so kann direkt die untere Grenze }
{ geprüft werden }
{ ansonsten auf Bereich dazwischen prüfen: }
else if (t^.low-last>1)then
begin
if t^.low-last-1=1 then
emit(A_DEC,opsize,regid2str[hregister])
else
emit(SUB,opsize,'$'+tostr(t^.low-last-1)+','+regid2str[hregister]);
emitl(jmp_lee,elselabel);
end;
emit(SUB,opsize,'$'+tostr(t^.high-t^.low+1)+','+regid2str[hregister]);
emitl(jmp_lee,t^.anweisung);
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(JMP,elselabel);
end;
procedure genjumptable(hp : pcaserecord;min_,max_ : longint);
var
table,last : longint;
procedure genitem(t : pcaserecord);
var
i : longint;
begin
if assigned(t^.less) then
genitem(t^.less);
{ mögliche Lücken füllen }
for i:=last+1 to t^.low-1 do
emit(A_LONG,S_NO,tolabel(elselabel));
for i:=t^.low to t^.high do
emit(A_LONG,S_NO,tolabel(t^.anweisung));
last:=t^.high;
if assigned(t^.greater) then
genitem(t^.greater);
end;
begin
emit(CMP,opsize,'$'+tostr(min_)+','+regid2str[hregister]);
{ cas expr less than min_ => goto elselabel }
emitl(jmp_le,elselabel);
emit(CMP,opsize,'$'+tostr(max_)+','+regid2str[hregister]);
emitl(jmp_gt,elselabel);
table:=getlabel;
{ Vorzeichen erweitern }
if opsize=S_W then
begin
emit(MOVZX,S_WL,regid2str[hregister]+
','+regid2str[reg16toreg32(hregister)]);
hregister:=reg16toreg32(hregister);
end
else if opsize=S_B then
begin
emit(MOVZX,S_BL,regid2str[hregister]+
','+regid2str[reg8toreg32(hregister)]);
hregister:=reg8toreg32(hregister);
end;
emit(JMP,S_NO,'*'+tolabel(table)+tostr_with_plus((-min_)*4)+'(,'+regid2str[hregister]+',4)');
{ Tabelle erzeugen }
if not(cs_littlesize in aktswitches ) then
emit(A_ALIGN,S_NO,'4,0x90');
emitl(A_LABEL,table);
last:=min_;
genitem(hp);
if not(cs_littlesize in aktswitches ) then
emit(A_ALIGN,S_NO,'4,0x90');
end;
var
min_label,max_label,labels : longint;
begin
endlabel:=getlabel;
elselabel:=getlabel;
with_sign:=is_signed(p^.left^.resulttype);
if with_sign then
begin
jmp_gt:=JG;
jmp_le:=JL;
jmp_lee:=JLE;
end
else
begin
jmp_gt:=JA;
jmp_le:=JB;
jmp_lee:=JBE;
end;
cleartempgen;
secondpass(p^.left);
{ determines the size of the operand }
case p^.left^.resulttype^.size of
1 : opsize:=S_B;
2 : opsize:=S_W;
4 : opsize:=S_L;
else internalerror(2003);
end;
{ 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_REFERENZ : begin
del_referenz(p^.left^.location.referenz);
hregister:=getregister32;
case opsize of
S_B : hregister:=reg32toreg8(hregister);
S_W : hregister:=reg32toreg16(hregister);
end;
emit(MOV,opsize,getreferenzstring(
p^.left^.location.referenz)+','+regid2str[hregister]);
end;
else internalerror(2002);
end;
{ now generate the jumps }
if cs_optimize in aktswitches then
begin
{ Verfahren wird empirisch ermittelt }
{ der Aufwand wäre auch berechenbar }
{ aber lohnt sich das bei den verschiedenen }
{ Prozessoren ? }
{ außerdem ließe sich die Größe auch nur }
{ ungefähr berechnen, da dei nicht bekannt }
{ ist, ob rel8,rel16 oder rel32 Sprünge be- }
{ nötigt werden }
min_label:=case_get_min(p^.nodes);
max_label:=case_get_max(p^.nodes);
labels:=case_count_labels(p^.nodes);
{ optimize for size ? }
if cs_littlesize in aktswitches then
begin
{ if the labels less or more a continuum then }
{ generate a jump table }
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
genjumptable(p^.nodes,min_label,max_label);
end
else
begin
if (labels<=2) then
genlinearlist(p^.nodes)
else
begin
if ((max_label-min_label)>6*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(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;
procedure secondpass(var p : ptree);
const
procedures : array[addn..simplenewn] of secondpassproc =
(secondadd,secondadd,secondadd,secondmoddiv,
secondmoddiv,secondassignment,secondload,secondnothing,
secondadd,secondadd,secondadd,secondadd,
secondadd,secondadd,secondin,secondadd,
secondadd,secondshlshr,secondshlshr,secondadd,
secondadd,secondsubscriptn,secondderef,secondaddr,
secondordconst,secondtypeconv,secondcalln,secondnothing,
secondrealconst,secondumminus,secondasm,secondvecn,
secondstringconst,secondfuncret,secondselfn,
secondnot,secondinline,secondniln,seconderror,
secondnothing,secondhnewn,secondhdisposen,secondnewn,
secondsimplenewdispose,secondnothing,secondsetcons,secondblockn,
secondnothing,secondnothing,secondifn,secondbreakn,
secondcontinuen,second_while_repeatn,second_while_repeatn,secondfor,
secondexitn,secondnothing,secondcase,secondlabel,
secondgoto,secondsimplenewdispose);
var
oldcodegenerror : boolean;
begin
oldcodegenerror:=codegenerror;
codegenerror:=false;
inputstack:=p^.inputfile;
inputstack^.line_no:=p^.line;
if not(p^.error) then
begin
procedures[p^.treetype](p);
p^.error:=codegenerror;
codegenerror:=codegenerror or oldcodegenerror;
end
else codegenerror:=true;
end;
function do_secondpass(var p : ptree) : boolean;
begin
codegenerror:=false;
if not(p^.error) then
secondpass(p);
do_secondpass:=codegenerror;
end;
var
regvars : array[1..maxvarregs] of pvarsym;
procedure searchregvars(p : psym);far;
var
i,j : longint;
begin
if (p^.typ=varsym) and (pvarsym(p)^.regable) then
begin
{ alle momentanen Registervariablen durchlaufen }
for i:=1 to maxvarregs do
begin
{ noch ein Register frei? }
if regvars[i]=nil then
begin
regvars[i]:=pvarsym(p);
break;
end;
{ oder eine Variable hinauswerfen? }
if pvarsym(p)^.refs>regvars[i]^.refs then
begin
for j:=maxvarregs-1 downto i do
regvars[j+1]:=regvars[j];
regvars[i]:=pvarsym(p);
break;
end;
end;
end;
end;
procedure generatecode(var p : ptree);
var
{ *pass modifiziert für jede Node aktlinenr und inputstack, }
{ um immer richtige Zeilennummern zu erhalten }
oldis : pinputstack;
oldnr,i : longint;
begin
cleartempgen;
oldis:=inputstack;
oldnr:=inputstack^.line_no;
{ bei Größe nur Vorkommen zählen }
if cs_littlesize in aktswitches then
t_times:=1
else
{ Referenz für Wiederholungen ist 100, }
{ wenn auf Geschwindigkeit optimiert }
{ wird }
t_times:=100;
if not(do_firstpass(p)) then
begin
{ Registervariablen möglich ? }
if (cs_maxoptimieren in aktswitches) and (p^.registers32<4) and
not(procinfo.uses_asm) then
begin
{ Kandidaten für Register heraussuchen }
for i:=1 to maxvarregs do
regvars[i]:=nil;
{$ifdef tp}
symtablestack^.foreach(searchregvars);
{$else}
symtablestack^.foreach(@searchregvars);
{$endif}
{ benötigte Register freihalten }
for i:=maxvarregs downto maxvarregs-p^.registers32+1 do
regvars[i]:=nil;
{ nun die Register aufteilen }
for i:=1 to maxvarregs do
begin
if assigned(regvars[i]) then
begin
{ Register ist nicht mehr für Ausdrücke }
{ verfügbar }
usableregs:=usableregs-[varregs[i]];
dec(c_usableregs);
{ möglicherweise werden keine 32 Bit Register }
{ gebraucht: }
if (regvars[i]^.definition^.deftype=grunddef) and
(
(pgrunddef(regvars[i]^.definition)^.typ=bool8bit) or
(pgrunddef(regvars[i]^.definition)^.typ=uchar) or
(pgrunddef(regvars[i]^.definition)^.typ=u8bit) or
(pgrunddef(regvars[i]^.definition)^.typ=s8bit)
) then
regvars[i]^.reg:=reg32toreg8(varregs[i])
else if (regvars[i]^.definition^.deftype=grunddef) and
(
(pgrunddef(regvars[i]^.definition)^.typ=u16bit) or
(pgrunddef(regvars[i]^.definition)^.typ=s16bit)
) then
regvars[i]^.reg:=reg32toreg16(varregs[i])
else regvars[i]^.reg:=varregs[i];
{ Register ist im Unterprogramm belegt }
usedinproc:=usedinproc or ($80 shr byte(varregs[i]));
end;
end;
{$ifdef EXTDEBUG}
for i:=1 to maxvarregs do
begin
if assigned(regvars[i]) then
writeln(' Register ',regid2str[regvars[i]^.reg],': ',regvars[i]^.name,
' Gewichtung: ',regvars[i]^.refs);
end;
{$endif}
end;
do_secondpass(p);
{ alle Register sind wieder benutzbar }
usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX];
c_usableregs:=4;
end;
aktproccode.concatlist(@exprasmlist);
inputstack:=oldis;
inputstack^.line_no:=oldnr;
end;
procedure codegeninit;
begin
aktbreaklabel:=0;
aktexitlabel:=0;
aktcontinuelabel:=0;
aktexitlabel:=0;
aktexceptlabel:=0;
aktentrycode.init;
aktexitcode.init;
aktexceptcode.init;
aktproccode.init;
exprasmlist.init;
datasegment.init;
constsegment.init;
vmtasmlist.init;
debuginfos.init;
end;
procedure codegendone;
begin
aktentrycode.done;
aktexitcode.done;
aktexceptcode.done;
aktproccode.done;
exprasmlist.done;
datasegment.done;
constsegment.done;
vmtasmlist.done;
debuginfos.done;
end;
end.
