{ $Id: cgi386.pas,v 1.3.2.2 1998/08/18 13:48:34 carl Exp $ Copyright (c) 1993-98 by Florian Klaempfl This unit generates i386 (or better) assembler from the parse tree This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } {$ifdef tp} {$E+,F+,N+,D+,L+,Y+} {$endif} unit cgi386; {***************************************************************************} interface {***************************************************************************} uses objects,verbose,cobjects,systems,globals,tree, symtable,types,strings,pass_1,hcodegen, aasm,i386,tgeni386,files,cgai386 {$ifdef GDB} ,gdb {$endif GDB} {$ifdef TP} ,cgi3862 {$endif TP} ; { produces assembler for the expression in variable p } { and produces an assembler node at the end } procedure generatecode(var p : ptree); { produces the actual code } function do_secondpass(var p : ptree) : boolean; procedure secondpass(var p : ptree); {$ifdef test_dest_loc} const { used to avoid temporary assignments } dest_loc_known : boolean = false; in_dest_loc : boolean = false; dest_loc_tree : ptree = nil; var dest_loc : tlocation; procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); {$endif test_dest_loc} {***************************************************************************} implementation {***************************************************************************} const never_copy_const_param : boolean = false; {$ifdef test_dest_loc} procedure mov_reg_to_dest(p : ptree; s : topsize; reg : tregister); begin if (dest_loc.loc=LOC_CREGISTER) or (dest_loc.loc=LOC_REGISTER) then begin emit_reg_reg(A_MOV,s,reg,dest_loc.register); p^.location:=dest_loc; in_dest_loc:=true; end else if (dest_loc.loc=LOC_REFERENCE) or (dest_loc.loc=LOC_MEM) then begin exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,s,reg,newreference(dest_loc.reference)))); p^.location:=dest_loc; in_dest_loc:=true; end else internalerror(20080); end; {$endif test_dest_loc} const bytes2Sxx:array[1..4] of Topsize=(S_B,S_W,S_NO,S_L); procedure error(const t : tmsgconst); begin if not(codegenerror) then verbose.Message(t); codegenerror:=true; end; type secondpassproc = procedure(var p : ptree); procedure seconderror(var p : ptree); begin p^.error:=true; codegenerror:=true; end; var { this is for open arrays and strings } { but be careful, this data is in the } { generated code destroyed quick, and also } { the next call of secondload destroys this } { data } { So be careful using the informations } { provided by this variables } highframepointer : tregister; highoffset : longint; {$ifndef TP} {$I cgi386ad.inc} {$endif TP} procedure secondload(var p : ptree); var hregister : tregister; symtabletype : tsymtabletype; i : longint; hp : preference; begin simple_loadn:=true; reset_reference(p^.location.reference); case p^.symtableentry^.typ of { this is only for toasm and toaddr } absolutesym : begin stringdispose(p^.location.reference.symbol); if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then begin if pabsolutesym(p^.symtableentry)^.absseg then p^.location.reference.segment:=R_FS; p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address; end else p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if p^.symtableentry^.owner^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; varsym : begin hregister:=R_NO; symtabletype:=p^.symtable^.symtabletype; { in case it is a register variable: } if pvarsym(p^.symtableentry)^.reg<>R_NO then begin p^.location.loc:=LOC_CREGISTER; p^.location.register:=pvarsym(p^.symtableentry)^.reg; unused:=unused-[pvarsym(p^.symtableentry)^.reg]; end else begin { first handle local and temporary variables } if (symtabletype=parasymtable) or (symtabletype=localsymtable) then begin p^.location.reference.base:=procinfo.framepointer; p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; if (symtabletype=localsymtable) then p^.location.reference.offset:=-p^.location.reference.offset; if (symtabletype=parasymtable) then inc(p^.location.reference.offset,p^.symtable^.call_offset); if (lexlevel>(p^.symtable^.symtablelevel)) then begin hregister:=getregister32; { make a reference } new(hp); reset_reference(hp^); hp^.offset:=procinfo.framepointer_offset; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); simple_loadn:=false; i:=lexlevel-1; while i>(p^.symtable^.symtablelevel) do begin { make a reference } new(hp); reset_reference(hp^); hp^.offset:=8; hp^.base:=hregister; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); dec(i); end; p^.location.reference.base:=hregister; end; end else case symtabletype of unitsymtable,globalsymtable, staticsymtable : begin stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; objectsymtable : begin if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then begin stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end else begin p^.location.reference.base:=R_ESI; p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address; end; end; withsymtable: begin hregister:=getregister32; p^.location.reference.base:=hregister; { make a reference } new(hp); reset_reference(hp^); hp^.offset:=p^.symtable^.datasize; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister))); p^.location.reference.offset:= pvarsym(p^.symtableentry)^.address; end; end; { in case call by reference, then calculate: } if (pvarsym(p^.symtableentry)^.varspez=vs_var) or ((pvarsym(p^.symtableentry)^.varspez=vs_const) and dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) then begin simple_loadn:=false; if hregister=R_NO then hregister:=getregister32; if (p^.location.reference.base=procinfo.framepointer) then begin highframepointer:=p^.location.reference.base; highoffset:=p^.location.reference.offset; end else begin highframepointer:=R_EDI; highoffset:=p^.location.reference.offset; exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, p^.location.reference.base,R_EDI))); end; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference), hregister))); clear_reference(p^.location.reference); p^.location.reference.base:=hregister; end; { if (pvarsym(p^.symtableentry)^.definition^.deftype=objectdef) and ((pobjectdef(pvarsym(p^.symtableentry)^.definition)^.options and oois_class)<>0) then begin simple_loadn:=false; if hregister=R_NO then hregister:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference), hregister))); clear_reference(p^.location.reference); p^.location.reference.base:=hregister; end; } end; end; procsym: begin {!!!!! Be aware, work on virtual methods too } stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:= stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname); if p^.symtable^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; typedconstsym : begin stringdispose(p^.location.reference.symbol); p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname); if p^.symtable^.symtabletype=unitsymtable then concat_external(p^.symtableentry^.mangledname,EXT_NEAR); end; else internalerror(4); end; end; procedure secondmoddiv(var p : ptree); var hreg1 : tregister; pushed,popeax,popedx : boolean; power : longint; hl : plabel; begin secondpass(p^.left); set_location(p^.location,p^.left^.location); pushed:=maybe_push(p^.right^.registers32,p); secondpass(p^.right); if pushed then restore(p); { put numerator in register } if p^.left^.location.loc<>LOC_REGISTER then begin if p^.left^.location.loc=LOC_CREGISTER then begin hreg1:=getregister32; emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hreg1); end else begin del_reference(p^.left^.location.reference); hreg1:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), 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 exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,hreg1,hreg1))); getlabel(hl); emitl(A_JNS,hl); if power=1 then exprasmlist^.concat(new(pai386,op_reg(A_INC,S_L,hreg1))) else exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,p^.right^.value-1,hreg1))); emitl(A_LABEL,hl); exprasmlist^.concat(new(pai386,op_const_reg(A_SAR,S_L,power,hreg1))); end else begin { bring denominator to EDI } { EDI is always free, it's } { only used for temporary } { purposes } if (p^.right^.location.loc<>LOC_REGISTER) and (p^.right^.location.loc<>LOC_CREGISTER) then begin del_reference(p^.right^.location.reference); p^.left^.location.loc:=LOC_REGISTER; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI))); end else begin ungetregister32(p^.right^.location.register); emit_reg_reg(A_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 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); popeax:=true; end; emit_reg_reg(A_MOV,S_L,R_EDX,R_EAX); end else begin if not(R_EDX in unused) then begin exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDX))); popedx:=true; end; if hreg1<>R_EAX then begin if not(R_EAX in unused) then begin exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); popeax:=true; end; emit_reg_reg(A_MOV,S_L,hreg1,R_EAX); end; end; exprasmlist^.concat(new(pai386,op_none(A_CLTD,S_NO))); exprasmlist^.concat(new(pai386,op_reg(A_IDIV,S_L,R_EDI))); if p^.treetype=divn then begin { if result register is busy then copy } if popeax then begin if hreg1=R_EAX then internalerror(112); emit_reg_reg(A_MOV,S_L,R_EAX,hreg1) end else if hreg1<>R_EAX then emit_reg_reg(A_MOV,S_L,R_EAX,hreg1); end else emit_reg_reg(A_MOV,S_L,R_EDX,hreg1); if popeax then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX))); if popedx then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDX))); end; { this registers are always used when div/mod are present } usedinproc:=usedinproc or ($80 shr byte(R_EAX)); usedinproc:=usedinproc or ($80 shr byte(R_EDX)); p^.location.loc:=LOC_REGISTER; p^.location.register:=hreg1; end; procedure secondshlshr(var p : ptree); 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); { load left operators in a register } if p^.left^.location.loc<>LOC_REGISTER then begin if p^.left^.location.loc=LOC_CREGISTER then begin hregister1:=getregister32; emit_reg_reg(A_MOV,S_L,p^.left^.location.register, hregister1); end else begin del_reference(p^.left^.location.reference); hregister1:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), hregister1))); end; end else hregister1:=p^.left^.location.register; { determine operator } if p^.treetype=shln then op:=A_SHL else op:=A_SHR; { shifting by a constant directly decode: } if (p^.right^.treetype=ordconstn) then begin exprasmlist^.concat(new(pai386,op_const_reg(op,S_L,p^.right^.location.reference.offset and 31, hregister1))); p^.location.loc:=LOC_REGISTER; p^.location.register:=hregister1; end else begin { load right operators in a register } if p^.right^.location.loc<>LOC_REGISTER then begin if p^.right^.location.loc=LOC_CREGISTER then begin hregister2:=getregister32; emit_reg_reg(A_MOV,S_L,p^.right^.location.register, hregister2); end else begin del_reference(p^.right^.location.reference); hregister2:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference), hregister2))); end; end else hregister2:=p^.right^.location.register; { left operator is already in a register } { hence are both in a register } { is it in the case ECX ? } if (hregister1=R_ECX) then begin { then only swap } emit_reg_reg(A_XCHG,S_L,hregister1, hregister2); hregister3:=hregister1; hregister1:=hregister2; hregister2:=hregister3; end { if second operator not in ECX ? } else if (hregister2<>R_ECX) then begin { ECX not occupied then swap with right register } if R_ECX in unused then begin emit_reg_reg(A_MOV,S_L,hregister2,R_ECX); ungetregister32(hregister2); end else begin { else save ECX and then copy it } popecx:=true; exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ECX))); emit_reg_reg(A_MOV,S_L,hregister2,R_ECX); ungetregister32(hregister2); end; end; { right operand is in ECX } emit_reg_reg(op,S_L,R_CL,hregister1); { maybe ECX back } if popecx then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ECX))); p^.location.register:=hregister1; end; { this register is always used when shl/shr are present } usedinproc:=usedinproc or ($80 shr byte(R_ECX)); end; procedure secondrealconst(var p : ptree); var hp1 : pai; lastlabel : plabel; found : boolean; begin clear_reference(p^.location.reference); lastlabel:=nil; found:=false; { const already used ? } if p^.labnumber=-1 then begin { tries to found an old entry } hp1:=pai(consts^.first); while assigned(hp1) do begin if hp1^.typ=ait_label then lastlabel:=pai_label(hp1)^.l else begin if (hp1^.typ=p^.realtyp) and (lastlabel<>nil) then begin { Florian this caused a internalerror(10)=> no free reg !! } {if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) or ((p^.realtyp=ait_real_80bit) and (pai_extended(hp1)^.value=p^.valued)) or ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then } if ((p^.realtyp=ait_real_64bit) and (pai_double(hp1)^.value=p^.valued)) then found:=true; if ((p^.realtyp=ait_real_extended) and (pai_extended(hp1)^.value=p^.valued)) then found:=true; if ((p^.realtyp=ait_real_32bit) and (pai_single(hp1)^.value=p^.valued)) then found:=true; if found then begin { found! } p^.labnumber:=lastlabel^.nb; break; end; end; lastlabel:=nil; end; hp1:=pai(hp1^.next); end; { :-(, we must generate a new entry } if p^.labnumber=-1 then begin getlabel(lastlabel); p^.labnumber:=lastlabel^.nb; case p^.realtyp of ait_real_64bit : consts^.insert(new(pai_double,init(p^.valued))); ait_real_32bit : consts^.insert(new(pai_single,init(p^.valued))); ait_real_extended : consts^.insert(new(pai_extended,init(p^.valued))); else internalerror(10120); end; {$ifndef MAKELIB} consts^.insert(new(pai_label,init(lastlabel))); {$else MAKELIB} consts^.insert(new(pai_symbol,init_global('$'+current_module^.name^ +'$real_const'+tostr(p^.labnumber)))); consts^.insert(new(pai_cut,init)); {$endif MAKELIB} end; end; stringdispose(p^.location.reference.symbol); {$ifndef MAKELIB} p^.location.reference.symbol:=stringdup(lab2str(lastlabel)); {$else MAKELIB} p^.location.reference.symbol:=stringdup('$'+current_module^.name^ +'$real_const'+tostr(p^.labnumber)); {$endif MAKELIB} end; procedure secondfixconst(var p : ptree); begin { an fix comma const. behaves as a memory reference } p^.location.loc:=LOC_MEM; p^.location.reference.isintvalue:=true; p^.location.reference.offset:=p^.valuef; end; procedure secondordconst(var p : ptree); begin { an integer const. behaves as a memory reference } p^.location.loc:=LOC_MEM; p^.location.reference.isintvalue:=true; p^.location.reference.offset:=p^.value; end; procedure secondniln(var p : ptree); begin p^.location.loc:=LOC_MEM; p^.location.reference.isintvalue:=true; p^.location.reference.offset:=0; end; procedure secondstringconst(var p : ptree); var hp1 : pai; lastlabel : plabel; pc : pchar; same_string : boolean; i : word; begin clear_reference(p^.location.reference); lastlabel:=nil; { const already used ? } if p^.labstrnumber=-1 then begin { tries to found an old entry } hp1:=pai(consts^.first); while assigned(hp1) do begin if hp1^.typ=ait_label then lastlabel:=pai_label(hp1)^.l else begin if (hp1^.typ=ait_string) and (lastlabel<>nil) and (pai_string(hp1)^.len=length(p^.values^)+2) then begin same_string:=true; for i:=1 to length(p^.values^) do if pai_string(hp1)^.str[i]<>p^.values^[i] then begin same_string:=false; break; end; if same_string then begin { found! } p^.labstrnumber:=lastlabel^.nb; break; end; end; lastlabel:=nil; end; hp1:=pai(hp1^.next); end; { :-(, we must generate a new entry } if p^.labstrnumber=-1 then begin getlabel(lastlabel); p^.labstrnumber:=lastlabel^.nb; getmem(pc,length(p^.values^)+3); move(p^.values^,pc^,length(p^.values^)+1); pc[length(p^.values^)+1]:=#0; { we still will have a problem if there is a #0 inside the pchar } consts^.insert(new(pai_string,init_pchar(pc))); { to overcome this problem we set the length explicitly } { with the ending null char } pai_string(consts^.first)^.len:=length(p^.values^)+2; {$ifndef MAKELIB} consts^.insert(new(pai_label,init(lastlabel))); {$else MAKELIB} consts^.insert(new(pai_symbol,init_global('$'+current_module^.name^ +'$string_const'+tostr(p^.labstrnumber)))); consts^.insert(new(pai_cut,init)); {$endif MAKELIB} end; end; stringdispose(p^.location.reference.symbol); {$ifndef MAKELIB} p^.location.reference.symbol:=stringdup(lab2str(lastlabel)); {$else MAKELIB} p^.location.reference.symbol:=stringdup('$'+current_module^.name^ +'$string_const'+tostr(p^.labstrnumber)); {$endif MAKELIB} p^.location.loc := LOC_MEM; end; procedure secondumminus(var p : ptree); {$ifdef SUPPORT_MMX} procedure do_mmx_neg; var op : tasmop; begin p^.location.loc:=LOC_MMXREGISTER; if cs_mmx_saturation in aktswitches then case mmx_type(p^.resulttype) of mmxs8bit: op:=A_PSUBSB; mmxu8bit: op:=A_PSUBUSB; mmxs16bit,mmxfixed16: op:=A_PSUBSW; mmxu16bit: op:=A_PSUBUSW; end else case mmx_type(p^.resulttype) of mmxs8bit,mmxu8bit: op:=A_PSUBB; mmxs16bit,mmxu16bit,mmxfixed16: op:=A_PSUBW; mmxs32bit,mmxu32bit: op:=A_PSUBD; end; emit_reg_reg(op,S_NO,p^.location.register,R_MM7); emit_reg_reg(A_MOVQ,S_NO,R_MM7,p^.location.register); end; {$endif} begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; case p^.left^.location.loc of LOC_REGISTER: begin p^.location.register:=p^.left^.location.register; exprasmlist^.concat(new(pai386,op_reg(A_NEG,S_L,p^.location.register))); end; LOC_CREGISTER: begin p^.location.register:=getregister32; emit_reg_reg(A_MOV,S_L,p^.location.register, p^.location.register); exprasmlist^.concat(new(pai386,op_reg(A_NEG,S_L,p^.location.register))); end; {$ifdef SUPPORT_MMX} LOC_MMXREGISTER: begin p^.location:=p^.left^.location; emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7); do_mmx_neg; end; LOC_CMMXREGISTER: begin p^.location.register:=getregistermmx; emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7); emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register, p^.location.register); do_mmx_neg; end; {$endif SUPPORT_MMX} LOC_REFERENCE,LOC_MEM: begin del_reference(p^.left^.location.reference); if (p^.left^.resulttype^.deftype=floatdef) and (pfloatdef(p^.left^.resulttype)^.typ<>f32bit) then begin p^.location.loc:=LOC_FPU; floatload(pfloatdef(p^.left^.resulttype)^.typ, p^.left^.location.reference); exprasmlist^.concat(new(pai386,op_none(A_FCHS,S_NO))); end {$ifdef SUPPORT_MMX} else if (cs_mmx in aktswitches) and is_mmx_able_array(p^.left^.resulttype) then begin p^.location.register:=getregistermmx; emit_reg_reg(A_PXOR,S_NO,R_MM7,R_MM7); exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO, newreference(p^.left^.location.reference), p^.location.register))); do_mmx_neg; end {$endif SUPPORT_MMX} else begin p^.location.register:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.left^.location.reference), p^.location.register))); exprasmlist^.concat(new(pai386,op_reg(A_NEG,S_L,p^.location.register))); end; end; LOC_FPU: begin p^.location.loc:=LOC_FPU; exprasmlist^.concat(new(pai386,op_none(A_FCHS,S_NO))); end; end; { Here was a problem... } { Operand to be negated always } { seems to be converted to signed } { 32-bit before doing neg!! } { So this is useless... } { emitoverflowcheck(p);} end; procedure secondaddr(var p : ptree); begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; del_reference(p^.left^.location.reference); p^.location.register:=getregister32; {@ on a procvar means returning an address to the procedure that is stored in it.} { yes but p^.left^.symtableentry can be nil for example on @self !! } { symtableentry can be also invalid, if left is no tree node } if (p^.left^.treetype=loadn) and assigned(p^.left^.symtableentry) and (p^.left^.symtableentry^.typ=varsym) and (pvarsym(p^.left^.symtableentry)^.definition^.deftype=procvardef) then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.left^.location.reference), p^.location.register))) else exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, newreference(p^.left^.location.reference), p^.location.register))); { for use of other segments } if p^.left^.location.reference.segment<>R_DEFAULT_SEG then p^.location.segment:=p^.left^.location.reference.segment; end; procedure seconddoubleaddr(var p : ptree); begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; del_reference(p^.left^.location.reference); p^.location.register:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, newreference(p^.left^.location.reference), p^.location.register))); end; procedure secondnot(var p : ptree); const flagsinvers : array[F_E..F_BE] of tresflags = (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C, F_A,F_AE,F_B,F_BE); var hl : plabel; begin if (p^.resulttype^.deftype=orddef) and (porddef(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; exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,S_B,1,p^.location.register))); end; LOC_CREGISTER : begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; p^.location.register:=reg32toreg8(getregister32); emit_reg_reg(A_MOV,S_B,p^.left^.location.register, p^.location.register); exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,S_B,1,p^.location.register))); end; LOC_REFERENCE,LOC_MEM : begin secondpass(p^.left); del_reference(p^.left^.location.reference); p^.location.loc:=LOC_REGISTER; p^.location.register:=reg32toreg8(getregister32); if p^.left^.location.loc=LOC_CREGISTER then emit_reg_reg(A_MOV,S_B,p^.left^.location.register, p^.location.register) else exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B, newreference(p^.left^.location.reference), p^.location.register))); exprasmlist^.concat(new(pai386,op_const_reg(A_XOR,S_B,1,p^.location.register))); end; end; end {$ifdef SUPPORT_MMX} else if (cs_mmx in aktswitches) and is_mmx_able_array(p^.left^.resulttype) then begin secondpass(p^.left); p^.location.loc:=LOC_MMXREGISTER; { prepare EDI } exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_L,$ffffffff,R_EDI))); { load operand } case p^.left^.location.loc of LOC_MMXREGISTER: p^.location:=p^.left^.location; LOC_CMMXREGISTER: begin p^.location.register:=getregistermmx; emit_reg_reg(A_MOVQ,S_NO,p^.left^.location.register, p^.location.register); end; LOC_REFERENCE,LOC_MEM: begin del_reference(p^.left^.location.reference); p^.location.register:=getregistermmx; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVQ,S_NO, newreference(p^.left^.location.reference), p^.location.register))); end; end; { load mask } emit_reg_reg(A_MOV,S_D,R_EDI,R_MM7); { lower 32 bit } emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register); { shift mask } exprasmlist^.concat(new(pai386,op_const_reg(A_PSLLQ,S_NO, 32,R_MM7))); { higher 32 bit } emit_reg_reg(A_PXOR,S_D,R_MM7,p^.location.register); end {$endif SUPPORT_MMX} else begin secondpass(p^.left); p^.location.loc:=LOC_REGISTER; case p^.left^.location.loc of LOC_REGISTER : begin p^.location.register:=p^.left^.location.register; exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register))); end; LOC_CREGISTER : begin p^.location.register:=getregister32; emit_reg_reg(A_MOV,S_L,p^.left^.location.register, p^.location.register); exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register))); end; LOC_REFERENCE,LOC_MEM : begin del_reference(p^.left^.location.reference); p^.location.register:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.left^.location.reference), p^.location.register))); exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register))); end; end; {if p^.left^.location.loc=loc_register then p^.location.register:=p^.left^.location.register else begin del_locref(p^.left^.location); p^.location.register:=getregister32; exprasmlist^.concat(new(pai386,op_loc_reg(A_MOV,S_L, p^.left^.location, p^.location.register))); end; exprasmlist^.concat(new(pai386,op_reg(A_NOT,S_L,p^.location.register)));} end; end; procedure secondnothing(var p : ptree); begin end; procedure secondderef(var p : ptree); var hr : tregister; begin secondpass(p^.left); clear_reference(p^.location.reference); case p^.left^.location.loc of LOC_REGISTER: p^.location.reference.base:=p^.left^.location.register; LOC_CREGISTER: begin { ... and reserve one for the pointer } hr:=getregister32; emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); p^.location.reference.base:=hr; end; else begin { free register } del_reference(p^.left^.location.reference); { ...and reserve one for the pointer } hr:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg( A_MOV,S_L,newreference(p^.left^.location.reference), hr))); p^.location.reference.base:=hr; end; end; end; procedure secondvecn(var p : ptree); var pushed : boolean; ind,hr : tregister; _p : ptree; function get_mul_size:longint; begin if p^.memindex then get_mul_size:=1 else get_mul_size:=p^.resulttype^.size; end; procedure calc_emit_mul; var l1,l2 : longint; begin l1:=get_mul_size; case l1 of 1,2,4,8 : p^.location.reference.scalefactor:=l1; else begin if ispowerof2(l1,l2) then exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,l2,ind))) else exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,l1,ind))); end; end; end; var extraoffset : longint; t : ptree; hp : preference; tai:Pai386; begin secondpass(p^.left); set_location(p^.location,p^.left^.location); { offset can only differ from 0 if arraydef } if p^.left^.resulttype^.deftype=arraydef then dec(p^.location.reference.offset, get_mul_size*parraydef(p^.left^.resulttype)^.lowrange); if p^.right^.treetype=ordconstn then begin { offset can only differ from 0 if arraydef } if (p^.left^.resulttype^.deftype=arraydef) then begin if not(is_open_array(p^.left^.resulttype)) then begin if (p^.right^.value>parraydef(p^.left^.resulttype)^.highrange) or (p^.right^.valueLOC_REFERENCE) and (p^.location.loc<>LOC_MEM) then Message(cg_e_illegal_expression); pushed:=maybe_push(p^.right^.registers32,p); secondpass(p^.right); if pushed then restore(p); case p^.right^.location.loc of LOC_REGISTER: begin ind:=p^.right^.location.register; case p^.right^.resulttype^.size of 1: begin hr:=reg8toreg32(ind); emit_reg_reg(A_MOVZX,S_BL,ind,hr); ind:=hr; end; 2: begin hr:=reg16toreg32(ind); emit_reg_reg(A_MOVZX,S_WL,ind,hr); ind:=hr; end; end; end; LOC_CREGISTER: begin ind:=getregister32; case p^.right^.resulttype^.size of 1: emit_reg_reg(A_MOVZX,S_BL,p^.right^.location.register,ind); 2: emit_reg_reg(A_MOVZX,S_WL,p^.right^.location.register,ind); 4: emit_reg_reg(A_MOV,S_L,p^.right^.location.register,ind); end; end; LOC_FLAGS: begin ind:=getregister32; exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_NO,reg32toreg8(ind)))); emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind); end else begin del_reference(p^.right^.location.reference); ind:=getregister32; { Booleans are stored in an 8 bit memory location, so the use of MOVL is not correct } case p^.right^.resulttype^.size of 1: tai:=new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.right^.location.reference),ind)); 2: tai:=new(Pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.right^.location.reference),ind)); 4: tai:=new(Pai386,op_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),ind)); end; exprasmlist^.concat(tai); end; end; { produce possible range check code: } if cs_rangechecking in aktswitches then begin if p^.left^.resulttype^.deftype=arraydef then begin new(hp); reset_reference(hp^); parraydef(p^.left^.resulttype)^.genrangecheck; hp^.symbol:=stringdup('R_'+tostr(parraydef(p^.left^.resulttype)^.rangenr)); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,ind,hp))); end; end; if p^.location.reference.index=R_NO then begin p^.location.reference.index:=ind; calc_emit_mul; end else begin if p^.location.reference.base=R_NO then begin case p^.location.reference.scalefactor of 2 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,1,p^.location.reference.index))); 4 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,2,p^.location.reference.index))); 8 : exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,3,p^.location.reference.index))); end; calc_emit_mul; p^.location.reference.base:=p^.location.reference.index; p^.location.reference.index:=ind; end else begin exprasmlist^.concat(new(pai386,op_ref_reg( A_LEA,S_L,newreference(p^.location.reference), p^.location.reference.index))); ungetregister32(p^.location.reference.base); { the symbol offset is loaded, } { so release the symbol name and set symbol } { to nil } stringdispose(p^.location.reference.symbol); p^.location.reference.offset:=0; calc_emit_mul; p^.location.reference.base:=p^.location.reference.index; p^.location.reference.index:=ind; end; end; if p^.memseg then p^.location.reference.segment:=R_FS; end; end; { *************** Converting Types **************** } { produces if necessary rangecheckcode } procedure maybe_rangechecking(p : ptree;p2,p1 : pdef); var hp : preference; hregister : tregister; neglabel,poslabel : plabel; is_register : boolean; begin { convert from p2 to p1 } { range check from enums is not made yet !!} { and its probably not easy } if (p1^.deftype<>orddef) or (p2^.deftype<>orddef) then exit; { range checking is different for u32bit } { lets try to generate it allways } if (cs_rangechecking in aktswitches) and { with $R+ explicit type conversations in TP aren't range checked! } (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and ((porddef(p1)^.von>porddef(p2)^.von) or (porddef(p1)^.bisporddef(p1)^.bis then begin getlabel(neglabel); getlabel(poslabel); exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,hregister,hregister))); emitl(A_JL,neglabel); end; exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp))); if porddef(p1)^.von>porddef(p1)^.bis then begin new(hp); reset_reference(hp^); hp^.symbol:=stringdup('R_'+tostr(porddef(p1)^.rangenr+1)); emitl(A_JMP,poslabel); emitl(A_LABEL,neglabel); exprasmlist^.concat(new(pai386,op_reg_ref(A_BOUND,S_L,hregister,hp))); emitl(A_LABEL,poslabel); end; end; end; type tsecondconvproc = procedure(p,hp : ptree;convtyp : tconverttype); procedure second_nothing(p,hp : ptree;convtyp : tconverttype); begin end; procedure second_only_rangecheck(p,hp : ptree;convtyp : tconverttype); begin maybe_rangechecking(p,hp^.resulttype,p^.resulttype); end; procedure second_bigger(p,hp : ptree;convtyp : tconverttype); 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 begin del_reference(p^.left^.location.reference); { we can do this here as we need no temp inside second_bigger } ungetiftemp(p^.left^.location.reference); end; { this is wrong !!! gives me movl (%eax),%eax for the length(string !!! use only for constant values } {Constanst cannot be loaded into registers using MOVZX!} if (p^.left^.location.loc<>LOC_MEM) or (not p^.left^.location.reference.isintvalue) then case convtyp of tc_u8bit_2_s32bit,tc_u8bit_2_u32bit : begin if is_register then hregister:=reg8toreg32(p^.left^.location.register) else hregister:=getregister32; op:=A_MOVZX; opsize:=S_BL; end; { here what do we do for negative values ? } tc_s8bit_2_s32bit,tc_s8bit_2_u32bit : begin if is_register then hregister:=reg8toreg32(p^.left^.location.register) else hregister:=getregister32; op:=A_MOVSX; opsize:=S_BL; end; tc_u16bit_2_s32bit,tc_u16bit_2_u32bit : begin if is_register then hregister:=reg16toreg32(p^.left^.location.register) else hregister:=getregister32; op:=A_MOVZX; opsize:=S_WL; end; tc_s16bit_2_s32bit,tc_s16bit_2_u32bit : begin if is_register then hregister:=reg16toreg32(p^.left^.location.register) else hregister:=getregister32; op:=A_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:=A_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:=A_MOVSX; opsize:=S_BW; end; end else case convtyp of tc_u8bit_2_s32bit, tc_s8bit_2_s32bit, tc_u16bit_2_s32bit, tc_s16bit_2_s32bit, tc_u8bit_2_u32bit, tc_s8bit_2_u32bit, tc_u16bit_2_u32bit, tc_s16bit_2_u32bit: begin hregister:=getregister32; op:=A_MOV; opsize:=S_L; end; tc_s8bit_2_u16bit, tc_s8bit_2_s16bit, tc_u8bit_2_s16bit, tc_u8bit_2_u16bit: begin hregister:=reg32toreg16(getregister32); op:=A_MOV; opsize:=S_W; 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 exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize, newreference(p^.left^.location.reference),hregister))); end; p^.location.loc:=LOC_REGISTER; p^.location.register:=hregister; maybe_rangechecking(p,p^.left^.resulttype,p^.resulttype); end; procedure second_string_string(p,hp : ptree;convtyp : tconverttype); var pushedregs : tpushed; begin stringdispose(p^.location.reference.symbol); gettempofsizereference(p^.resulttype^.size,p^.location.reference); del_reference(p^.left^.location.reference); copystring(p^.location.reference,p^.left^.location.reference,pstringdef(p^.resulttype)^.len); ungetiftemp(p^.left^.location.reference); end; procedure second_cstring_charpointer(p,hp : ptree;convtyp : tconverttype); begin p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; inc(p^.left^.location.reference.offset); exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), p^.location.register))); end; procedure second_string_chararray(p,hp : ptree;convtyp : tconverttype); begin inc(p^.location.reference.offset); end; procedure second_array_to_pointer(p,hp : ptree;convtyp : tconverttype); begin del_reference(p^.left^.location.reference); p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(p^.left^.location.reference), p^.location.register))); end; procedure second_pointer_to_array(p,hp : ptree;convtyp : tconverttype); begin p^.location.loc:=LOC_REFERENCE; clear_reference(p^.location.reference); if p^.left^.location.loc=LOC_REGISTER then p^.location.reference.base:=p^.left^.location.register else begin if p^.left^.location.loc=LOC_CREGISTER then begin p^.location.reference.base:=getregister32; emit_reg_reg(A_MOV,S_L,p^.left^.location.register, p^.location.reference.base); end else begin del_reference(p^.left^.location.reference); p^.location.reference.base:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), p^.location.reference.base))); end; end; end; { generates the code for the type conversion from an array of char } { to a string } procedure second_chararray_to_string(p,hp : ptree;convtyp : tconverttype); var l : longint; begin { this is a type conversion which copies the data, so we can't } { return a reference } p^.location.loc:=LOC_MEM; { first get the memory for the string } stringdispose(p^.location.reference.symbol); gettempofsizereference(256,p^.location.reference); { calc the length of the array } l:=parraydef(p^.left^.resulttype)^.highrange- parraydef(p^.left^.resulttype)^.lowrange+1; if l>255 then Message(sym_e_type_mismatch); { write the length } exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,l, newreference(p^.location.reference)))); { copy to first char of string } inc(p^.location.reference.offset); { generates the copy code } { and we need the source never } concatcopy(p^.left^.location.reference,p^.location.reference,l,true); { correct the string location } dec(p^.location.reference.offset); end; procedure second_char_to_string(p,hp : ptree;convtyp : tconverttype); begin stringdispose(p^.location.reference.symbol); gettempofsizereference(256,p^.location.reference); { call loadstring with correct left and right } p^.right:=p^.left; p^.left:=p; loadstring(p); p^.left:=nil; { reset left tree, which is empty } end; procedure second_int_real(p,hp : ptree;convtyp : tconverttype); var r : preference; begin if (p^.left^.location.loc=LOC_REGISTER) or (p^.left^.location.loc=LOC_CREGISTER) then begin case porddef(p^.left^.resulttype)^.typ of s8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_BL,p^.left^.location.register,R_EDI))); u8bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,p^.left^.location.register,R_EDI))); s16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVSX,S_WL,p^.left^.location.register,R_EDI))); u16bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,p^.left^.location.register,R_EDI))); u32bit,s32bit : exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,p^.left^.location.register,R_EDI))); {!!!! u32bit } end; ungetregister(p^.left^.location.register); end else begin r:=newreference(p^.left^.location.reference); case porddef(p^.left^.resulttype)^.typ of s8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,r,R_EDI))); u8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,r,R_EDI))); s16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,r,R_EDI))); u16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,r,R_EDI))); u32bit,s32bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); {!!!! u32bit } end; del_reference(p^.left^.location.reference); ungetiftemp(p^.left^.location.reference); end; if porddef(p^.left^.resulttype)^.typ=u32bit then push_int(0); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDI))); new(r); reset_reference(r^); r^.base:=R_ESP; { for u32bit a solution would be to push $0 and to load a comp } if porddef(p^.left^.resulttype)^.typ=u32bit then exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_Q,r))) else exprasmlist^.concat(new(pai386,op_ref(A_FILD,S_L,r))); { better than an add on all processors } if porddef(p^.left^.resulttype)^.typ=u32bit then exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,8,R_ESP))) else exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); p^.location.loc:=LOC_FPU; end; procedure second_real_fix(p,hp : ptree;convtyp : tconverttype); var {hs : string;} rreg : tregister; ref : treference; begin { real must be on fpu stack } if (p^.left^.location.loc<>LOC_FPU) then exprasmlist^.concat(new(pai386,op_ref(A_FLD,S_L,newreference(p^.left^.location.reference)))); push_int($1f3f); push_int(65536); reset_reference(ref); ref.base:=R_ESP; exprasmlist^.concat(new(pai386,op_ref(A_FIMUL,S_L,newreference(ref)))); ref.offset:=4; exprasmlist^.concat(new(pai386,op_ref(A_FSTCW,S_L,newreference(ref)))); ref.offset:=6; exprasmlist^.concat(new(pai386,op_ref(A_FLDCW,S_L,newreference(ref)))); ref.offset:=0; exprasmlist^.concat(new(pai386,op_ref(A_FISTP,S_L,newreference(ref)))); ref.offset:=4; exprasmlist^.concat(new(pai386,op_ref(A_FLDCW,S_L,newreference(ref)))); rreg:=getregister32; exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,rreg))); { better than an add on all processors } exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); p^.location.loc:=LOC_REGISTER; p^.location.register:=rreg; end; procedure second_float_float(p,hp : ptree;convtyp : tconverttype); begin case p^.left^.location.loc of LOC_FPU : ; LOC_MEM, LOC_REFERENCE: begin floatload(pfloatdef(p^.left^.resulttype)^.typ, p^.left^.location.reference); { we have to free the reference } del_reference(p^.left^.location.reference); end; end; p^.location.loc:=LOC_FPU; end; procedure second_fix_real(p,hp : ptree;convtyp : tconverttype); var popeax,popebx,popecx,popedx : boolean; startreg : tregister; hl : plabel; r : treference; begin if (p^.left^.location.loc=LOC_REGISTER) or (p^.left^.location.loc=LOC_CREGISTER) then begin startreg:=p^.left^.location.register; ungetregister(startreg); popeax:=(startreg<>R_EAX) and not (R_EAX in unused); if popeax then exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); { mov eax,eax is removed by emit_reg_reg } emit_reg_reg(A_MOV,S_L,startreg,R_EAX); end else begin exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference( p^.left^.location.reference),R_EAX))); del_reference(p^.left^.location.reference); startreg:=R_NO; end; popebx:=(startreg<>R_EBX) and not (R_EBX in unused); if popebx then exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBX))); popecx:=(startreg<>R_ECX) and not (R_ECX in unused); if popecx then exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ECX))); popedx:=(startreg<>R_EDX) and not (R_EDX in unused); if popedx then exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EDX))); exprasmlist^.concat(new(pai386,op_none(A_CDQ,S_NO))); emit_reg_reg(A_XOR,S_L,R_EDX,R_EAX); emit_reg_reg(A_MOV,S_L,R_EAX,R_EBX); emit_reg_reg(A_SUB,S_L,R_EDX,R_EAX); getlabel(hl); emitl(A_JZ,hl); exprasmlist^.concat(new(pai386,op_const_reg(A_RCL,S_L,1,R_EBX))); emit_reg_reg(A_BSR,S_L,R_EAX,R_EDX); exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,32,R_CL))); emit_reg_reg(A_SUB,S_B,R_DL,R_CL); emit_reg_reg(A_SHL,S_L,R_CL,R_EAX); exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_W,1007,R_DX))); exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_W,5,R_DX))); exprasmlist^.concat(new(pai386,op_const_reg_reg(A_SHLD,S_W,11,R_DX,R_BX))); exprasmlist^.concat(new(pai386,op_const_reg_reg(A_SHLD,S_W,20,R_EAX,R_EBX))); exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,20,R_EAX))); emitl(A_LABEL,hl); { better than an add on all processors } exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBX))); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EAX))); reset_reference(r); r.base:=R_ESP; exprasmlist^.concat(new(pai386,op_ref(A_FLD,S_L,newreference(r)))); exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,8,R_ESP))); if popedx then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDX))); if popecx then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ECX))); if popebx then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EBX))); if popeax then exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EAX))); p^.location.loc:=LOC_FPU; end; procedure second_int_fix(p,hp : ptree;convtyp : tconverttype); var {hs : string;} hregister : tregister; begin if (p^.left^.location.loc=LOC_REGISTER) then hregister:=p^.left^.location.register else if (p^.left^.location.loc=LOC_CREGISTER) then hregister:=getregister32 else begin del_reference(p^.left^.location.reference); hregister:=getregister32; case porddef(p^.left^.resulttype)^.typ of s8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_BL,newreference(p^.left^.location.reference), hregister))); u8bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL,newreference(p^.left^.location.reference), hregister))); s16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVSX,S_WL,newreference(p^.left^.location.reference), hregister))); u16bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_WL,newreference(p^.left^.location.reference), hregister))); u32bit,s32bit : exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), hregister))); {!!!! u32bit } end; end; exprasmlist^.concat(new(pai386,op_const_reg(A_SHL,S_L,16,hregister))); p^.location.loc:=LOC_REGISTER; p^.location.register:=hregister; end; procedure second_smaller(p,hp : ptree;convtyp : tconverttype); var hregister,destregister : tregister; ref : boolean; hpp : preference; begin ref:=false; { problems with enums !! } if (cs_rangechecking in aktswitches) and { with $R+ explicit type conversations in TP aren't range checked! } (not(p^.explizit) or not(cs_tp_compatible in aktswitches)) and (p^.resulttype^.deftype=orddef) and (hp^.resulttype^.deftype=orddef) and ((porddef(p^.resulttype)^.von>porddef(hp^.resulttype)^.von) or (porddef(p^.resulttype)^.bistc_bool_2_u8bit then begin secondpass(p^.left); set_location(p^.location,p^.left^.location); end; if p^.convtyp<>tc_equal then {the second argument only is for maybe_range_checking !} secondconvert[p^.convtyp](p,p^.left,p^.convtyp) end; procedure secondassignment(var p : ptree); var opsize : topsize; {pushed,}withresult : boolean; otlabel,hlabel,oflabel : plabel; hregister : tregister; loc : tloc; begin otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); withresult:=false; { calculate left sides } secondpass(p^.left); case p^.left^.location.loc of LOC_REFERENCE : begin { in case left operator uses to register } { but to few are free then LEA } if (p^.left^.location.reference.base<>R_NO) and (p^.left^.location.reference.index<>R_NO) and (usablereg32LOC_REFERENCE then internalerror(10010) else floatstore(pfloatdef(p^.left^.resulttype)^.typ, p^.left^.location.reference); end; LOC_JUMP : begin getlabel(hlabel); emitl(A_LABEL,truelabel); if loc=LOC_CREGISTER then exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B, 1,p^.left^.location.register))) else exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, 1,newreference(p^.left^.location.reference)))); {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B, 1,p^.left^.location)));} emitl(A_JMP,hlabel); emitl(A_LABEL,falselabel); if loc=LOC_CREGISTER then exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B, p^.left^.location.register, p^.left^.location.register))) else exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B, 0,newreference(p^.left^.location.reference)))); emitl(A_LABEL,hlabel); end; LOC_FLAGS : begin if loc=LOC_CREGISTER then exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_NO, p^.left^.location.register))) else exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_NO, newreference(p^.left^.location.reference)))); end; end; truelabel:=otlabel; falselabel:=oflabel; end; { save the size of pushed parameter } var pushedparasize : longint; procedure secondcallparan(var p : ptree;defcoll : pdefcoll; push_from_left_to_right : boolean); var size : longint; stackref : treference; otlabel,hlabel,oflabel : plabel; { temporary variables: } tempdeftype : tdeftype; tempreference : treference; r : preference; s : topsize; op : tasmop; begin { push from left to right if specified } if push_from_left_to_right and assigned(p^.right) then secondcallparan(p^.right,defcoll^.next,push_from_left_to_right); otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(p^.left); { in codegen.handleread.. defcoll^.data is set to nil } if assigned(defcoll^.data) and (defcoll^.data^.deftype=formaldef) then begin { allow @var } if p^.left^.treetype=addrn then begin { allways a register } exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,p^.left^.location.register))); ungetregister32(p^.left^.location.register); end else begin if (p^.left^.location.loc<>LOC_REFERENCE) and (p^.left^.location.loc<>LOC_MEM) then Message(sym_e_type_mismatch) else begin emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); end; end; inc(pushedparasize,4); end { handle call by reference parameter } else if (defcoll^.paratyp=vs_var) then begin if (p^.left^.location.loc<>LOC_REFERENCE) then Message(cg_e_var_must_be_reference); { open array ? } { defcoll^.data can be nil for read/write } if assigned(defcoll^.data) and is_open_array(defcoll^.data) then begin { push high } if is_open_array(p^.left^.resulttype) then begin new(r); reset_reference(r^); r^.base:=highframepointer; r^.offset:=highoffset+4; exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r))); end else push_int(parraydef(p^.left^.resulttype)^.highrange- parraydef(p^.left^.resulttype)^.lowrange); inc(pushedparasize,4); end; emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); inc(pushedparasize,4); end else begin tempdeftype:=p^.resulttype^.deftype; if tempdeftype=filedef then Message(cg_e_file_must_call_by_reference); if (defcoll^.paratyp=vs_const) and dont_copy_const_param(p^.resulttype) then begin emitpushreferenceaddr(p^.left^.location.reference); del_reference(p^.left^.location.reference); 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 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,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 exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,p^.left^.location.register))); inc(pushedparasize,2); ungetregister32(reg16toreg32(p^.left^.location.register)); end; R_AL,R_BL,R_CL,R_DL: begin { we must push always 16 bit } exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W, reg8toreg16(p^.left^.location.register)))); inc(pushedparasize,2); ungetregister32(reg8toreg32(p^.left^.location.register)); end; end; end; LOC_FPU : begin size:=pfloatdef(p^.left^.resulttype)^.size; inc(pushedparasize,size); exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP))); new(r); reset_reference(r^); r^.base:=R_ESP; floatstoreops(pfloatdef(p^.left^.resulttype)^.typ,op,s); exprasmlist^.concat(new(pai386,op_ref(op,s,r))); end; LOC_REFERENCE,LOC_MEM : begin tempreference:=p^.left^.location.reference; del_reference(p^.left^.location.reference); case p^.resulttype^.deftype of orddef : begin case porddef(p^.resulttype)^.typ of s32bit,u32bit : begin emit_push_mem(tempreference); inc(pushedparasize,4); end; s8bit,u8bit,uchar,bool8bit,s16bit,u16bit : begin exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W, newreference(tempreference)))); inc(pushedparasize,2); end; end; end; floatdef : begin case pfloatdef(p^.resulttype)^.typ of f32bit, s32real : begin emit_push_mem(tempreference); inc(pushedparasize,4); end; s64real, s64bit : begin inc(tempreference.offset,4); emit_push_mem(tempreference); dec(tempreference.offset,4); emit_push_mem(tempreference); inc(pushedparasize,8); end; s80real : begin inc(tempreference.offset,6); emit_push_mem(tempreference); dec(tempreference.offset,4); emit_push_mem(tempreference); dec(tempreference.offset,2); exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W, newreference(tempreference)))); inc(pushedparasize,extended_size); end; end; end; pointerdef,procvardef, enumdef,classrefdef: begin emit_push_mem(tempreference); inc(pushedparasize,4); end; arraydef,recorddef,stringdef,setdef,objectdef : begin if ((p^.resulttype^.deftype=setdef) and (psetdef(p^.resulttype)^.settype=smallset)) then begin emit_push_mem(tempreference); inc(pushedparasize,4); end else 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; } { create stack space } exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,S_L,size,R_ESP))); inc(pushedparasize,size); { create stack reference } stackref.symbol := nil; clear_reference(stackref); stackref.base:=R_ESP; { produce copy } if p^.resulttype^.deftype=stringdef then begin copystring(stackref,p^.left^.location.reference, pstringdef(p^.resulttype)^.len); end else begin concatcopy(p^.left^.location.reference, stackref,p^.resulttype^.size,true); end; end; end; else Message(cg_e_illegal_expression); end; end; LOC_JUMP: begin getlabel(hlabel); inc(pushedparasize,2); emitl(A_LABEL,truelabel); exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,1))); emitl(A_JMP,hlabel); emitl(A_LABEL,falselabel); exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,0))); emitl(A_LABEL,hlabel); end; LOC_FLAGS: begin if not(R_EAX in unused) then exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI))); { clear full EAX is faster } { but dont you set the equal flag ? } {exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_EAX,R_EAX)));} exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.left^.location.resflags],S_NO, R_AL))); exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BW,R_AL,R_AX))); {exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_EAX,R_EAX)));} inc(pushedparasize,2); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,R_AX))); { this is also false !!! if not(R_EAX in unused) then exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EAX,R_EDI)));} if not(R_EAX in unused) then exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,R_EDI,R_EAX))); end; {$ifdef SUPPORT_MMX} LOC_MMXREGISTER, LOC_CMMXREGISTER: begin exprasmlist^.concat(new(pai386,op_const_reg( A_SUB,S_L,8,R_ESP))); new(r); reset_reference(r^); r^.base:=R_ESP; exprasmlist^.concat(new(pai386,op_reg_ref( A_MOVQ,S_NO,p^.left^.location.register,r))); end; {$endif SUPPORT_MMX} end; end; truelabel:=otlabel; falselabel:=oflabel; { push from right to left } if not push_from_left_to_right and assigned(p^.right) then secondcallparan(p^.right,defcoll^.next,push_from_left_to_right); end; procedure secondcalln(var p : ptree); var unusedregisters : tregisterset; pushed : tpushed; funcretref : treference; hregister : tregister; oldpushedparasize : longint; { true if ESI must be loaded again after the subroutine } loadesi : boolean; { true if a virtual method must be called directly } no_virtual_call : boolean; { true if we produce a con- or destrutor in a call } is_con_or_destructor : boolean; { true if a constructor is called again } extended_new : boolean; { adress returned from an I/O-error } iolabel : plabel; { lexlevel count } i : longint; { help reference pointer } r : preference; pp,params : ptree; { instruction for alignement correction } corr : pai386; { we must pop this size also after !! } must_pop : boolean; pop_size : longint; label dont_call; begin extended_new:=false; iolabel:=nil; loadesi:=true; no_virtual_call:=false; unusedregisters:=unused; if not assigned(p^.procdefinition) then exit; { 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 getlabel(iolabel); emitl(A_LABEL,iolabel); end else iolabel:=nil; { save all used registers } pushusedregisters(pushed,p^.procdefinition^.usedregisters); { give used registers through } usedinproc:=usedinproc or p^.procdefinition^.usedregisters; end else begin pushusedregisters(pushed,$ff); usedinproc:=$ff; { no IO check for methods and procedure variables } iolabel:=nil; end; { generate the code for the parameter and push them } oldpushedparasize:=pushedparasize; pushedparasize:=0; corr:=new(pai386,op_const_reg(A_SUB,S_L,0,R_ESP)); exprasmlist^.concat(corr); if (p^.resulttype<>pdef(voiddef)) and ret_in_param(p^.resulttype) then begin funcretref.symbol:=nil; {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) and (dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then begin funcretref:=dest_loc.reference; if assigned(dest_loc.reference.symbol) then funcretref.symbol:=stringdup(dest_loc.reference.symbol^); in_dest_loc:=true; end else {$endif test_dest_loc} gettempofsizereference(p^.procdefinition^.retdef^.size,funcretref); end; if assigned(p^.left) then begin pushedparasize:=0; { be found elsewhere } if assigned(p^.right) then secondcallparan(p^.left,pprocvardef(p^.right^.resulttype)^.para1, (p^.procdefinition^.options and poleftright)<>0) else secondcallparan(p^.left,p^.procdefinition^.para1, (p^.procdefinition^.options and poleftright)<>0); end; params:=p^.left; p^.left:=nil; if ret_in_param(p^.resulttype) then begin emitpushreferenceaddr(funcretref); inc(pushedparasize,4); end; { overloaded operator have no symtable } if (p^.right=nil) then begin { push self } if assigned(p^.symtable) and (p^.symtable^.symtabletype=withsymtable) then begin { dirty trick to avoid the secondcall below } p^.methodpointer:=genzeronode(callparan); p^.methodpointer^.location.loc:=LOC_REGISTER; p^.methodpointer^.location.register:=R_ESI; { make a reference } new(r); reset_reference(r^); r^.offset:=p^.symtable^.datasize; r^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); end; { push self } if assigned(p^.symtable) and ((p^.symtable^.symtabletype=objectsymtable) or (p^.symtable^.symtabletype=withsymtable)) then begin if assigned(p^.methodpointer) then begin { if p^.methodpointer^.resulttype=classrefdef then begin two possibilities: 1. constructor 2. class method end else } begin case p^.methodpointer^.treetype of typen: begin { direct call to inherited method } if (p^.procdefinition^.options and poabstractmethod)<>0 then begin error(cg_e_cant_call_abstract_method); goto dont_call; end; { generate no virtual call } no_virtual_call:=true; if (p^.symtableprocentry^.properties and sp_static)<>0 then begin { well lets put the VMT address directly into ESI } { it is kind of dirty but that is the simplest } { way to accept virtual static functions (PM) } loadesi:=true; exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV,S_L, newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0),R_ESI))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); end else { this is a member call, so ESI isn't modfied } loadesi:=false; if not(is_con_or_destructor and pobjectdef(p^.methodpointer^.resulttype)^.isclass and assigned(aktprocsym) and ((aktprocsym^.definition^.options and (poconstructor or podestructor))<>0)) then exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); { if an inherited con- or destructor should be } { called in a con- or destructor then a warning } { will be made } { con- and destructors need a pointer to the vmt } if is_con_or_destructor and not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) and assigned(aktprocsym) then begin if not ((aktprocsym^.definition^.options and (poconstructor or podestructor))<>0) then Message(cg_w_member_cd_call_from_method); end; if is_con_or_destructor then push_int(0) end; hnewn: begin { extended syntax of new } { ESI must be zero } exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI))); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); { insert the vmt } exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L, newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR); extended_new:=true; end; hdisposen: begin secondpass(p^.methodpointer); { destructor with extended syntax called from dispose } { hdisposen always deliver LOC_REFERENCE } exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, newreference(p^.methodpointer^.location.reference),R_ESI))); del_reference(p^.methodpointer^.location.reference); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L, newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,0)))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname,EXT_NEAR); end; else begin { call to an instance member } if (p^.symtable^.symtabletype<>withsymtable) then begin secondpass(p^.methodpointer); case p^.methodpointer^.location.loc of LOC_REGISTER: begin ungetregister32(p^.methodpointer^.location.register); emit_reg_reg(A_MOV,S_L,p^.methodpointer^.location.register,R_ESI); end; else begin if (p^.methodpointer^.resulttype^.deftype=objectdef) and pobjectdef(p^.methodpointer^.resulttype)^.isclass then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.methodpointer^.location.reference),R_ESI))) else exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, newreference(p^.methodpointer^.location.reference),R_ESI))); del_reference(p^.methodpointer^.location.reference); end; end; end; { when calling a class method, we have to load ESI with the VMT ! But that's wrong, if we call a class method via self } if ((p^.procdefinition^.options and poclassmethod)<>0) and not(p^.methodpointer^.treetype=selfn) then begin { class method needs current VMT } new(r); reset_reference(r^); r^.base:=R_ESI; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); end; exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); if is_con_or_destructor then begin { classes don't get a VMT pointer pushed } if (p^.methodpointer^.resulttype^.deftype=objectdef) and not(pobjectdef(p^.methodpointer^.resulttype)^.isclass) then begin if ((p^.procdefinition^.options and poconstructor)<>0) then begin { it's no bad idea, to insert the VMT } exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L, newcsymbol(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname, 0)))); concat_external(pobjectdef(p^.methodpointer^.resulttype)^.vmt_mangledname, EXT_NEAR); end { destructors haven't to dispose the instance, if this is } { a direct call } else push_int(0); end; end; end; end; end; end else begin if ((p^.procdefinition^.options and poclassmethod)<>0) and not( assigned(aktprocsym) and ((aktprocsym^.definition^.options and poclassmethod)<>0) ) then begin { class method needs current VMT } new(r); reset_reference(r^); r^.base:=R_ESI; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_ESI))); end else begin { member call, ESI isn't modified } loadesi:=false; end; exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); { but a con- or destructor here would probably almost } { always be placed wrong } if is_con_or_destructor then begin Message(cg_w_member_cd_call_from_method); push_int(0); end; end; end; { push base pointer ?} if (lexlevel>1) and assigned(pprocdef(p^.procdefinition)^.parast) and ((p^.procdefinition^.parast^.symtablelevel)>2) then begin { if we call a nested function in a method, we must } { push also SELF! } { THAT'S NOT TRUE, we have to load ESI via frame pointer } { access } { begin loadesi:=false; exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_ESI))); end; } if lexlevel=(p^.procdefinition^.parast^.symtablelevel) then begin new(r); reset_reference(r^); r^.offset:=procinfo.framepointer_offset; r^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_L,r))) end { this is only true if the difference is one !! but it cannot be more !! } else if (lexlevel=p^.procdefinition^.parast^.symtablelevel-1) then begin exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,procinfo.framepointer))) end else if (lexlevel>p^.procdefinition^.parast^.symtablelevel) then begin hregister:=getregister32; new(r); reset_reference(r^); r^.offset:=procinfo.framepointer_offset; r^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); for i:=(p^.procdefinition^.parast^.symtablelevel) to lexlevel-1 do begin new(r); reset_reference(r^); {we should get the correct frame_pointer_offset at each level how can we do this !!! } r^.offset:=procinfo.framepointer_offset; r^.base:=hregister; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,hregister))); end; exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,hregister))); ungetregister32(hregister); end else internalerror(25000); end; { exported methods should be never called direct } if (p^.procdefinition^.options and poexports)<>0 then Message(cg_e_dont_call_exported_direct); if (pushedparasize mod 4)<>0 then begin corr^.op1:=pointer(4-(pushedparasize mod 4)); must_pop:=true; pop_size:=4-(pushedparasize mod 4); end else begin exprasmlist^.remove(corr); must_pop:=false; pop_size:=0; end; if ((p^.procdefinition^.options and povirtualmethod)<>0) and not(no_virtual_call) then begin { static functions contain the vmt_address in ESI } { also class methods } if assigned(aktprocsym) then begin if ((aktprocsym^.properties and sp_static)<>0) or ((aktprocsym^.definition^.options and poclassmethod)<>0) or ((p^.procdefinition^.options and postaticmethod)<>0) or { ESI is loaded earlier } ((p^.procdefinition^.options and poclassmethod)<>0)then begin new(r); reset_reference(r^); r^.base:=R_ESI; end else begin new(r); reset_reference(r^); r^.base:=R_ESI; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); new(r); reset_reference(r^); r^.base:=R_EDI; end; end else begin new(r); reset_reference(r^); r^.base:=R_ESI; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,R_EDI))); new(r); reset_reference(r^); r^.base:=R_EDI; end; if p^.procdefinition^.extnumber=-1 then internalerror($Da); r^.offset:=p^.procdefinition^.extnumber*4+12; if (cs_rangechecking in aktswitches) then begin exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,r^.base))); emitcall('CHECK_OBJECT',true); end; exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,r))); end else emitcall(p^.procdefinition^.mangledname, p^.symtableproc^.symtabletype=unitsymtable); if ((p^.procdefinition^.options and poclearstack)<>0) then begin { consider the alignment with the rest (PM) } pushedparasize:=pushedparasize+pop_size; must_pop:=false; if pushedparasize=4 then { better than an add on all processors } exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))) { the pentium has two pipes and pop reg is pairable } { but the registers must be different! } else if (pushedparasize=8) and not(cs_littlesize in aktswitches) and (opt_processors=pentium) and (procinfo._class=nil) then begin exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_EDI))); exprasmlist^.concat(new(pai386,op_reg(A_POP,S_L,R_ESI))); end else exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pushedparasize,R_ESP))); end; end else begin if (pushedparasize mod 4)<>0 then begin corr^.op1:=pointer(4-(pushedparasize mod 4)); must_pop:=true; pop_size:=4-(pushedparasize mod 4); end else begin exprasmlist^.remove(corr); must_pop:=false; pop_size:=0; end; secondpass(p^.right); case p^.right^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin exprasmlist^.concat(new(pai386,op_reg(A_CALL,S_NO,p^.right^.location.register))); ungetregister32(p^.right^.location.register); end else exprasmlist^.concat(new(pai386,op_ref(A_CALL,S_NO,newreference(p^.right^.location.reference)))); del_reference(p^.right^.location.reference); end; end; dont_call: pushedparasize:=oldpushedparasize; unused:=unusedregisters; { handle function results } if p^.resulttype<>pdef(voiddef) then begin { a contructor could be a function with boolean result } if (p^.right=nil) and ((p^.procdefinition^.options and poconstructor)<>0) and { quick'n'dirty check if it is a class or an object } (p^.resulttype^.deftype=orddef) then begin p^.location.loc:=LOC_FLAGS; p^.location.resflags:=F_NE; if extended_new then begin {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) then mov_reg_to_dest(p,S_L,R_EAX) else {$endif test_dest_loc} begin hregister:=getregister32; emit_reg_reg(A_MOV,S_L,R_EAX,hregister); p^.location.register:=hregister; end; end; end { structed results are easy to handle.... } else if ret_in_param(p^.resulttype) then begin p^.location.loc:=LOC_MEM; stringdispose(p^.location.reference.symbol); p^.location.reference:=funcretref; end else begin if (p^.resulttype^.deftype=orddef) then begin p^.location.loc:=LOC_REGISTER; case porddef(p^.resulttype)^.typ of s32bit,u32bit : begin {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) then mov_reg_to_dest(p,S_L,R_EAX) else {$endif test_dest_loc} begin hregister:=getregister32; emit_reg_reg(A_MOV,S_L,R_EAX,hregister); p^.location.register:=hregister; end; end; uchar,u8bit,bool8bit,s8bit : begin {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) then mov_reg_to_dest(p,S_B,R_AL) else {$endif test_dest_loc} begin hregister:=getregister32; emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister)); p^.location.register:=reg32toreg8(hregister); end; end; s16bit,u16bit : begin {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) then mov_reg_to_dest(p,S_W,R_AX) else {$endif test_dest_loc} begin hregister:=getregister32; emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister)); p^.location.register:=reg32toreg16(hregister); end; end; else internalerror(7); end end else if (p^.resulttype^.deftype=floatdef) then case pfloatdef(p^.resulttype)^.typ of f32bit : begin p^.location.loc:=LOC_REGISTER; {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) then mov_reg_to_dest(p,S_L,R_EAX) else {$endif test_dest_loc} begin hregister:=getregister32; emit_reg_reg(A_MOV,S_L,R_EAX,hregister); p^.location.register:=hregister; end; end; else p^.location.loc:=LOC_FPU; end else begin p^.location.loc:=LOC_REGISTER; {$ifdef test_dest_loc} if dest_loc_known and (dest_loc_tree=p) then mov_reg_to_dest(p,S_L,R_EAX) else {$endif test_dest_loc} begin hregister:=getregister32; emit_reg_reg(A_MOV,S_L,R_EAX,hregister); p^.location.register:=hregister; end; end; end; end; { perhaps i/o check ? } if iolabel<>nil then begin exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(iolabel),0)))); { this was wrong, probably an error due to diff3 emitcall(p^.procdefinition^.mangledname);} emitcall('IOCHECK',true); end; { this should be optimized (PM) } if must_pop then exprasmlist^.concat(new(pai386,op_const_reg(A_ADD,S_L,pop_size,R_ESP))); { restore registers } popusedregisters(pushed); { at last, restore instance pointer (SELF) } if loadesi then maybe_loadesi; pp:=params; while assigned(pp) do begin if assigned(pp^.left) then if (pp^.left^.location.loc=LOC_REFERENCE) or (pp^.left^.location.loc=LOC_MEM) then ungetiftemp(pp^.left^.location.reference); pp:=pp^.right; end; disposetree(params); end; { reverts the parameter list } var nb_para : integer; function reversparameter(p : ptree) : ptree; var hp1,hp2 : ptree; begin hp1:=nil; nb_para := 0; while assigned(p) do begin { pull out } hp2:=p; p:=p^.right; inc(nb_para); { pull in } hp2^.right:=hp1; hp1:=hp2; end; reversparameter:=hp1; end; procedure secondinline(var p : ptree); const in2size:array[in_inc_byte..in_dec_dword] of Topsize= (S_B,S_W,S_L,S_B,S_W,S_L); in2instr:array[in_inc_byte..in_dec_dword] of Tasmop= (A_INC,A_INC,A_INC,A_DEC,A_DEC,A_DEC); ad2instr:array[in_inc_byte..in_dec_dword] of Tasmop= (A_ADD,A_ADD,A_ADD,A_SUB,A_SUB,A_SUB); { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); } float_name: array[tfloattype] of string[8]= ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED16'); var aktfile : treference; ft : tfiletype; opsize : topsize; asmop : tasmop; pushed : tpushed; dummycoll : tdefcoll; { produces code for READ(LN) and WRITE(LN) } procedure handlereadwrite(doread,callwriteln : boolean); procedure loadstream; const io:array[0..1] of string[7]=('_OUTPUT','_INPUT'); var r : preference; begin new(r); reset_reference(r^); r^.symbol:=stringdup('U_'+upper(target_info.system_unit)+io[byte(doread)]); if assem_need_external_list and not (cs_compilesystem in aktswitches) then concat_external(r^.symbol^,EXT_NEAR); exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI))) end; var node,hp : ptree; typedtyp,pararesult : pdef; doflush,has_length : boolean; dummycoll : tdefcoll; iolabel : plabel; npara : longint; begin { I/O check } if cs_iocheck in aktswitches then begin getlabel(iolabel); emitl(A_LABEL,iolabel); end else iolabel:=nil; { no automatic call from flush } doflush:=false; { for write of real with the length specified } has_length:=false; hp:=nil; { reserve temporary pointer to data variable } aktfile.symbol:=nil; gettempofsizereference(4,aktfile); { first state text data } ft:=ft_text; { and state a parameter ? } if p^.left=nil then begin { state screen address} doflush:=true; { the following instructions are for "writeln;" } loadstream; { save @Dateivarible in temporary variable } exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); end else begin { revers paramters } node:=reversparameter(p^.left); p^.left := node; npara := nb_para; { calculate data variable } { is first parameter a file type ? } if node^.left^.resulttype^.deftype=filedef then begin ft:=pfiledef(node^.left^.resulttype)^.filetype; if ft=ft_typed then typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as; secondpass(node^.left); if codegenerror then exit; { save reference in temporary variables } { reference in tempor„re Variable retten } if node^.left^.location.loc<>LOC_REFERENCE then begin Message(cg_e_illegal_expression); exit; end; exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI))); { skip to the next parameter } node:=node^.right; end else begin { if we write to stdout/in then flush after the write(ln) } doflush:=true; loadstream; end; { save @Dateivarible in temporary variable } exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile)))); if doread then { parameter by READ gives call by reference } dummycoll.paratyp:=vs_var { an WRITE Call by "Const" } else dummycoll.paratyp:=vs_const; { because of secondcallparan, which otherwise attaches } if ft=ft_typed then begin { this is to avoid copy of simple const parameters } dummycoll.data:=new(pformaldef,init); end else { I think, this isn't a good solution (FK) } dummycoll.data:=nil; while assigned(node) do begin pushusedregisters(pushed,$ff); hp:=node; node:=node^.right; hp^.right:=nil; if hp^.is_colon_para then Message(parser_e_illegal_colon_qualifier); if ft=ft_typed then never_copy_const_param:=true; secondcallparan(hp,@dummycoll,false); if ft=ft_typed then never_copy_const_param:=false; hp^.right:=node; if codegenerror then exit; emit_push_mem(aktfile); if (ft=ft_typed) then begin { OK let's try this } { first we must only allow the right type } { we have to call blockread or blockwrite } { but the real problem is that } { reset and rewrite should have set } { the type size } { as recordsize for that file !!!! } { how can we make that } { I think that is only possible by adding } { reset and rewrite to the inline list a call } { allways read only one record by element } push_int(typedtyp^.size); if doread then emitcall('TYPED_READ',true) else emitcall('TYPED_WRITE',true) {!!!!!!!} end else begin { save current position } pararesult:=hp^.left^.resulttype; { handle possible field width } { of course only for write(ln) } if not doread then begin { handle total width parameter } if assigned(node) and node^.is_colon_para then begin hp:=node; node:=node^.right; hp^.right:=nil; secondcallparan(hp,@dummycoll,false); hp^.right:=node; if codegenerror then exit; has_length:=true; end else if pararesult^.deftype<>floatdef then push_int(0) else push_int(-32767); { a second colon para for a float ? } if assigned(node) and node^.is_colon_para then begin hp:=node; node:=node^.right; hp^.right:=nil; secondcallparan(hp,@dummycoll,false); hp^.right:=node; if pararesult^.deftype<>floatdef then Message(parser_e_illegal_colon_qualifier); if codegenerror then exit; end else begin if pararesult^.deftype=floatdef then push_int(-1); end end; case pararesult^.deftype of stringdef: begin if doread then emitcall('READ_TEXT_STRING',true) else begin emitcall('WRITE_TEXT_STRING',true); {ungetiftemp(hp^.left^.location.reference);} end; end; pointerdef : begin if is_equal(ppointerdef(pararesult)^.definition,cchardef) then begin if doread then emitcall('READ_TEXT_PCHAR_AS_POINTER',true) else emitcall('WRITE_TEXT_PCHAR_AS_POINTER',true); end else Message(parser_e_illegal_parameter_list); end; arraydef : begin if (parraydef(pararesult)^.lowrange=0) and is_equal(parraydef(pararesult)^.definition,cchardef) then begin if doread then emitcall('READ_TEXT_PCHAR_AS_ARRAY',true) else emitcall('WRITE_TEXT_PCHAR_AS_ARRAY',true); end else Message(parser_e_illegal_parameter_list); end; floatdef: begin if doread then emitcall('READ_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true) else emitcall('WRITE_TEXT_'+float_name[pfloatdef(pararesult)^.typ],true); end; orddef : begin case porddef(pararesult)^.typ of u8bit : if doread then emitcall('READ_TEXT_BYTE',true); s8bit : if doread then emitcall('READ_TEXT_SHORTINT',true); u16bit : if doread then emitcall('READ_TEXT_WORD',true); s16bit : if doread then emitcall('READ_TEXT_INTEGER',true); s32bit : if doread then emitcall('READ_TEXT_LONGINT',true) else emitcall('WRITE_TEXT_LONGINT',true); u32bit : if doread then emitcall('READ_TEXT_CARDINAL',true) else emitcall('WRITE_TEXT_CARDINAL',true); uchar : if doread then emitcall('READ_TEXT_CHAR',true) else emitcall('WRITE_TEXT_CHAR',true); bool8bit : if doread then { emitcall('READ_TEXT_BOOLEAN',true) } Message(parser_e_illegal_parameter_list) else emitcall('WRITE_TEXT_BOOLEAN',true); else Message(parser_e_illegal_parameter_list); end; end; else Message(parser_e_illegal_parameter_list); end; end; { load ESI in methods again } popusedregisters(pushed); maybe_loadesi; end; end; if callwriteln then begin pushusedregisters(pushed,$ff); emit_push_mem(aktfile); { pushexceptlabel; } if ft<>ft_text then Message(parser_e_illegal_parameter_list) ; emitcall('WRITELN_TEXT',true); popusedregisters(pushed); maybe_loadesi; end; if doflush and not(doread) then begin pushusedregisters(pushed,$ff); { pushexceptlabel; } emitcall('FLUSH_STDOUT',true); popusedregisters(pushed); maybe_loadesi; end; if iolabel<>nil then begin { registers are saved in the procedure } exprasmlist^.concat(new(pai386,op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(iolabel),0)))); emitcall('IOCHECK',true); end; ungetiftemp(aktfile); if assigned(p^.left) then begin p^.left:=reversparameter(p^.left); if npara<>nb_para then Message(cg_f_internal_error_in_secondinline); hp:=p^.left; while assigned(hp) do begin if assigned(hp^.left) then if (hp^.left^.location.loc=LOC_REFERENCE) or (hp^.left^.location.loc=LOC_MEM) then ungetiftemp(hp^.left^.location.reference); hp:=hp^.right; end; end; end; procedure handle_str; var hp,node,lentree,paratree : ptree; dummycoll : tdefcoll; is_real,has_length : boolean; real_type : byte; begin pushusedregisters(pushed,$ff); node:=p^.left; is_real:=false; has_length:=false; while assigned(node^.right) do node:=node^.right; { if a real parameter somewhere then call REALSTR } if (node^.left^.resulttype^.deftype=floatdef) then is_real:=true; node:=p^.left; { we have at least two args } { with at max 2 colon_para in between } { first arg longint or float } hp:=node; node:=node^.right; hp^.right:=nil; dummycoll.data:=hp^.resulttype; { string arg } dummycoll.paratyp:=vs_var; secondcallparan(hp,@dummycoll,false); if codegenerror then exit; dummycoll.paratyp:=vs_const; { second arg } hp:=node; node:=node^.right; hp^.right:=nil; { frac para } if hp^.is_colon_para and assigned(node) and node^.is_colon_para then begin dummycoll.data:=hp^.resulttype; secondcallparan(hp,@dummycoll,false); if codegenerror then exit; hp:=node; node:=node^.right; hp^.right:=nil; has_length:=true; end else if is_real then push_int(-1); { third arg, length only if is_real } if hp^.is_colon_para then begin dummycoll.data:=hp^.resulttype; secondcallparan(hp,@dummycoll,false); if codegenerror then exit; hp:=node; node:=node^.right; hp^.right:=nil; end else if is_real then push_int(-32767) else push_int(-1); { last arg longint or real } secondcallparan(hp,@dummycoll,false); if codegenerror then exit; if is_real then emitcall('STR_'+float_name[pfloatdef(hp^.resulttype)^.typ],true) else if porddef(hp^.resulttype)^.typ=u32bit then emitcall('STR_CARDINAL',true) else emitcall('STR_LONGINT',true); popusedregisters(pushed); end; var r : preference; 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(A_MOV,S_W,p^.left^.location.register, p^.location.register); end else begin del_reference(p^.left^.location.reference); p^.location.register:=reg32toreg16(getregister32); exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference), p^.location.register))); end; end else p^.location.register:=p^.left^.location.register; if p^.inlinenumber=in_hi_word then exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register))); p^.location.register:=reg16toreg8(p^.location.register); end; in_high_x : begin if is_open_array(p^.left^.resulttype) then begin secondpass(p^.left); del_reference(p^.left^.location.reference); p^.location.register:=getregister32; new(r); reset_reference(r^); r^.base:=highframepointer; r^.offset:=highoffset+4; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, r,p^.location.register))); end end; in_sizeof_x, in_typeof_x : begin { for both cases load vmt } if p^.left^.treetype=typen then begin p^.location.register:=getregister32; exprasmlist^.concat(new(pai386,op_csymbol_reg(A_MOV, S_L,newcsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,0), p^.location.register))); end else begin secondpass(p^.left); del_reference(p^.left^.location.reference); p^.location.loc:=LOC_REGISTER; p^.location.register:=getregister32; { load VMT pointer } exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.left^.location.reference), p^.location.register))); end; { in sizeof load size } if p^.inlinenumber=in_sizeof_x then begin new(r); reset_reference(r^); r^.base:=p^.location.register; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r, 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(A_MOV,S_L,p^.left^.location.register, p^.location.register); end else begin del_reference(p^.left^.location.reference); p^.location.register:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), p^.location.register))); end; end else p^.location.register:=p^.left^.location.register; if p^.inlinenumber=in_hi_long then exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_L,16,p^.location.register))); p^.location.register:=reg32toreg16(p^.location.register); end; {***CHARBUG} {We can now comment them out, as they are handled as typecast. Saves an incredible amount of 8 bytes code. I'am not lucky about this, because it's _not_ a type cast (FK) } { in_ord_char, in_chr_byte,} {***} in_length_string : begin secondpass(p^.left); set_location(p^.location,p^.left^.location); end; in_pred_x, in_succ_x: begin secondpass(p^.left); if p^.inlinenumber=in_pred_x then asmop:=A_DEC else asmop:=A_INC; case p^.resulttype^.size of 4 : opsize:=S_L; 2 : opsize:=S_W; 1 : opsize:=S_B; else internalerror(10080); end; p^.location.loc:=LOC_REGISTER; if p^.left^.location.loc<>LOC_REGISTER then begin p^.location.register:=getregister32; if (p^.resulttype^.size=2) then p^.location.register:=reg32toreg16(p^.location.register); if (p^.resulttype^.size=1) then p^.location.register:=reg32toreg8(p^.location.register); if p^.left^.location.loc=LOC_CREGISTER then emit_reg_reg(A_MOV,opsize,p^.left^.location.register, p^.location.register) else if p^.left^.location.loc=LOC_FLAGS then exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.left^.location.resflags],S_NO, p^.location.register))) else begin del_reference(p^.left^.location.reference); exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference), p^.location.register))); end; end else p^.location.register:=p^.left^.location.register; exprasmlist^.concat(new(pai386,op_reg(asmop,opsize, p^.location.register))) { here we should insert bounds check ? } { and direct call to bounds will crash the program } { if we are at the limit } { we could also simply say that pred(first)=first and succ(last)=last } { could this be usefull I don't think so (PM) emitoverflowcheck;} end; in_inc_byte..in_dec_dword: begin secondpass(p^.left); if cs_check_overflow in aktswitches then begin { SINCE THE CARRY FLAG IS NEVER SET BY DEC/INC, we must use } { ADD and SUB to check for overflow for unsigned operations. } exprasmlist^.concat(new(pai386,op_const_ref(ad2instr[p^.inlinenumber], in2size[p^.inlinenumber],1,newreference(p^.left^.location.reference)))); emitoverflowcheck(p^.left); end else exprasmlist^.concat(new(pai386,op_ref(in2instr[p^.inlinenumber], in2size[p^.inlinenumber],newreference(p^.left^.location.reference)))); 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 exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L, p^.left^.left^.location.register, p^.left^.left^.location.register))); ungetregister32(p^.left^.left^.location.register); end else begin exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0, newreference(p^.left^.left^.location.reference)))); del_reference(p^.left^.left^.location.reference); end; p^.location.resflags:=F_NE; end; in_reset_typedfile,in_rewrite_typedfile : begin pushusedregisters(pushed,$ff); exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size))); secondload(p^.left); emitpushreferenceaddr(p^.left^.location.reference); if p^.inlinenumber=in_reset_typedfile then emitcall('RESET_TYPED',true) else emitcall('REWRITE_TYPED',true); popusedregisters(pushed); 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_mem(aktfile); { pushexceptlabel; } if ft<>ft_text then Message(parser_e_illegal_parameter_list); emitcall('READLN_TEXT',true); 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); var hr : tregister; begin secondpass(p^.left); if codegenerror then exit; { classes must be dereferenced implicit } if (p^.left^.resulttype^.deftype=objectdef) and pobjectdef(p^.left^.resulttype)^.isclass then begin clear_reference(p^.location.reference); case p^.left^.location.loc of LOC_REGISTER: p^.location.reference.base:=p^.left^.location.register; LOC_CREGISTER: begin { ... and reserve one for the pointer } hr:=getregister32; emit_reg_reg(A_MOV,S_L,p^.left^.location.register,hr); p^.location.reference.base:=hr; end; else begin { free register } del_reference(p^.left^.location.reference); { ... and reserve one for the pointer } hr:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg( A_MOV,S_L,newreference(p^.left^.location.reference), hr))); p^.location.reference.base:=hr; end; end; end else set_location(p^.location,p^.left^.location); inc(p^.location.reference.offset,p^.vs^.address); end; procedure secondselfn(var p : ptree); begin clear_reference(p^.location.reference); if (p^.resulttype^.deftype=classrefdef) or ((p^.resulttype^.deftype=objectdef) and pobjectdef(p^.resulttype)^.isclass ) then p^.location.register:=R_ESI else p^.location.reference.base:=R_ESI; end; procedure secondhdisposen(var p : ptree); begin secondpass(p^.left); if codegenerror then exit; clear_reference(p^.location.reference); case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER: begin p^.location.reference.index:=getregister32; exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, p^.left^.location.register, p^.location.reference.index))); end; LOC_MEM,LOC_REFERENCE : begin del_reference(p^.left^.location.reference); p^.location.reference.index:=getregister32; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference), p^.location.reference.index))); end; end; end; procedure secondhnewn(var p : ptree); begin end; procedure secondnewn(var p : ptree); begin secondpass(p^.left); if codegenerror then exit; p^.location.register:=p^.left^.location.register; end; procedure secondsimplenewdispose(var p : ptree); var pushed : tpushed; begin secondpass(p^.left); if codegenerror then exit; pushusedregisters(pushed,$ff); { determines the size of the mem block } push_int(ppointerdef(p^.left^.resulttype)^.definition^.size); { push pointer adress } case p^.left^.location.loc of LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, p^.left^.location.register))); LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference); end; { call the mem handling procedures } case p^.treetype of simpledisposen: emitcall('FREEMEM',true); simplenewn: emitcall('GETMEM',true); end; popusedregisters(pushed); { may be load ESI } maybe_loadesi; end; { copies p a set element on the stack } procedure pushsetelement(var p : ptree); var hr : tregister; begin { copy the element on the stack, slightly complicated } 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); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,reg32toreg16(hr)))); end; R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : begin ungetregister32(reg16toreg32(hr)); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,hr))); end; R_AL,R_BL,R_CL,R_DL : begin ungetregister32(reg8toreg32(hr)); exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_W,reg8toreg16(hr)))); end; end; end; else begin exprasmlist^.concat(new(pai386,op_ref(A_PUSH,S_W,newreference(p^.location.reference)))); del_reference(p^.location.reference); end; end; end; procedure secondsetcons(var p : ptree); var l : plabel; i,smallsetvalue : longint; hp : ptree; href,sref : treference; begin { this should be reimplemented for smallsets } { differently (PM) } { produce constant part } href.symbol := Nil; clear_reference(href); getlabel(l); href.symbol:=stringdup(lab2str(l)); stringdispose(p^.location.reference.symbol); datasegment^.concat(new(pai_label,init(l))); {if psetdef(p^.resulttype)=smallset then begin smallsetvalue:=(p^.constset^[3]*256)+p^.constset^[2]; smallsetvalue:=((smallset*256+p^.constset^[1])*256+p^.constset^[1]; datasegment^.concat(new(pai_const,init_32bit(smallsetvalue))); hp:=p^.left; if assigned(hp) then begin sref.symbol:=nil; gettempofsizereference(32,sref); concatcopy(href,sref,32,false); while assigned(hp) do begin secondpass(hp^.left); if codegenerror then exit; pushsetelement(hp^.left); emitpushreferenceaddr(sref); register is save in subroutine emitcall('SET_SET_BYTE',true); hp:=hp^.right; end; p^.location.reference:=sref; end else p^.location.reference:=href; end else } begin for i:=0 to 31 do datasegment^.concat(new(pai_const,init_8bit(p^.constset^[i]))); hp:=p^.left; if assigned(hp) then begin sref.symbol:=nil; gettempofsizereference(32,sref); concatcopy(href,sref,32,false); while assigned(hp) do begin secondpass(hp^.left); if codegenerror then exit; pushsetelement(hp^.left); emitpushreferenceaddr(sref); { register is save in subroutine } emitcall('SET_SET_BYTE',true); hp:=hp^.right; end; p^.location.reference:=sref; end else p^.location.reference:=href; end; end; { could be built into secondadd but it } { should be easy to read } procedure secondin(var p : ptree); type Tsetpart=record range:boolean; {Part is a range.} start,stop:byte; {Start/stop when range; Stop=element when an element.} end; var pushed,ranges : boolean; hr : tregister; setparts:array[1..8] of Tsetpart; i,numparts:byte; href,href2:Treference; l,l2 : plabel; function swaplongint(l : longint): longint; var w1: word; w2: word; begin w1:=l and $ffff; w2:=l shr 16; l:=swap(w2)+(longint(swap(w1)) shl 16); swaplongint:=l; end; function analizeset(Aset:Pconstset):boolean; type byteset=set of byte; tlongset = array[0..7] of longint; var compares,maxcompares:word; i:byte; someset : tlongset; begin analizeset:=false; ranges:=false; numparts:=0; compares:=0; {Lots of comparisions take a lot of time, so do not allow too much comparisions. 8 comparisions are, however, still smalller than emitting the set.} maxcompares:=5; if cs_littlesize in aktswitches then maxcompares:=8; move(ASet^,someset,32); { On Big endian machines sets are stored } { as INTEL Little-endian format, therefore } { we must convert it to the correct format } {$IFDEF BIG_ENDIAN} for I:=0 to 7 do someset[i]:=swaplongint(someset[i]); {$ENDIF} for i:=0 to 255 do if i in byteset(someset) then begin if (numparts=0) or (i<>setparts[numparts].stop+1) then begin {Set element is a separate element.} inc(compares); if compares>maxcompares then exit; inc(numparts); setparts[numparts].range:=false; setparts[numparts].stop:=i; end else {Set element is part of a range.} if not setparts[numparts].range then begin {Transform an element into a range.} setparts[numparts].range:=true; setparts[numparts].start:= setparts[numparts].stop; setparts[numparts].stop:=i; inc(compares); if compares>maxcompares then exit; end else begin {Extend a range.} setparts[numparts].stop:=i; {A range of two elements can better be checked as two separate ones. When extending a range, our range becomes larger than two elements.} ranges:=true; end; end; analizeset:=true; end; begin if psetdef(p^.right^.resulttype)^.settype=smallset then begin if p^.left^.treetype=ordconstn then begin { only compulsory } secondpass(p^.left); secondpass(p^.right); if codegenerror then exit; p^.location.resflags:=F_NE; case p^.right^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin exprasmlist^.concat(new(pai386,op_const_reg( A_TEST,S_L,1 shl (p^.left^.value and 31), p^.right^.location.register))); ungetregister32(p^.right^.location.register); end else begin exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_L,1 shl (p^.left^.value and 31), newreference(p^.right^.location.reference)))); del_reference(p^.right^.location.reference); end; end; end else begin { calculate both operators } { the complex one first } firstcomplex(p); secondpass(p^.left); { are too few registers free? } pushed:=maybe_push(p^.right^.registers32,p^.left); secondpass(p^.right); if pushed then restore(p^.left); { of course not commutative } if p^.swaped then swaptree(p); case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER: begin hr:=p^.left^.location.register; case p^.left^.location.register of R_AX,R_BX,R_CX,R_DX,R_DI,R_SI,R_SP : begin hr:=reg16toreg32(p^.left^.location.register); ungetregister32(hr); exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL, p^.left^.location.register,hr))); end; R_AL,R_BL,R_CL,R_DL : begin hr:=reg8toreg32(p^.left^.location.register); ungetregister32(hr); exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL, p^.left^.location.register,hr))); end; end; end; else begin { the set element isn't never samller than a byte } { and because it's a small set we need only 5 bits } { but 8 bits are eaiser to load } exprasmlist^.concat(new(pai386,op_ref_reg(A_MOVZX,S_BL, newreference(p^.left^.location.reference),R_EDI))); hr:=R_EDI; del_reference(p^.left^.location.reference); end; end; case p^.right^.location.loc of LOC_REGISTER, LOC_CREGISTER: exprasmlist^.concat(new(pai386,op_reg_reg(A_BT,S_L,hr, p^.right^.location.register))); else begin exprasmlist^.concat(new(pai386,op_reg_ref(A_BT,S_L,hr, newreference(p^.right^.location.reference)))); del_reference(p^.right^.location.reference); end; end; p^.location.loc:=LOC_FLAGS; p^.location.resflags:=F_C; end; end else begin if p^.left^.treetype=ordconstn then begin { only compulsory } secondpass(p^.left); secondpass(p^.right); if codegenerror then exit; p^.location.resflags:=F_NE; inc(p^.right^.location.reference.offset,p^.left^.value shr 3); exprasmlist^.concat(new(pai386,op_const_ref(A_TEST,S_B,1 shl (p^.left^.value and 7), newreference(p^.right^.location.reference)))); del_reference(p^.right^.location.reference); end else begin if (p^.right^.treetype=setconstrn) and analizeset(p^.right^.constset) then begin {It gives us advantage to check for the set elements separately instead of using the SET_IN_BYTE procedure. To do: Build in support for LOC_JUMP.} secondpass(p^.left); {We won't do a second pass on p^.right, because this will emit the constant set.} {If register is used, use only lower 8 bits} case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_const_reg(A_AND,S_B, 255,p^.left^.location.register))); end; {Get a label to jump to the end.} p^.location.loc:=LOC_FLAGS; {It's better to use the zero flag when there are no ranges.} if ranges then p^.location.resflags:=F_C else p^.location.resflags:=F_E; href.symbol := nil; clear_reference(href); getlabel(l); href.symbol:=stringdup(lab2str(l)); for i:=1 to numparts do if setparts[i].range then begin {Check if left is in a range.} {Get a label to jump over the check.} href2.symbol := nil; clear_reference(href2); getlabel(l2); href.symbol:=stringdup(lab2str(l2)); if setparts[i].start=setparts[i].stop-1 then begin case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B, setparts[i].start,p^.left^.location.register))); else exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, setparts[i].start,newreference(p^.left^.location.reference)))); end; {Result should be in carry flag when ranges are used.} if ranges then exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); {If found, jump to end.} emitl(A_JE,l); case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER: exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B, setparts[i].stop,p^.left^.location.register))); else exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, setparts[i].stop,newreference(p^.left^.location.reference)))); end; {Result should be in carry flag when ranges are used.} if ranges then exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); {If found, jump to end.} emitl(A_JE,l); end else begin if setparts[i].start<>0 then begin { We only check for the lower bound if it is > 0, because set elements lower than 0 do nt exist.} case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B, setparts[i].start,p^.left^.location.register))); else exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, setparts[i].start,newreference(p^.left^.location.reference)))); end; {If lower, jump to next check.} emitl(A_JB,l2); end; if setparts[i].stop<>255 then begin { We only check for the high bound if it is < 255, because set elements higher than 255 do nt exist.} case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER : exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B, setparts[i].stop+1,p^.left^.location.register))); else exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, setparts[i].stop+1,newreference(p^.left^.location.reference)))); end; {If higher, element is in set.} emitl(A_JB,l); end else begin exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); emitl(A_JMP,l); end; end; {Emit the jump over label.} exprasmlist^.concat(new(pai_label,init(l2))); end else begin {Emit code to check if left is an element.} case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER: exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,S_B, setparts[i].stop,p^.left^.location.register))); else exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_B, setparts[i].stop,newreference(p^.left^.location.reference)))); end; {Result should be in carry flag when ranges are used.} if ranges then exprasmlist^.concat(new(pai386,op_none(A_STC,S_NO))); {If found, jump to end.} emitl(A_JE,l); end; if ranges then exprasmlist^.concat(new(pai386,op_none(A_CLC,S_NO))); {To compensate for not doing a second pass.} stringdispose(p^.right^.location.reference.symbol); {Now place the end label.} exprasmlist^.concat(new(pai_label,init(l))); case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER: ungetregister32(p^.left^.location.register); else del_reference(p^.left^.location.reference); end; end else begin { calculate both operators } { the complex one first } firstcomplex(p); secondpass(p^.left); { are too few registers free? } pushed:=maybe_push(p^.right^.registers32,p); secondpass(p^.right); if pushed then restore(p); { of course not commutative } if p^.swaped then swaptree(p); pushsetelement(p^.left); emitpushreferenceaddr(p^.right^.location.reference); del_reference(p^.right^.location.reference); { registers need not be save. that happens in SET_IN_BYTE } { (EDI is changed) } emitcall('SET_IN_BYTE',true); { ungetiftemp(p^.right^.location.reference); } p^.location.loc:=LOC_FLAGS; p^.location.resflags:=F_C; end; end; end; end; {***} procedure secondexpr(var p : ptree); begin secondpass(p^.left); end; procedure secondblockn(var p : ptree); var hp : ptree; begin hp:=p^.left; while assigned(hp) do begin { assignments could be distance optimized } if assigned(hp^.right) then begin cleartempgen; secondpass(hp^.right); end; hp:=hp^.left; end; end; procedure second_while_repeatn(var p : ptree); var l1,l2,l3,oldclabel,oldblabel : plabel; otlabel,oflabel : plabel; begin getlabel(l1); getlabel(l2); { arrange continue and breaklabels: } oldclabel:=aktcontinuelabel; oldblabel:=aktbreaklabel; if p^.treetype=repeatn then begin emitl(A_LABEL,l1); aktcontinuelabel:=l1; aktbreaklabel:=l2; cleartempgen; if assigned(p^.right) then secondpass(p^.right); otlabel:=truelabel; oflabel:=falselabel; truelabel:=l2; falselabel:=l1; cleartempgen; secondpass(p^.left); maketojumpbool(p^.left); emitl(A_LABEL,l2); truelabel:=otlabel; falselabel:=oflabel; end else begin { handling code at the end as it is much more efficient } emitl(A_JMP,l2); emitl(A_LABEL,l1); cleartempgen; getlabel(l3); aktcontinuelabel:=l2; aktbreaklabel:=l3; if assigned(p^.right) then secondpass(p^.right); emitl(A_LABEL,l2); otlabel:=truelabel; oflabel:=falselabel; truelabel:=l1; falselabel:=l3; cleartempgen; secondpass(p^.left); maketojumpbool(p^.left); emitl(A_LABEL,l3); truelabel:=otlabel; falselabel:=oflabel; end; aktcontinuelabel:=oldclabel; aktbreaklabel:=oldblabel; end; procedure secondifn(var p : ptree); var hl,otlabel,oflabel : plabel; begin otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); cleartempgen; secondpass(p^.left); maketojumpbool(p^.left); if assigned(p^.right) then begin emitl(A_LABEL,truelabel); cleartempgen; secondpass(p^.right); end; if assigned(p^.t1) then begin if assigned(p^.right) then begin getlabel(hl); emitl(A_JMP,hl); end; emitl(A_LABEL,falselabel); cleartempgen; secondpass(p^.t1); if assigned(p^.right) then emitl(A_LABEL,hl); end else emitl(A_LABEL,falselabel); if not(assigned(p^.right)) then emitl(A_LABEL,truelabel); truelabel:=otlabel; falselabel:=oflabel; end; procedure secondbreakn(var p : ptree); begin if aktbreaklabel<>nil then emitl(A_JMP,aktbreaklabel) else Message(cg_e_break_not_allowed); end; procedure secondcontinuen(var p : ptree); begin if aktcontinuelabel<>nil then emitl(A_JMP,aktcontinuelabel) else Message(cg_e_continue_not_allowed); end; procedure secondfor(var p : ptree); var l3,oldclabel,oldblabel : plabel; omitfirstcomp,temptovalue : boolean; hs : byte; temp1 : treference; hop : tasmop; cmpreg,cmp32 : tregister; opsize : topsize; count_var_is_signed : boolean; begin oldclabel:=aktcontinuelabel; oldblabel:=aktbreaklabel; getlabel(aktcontinuelabel); getlabel(aktbreaklabel); getlabel(l3); { could we spare the first comparison ? } omitfirstcomp:=false; if p^.right^.treetype=ordconstn then if p^.left^.right^.treetype=ordconstn then omitfirstcomp:=(p^.backward and (p^.left^.right^.value>=p^.right^.value)) or (not(p^.backward) and (p^.left^.right^.value<=p^.right^.value)); { only calculate reference } cleartempgen; secondpass(p^.t2); if not(simple_loadn) then Message(cg_e_illegal_count_var); { produce start assignment } cleartempgen; secondpass(p^.left); count_var_is_signed:=is_signed(porddef(p^.t2^.resulttype)); hs:=p^.t2^.resulttype^.size; cmp32:=getregister32; case hs of 1 : begin opsize:=S_B; cmpreg:=reg32toreg8(cmp32); end; 2 : begin opsize:=S_W; cmpreg:=reg32toreg16(cmp32); end; 4 : begin opsize:=S_L; cmpreg:=cmp32; end; end; cleartempgen; secondpass(p^.right); { calculate pointer value and check if changeable and if so } { load into temporary variable } if p^.right^.treetype<>ordconstn then begin temp1.symbol:=nil; gettempofsizereference(hs,temp1); temptovalue:=true; if (p^.right^.location.loc=LOC_REGISTER) or (p^.right^.location.loc=LOC_CREGISTER) then begin exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,p^.right^.location.register, newreference(temp1)))); end else concatcopy(p^.right^.location.reference,temp1,hs,false); end else temptovalue:=false; if temptovalue then begin if p^.t2^.location.loc=LOC_CREGISTER then begin exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), p^.t2^.location.register))); end else begin exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference), cmpreg))); exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), cmpreg))); end; end else begin if not(omitfirstcomp) then begin if p^.t2^.location.loc=LOC_CREGISTER then exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value, p^.t2^.location.register))) else exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value, newreference(p^.t2^.location.reference)))); end; end; if p^.backward then if count_var_is_signed then hop:=A_JL else hop:=A_JB else if count_var_is_signed then hop:=A_JG else hop:=A_JA; if not(omitfirstcomp) or temptovalue then emitl(hop,aktbreaklabel); emitl(A_LABEL,l3); { help register must not be in instruction block } cleartempgen; if assigned(p^.t1) then secondpass(p^.t1); emitl(A_LABEL,aktcontinuelabel); { makes no problems there } cleartempgen; { demand help register again } cmp32:=getregister32; case hs of 1 : begin opsize:=S_B; cmpreg:=reg32toreg8(cmp32); end; 2 : begin opsize:=S_W; cmpreg:=reg32toreg16(cmp32); end; 4 : opsize:=S_L; end; { produce comparison and the corresponding } { jump } if temptovalue then begin if p^.t2^.location.loc=LOC_CREGISTER then begin exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), p^.t2^.location.register))); end else begin exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.t2^.location.reference), cmpreg))); exprasmlist^.concat(new(pai386,op_ref_reg(A_CMP,opsize,newreference(temp1), cmpreg))); end; end else begin if p^.t2^.location.loc=LOC_CREGISTER then exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^.right^.value, p^.t2^.location.register))) else exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,opsize,p^.right^.value, newreference(p^.t2^.location.reference)))); end; if p^.backward then if count_var_is_signed then hop:=A_JLE else hop :=A_JBE else if count_var_is_signed then hop:=A_JGE else hop:=A_JAE; emitl(hop,aktbreaklabel); { according to count direction DEC or INC... } { must be after the test because of 0to 255 for bytes !! } if p^.backward then hop:=A_DEC else hop:=A_INC; if p^.t2^.location.loc=LOC_CREGISTER then exprasmlist^.concat(new(pai386,op_reg(hop,opsize,p^.t2^.location.register))) else exprasmlist^.concat(new(pai386,op_ref(hop,opsize,newreference(p^.t2^.location.reference)))); emitl(A_JMP,l3); { this is the break label: } emitl(A_LABEL,aktbreaklabel); ungetregister32(cmp32); if temptovalue then ungetiftemp(temp1); aktcontinuelabel:=oldclabel; aktbreaklabel:=oldblabel; end; { var hs : string; } procedure secondexitn(var p : ptree); var is_mem : boolean; {op : tasmop; s : topsize;} otlabel,oflabel : plabel; label do_jmp; begin if assigned(p^.left) then begin otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(p^.left); case p^.left^.location.loc of LOC_FPU : goto do_jmp; LOC_MEM,LOC_REFERENCE : is_mem:=true; LOC_CREGISTER, LOC_REGISTER : is_mem:=false; LOC_FLAGS : begin exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_NO,R_AL))); goto do_jmp; end; LOC_JUMP : begin emitl(A_LABEL,truelabel); exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,1,R_AL))); emitl(A_JMP,aktexit2label); exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,R_AL,R_AL))); goto do_jmp; end; else internalerror(2001); end; if (procinfo.retdef^.deftype=orddef) then begin case porddef(procinfo.retdef)^.typ of s32bit,u32bit : if is_mem then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.left^.location.reference),R_EAX))) else emit_reg_reg(A_MOV,S_L, p^.left^.location.register,R_EAX); u8bit,s8bit,uchar,bool8bit : if is_mem then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_B, newreference(p^.left^.location.reference),R_AL))) else emit_reg_reg(A_MOV,S_B, p^.left^.location.register,R_AL); s16bit,u16bit : if is_mem then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W, newreference(p^.left^.location.reference),R_AX))) else emit_reg_reg(A_MOV,S_W, p^.left^.location.register,R_AX); end; end else if (procinfo.retdef^.deftype in [pointerdef,enumdef,procvardef]) then begin if is_mem then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.left^.location.reference),R_EAX))) else exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L, p^.left^.location.register,R_EAX))); end else if (procinfo.retdef^.deftype=floatdef) then begin if pfloatdef(procinfo.retdef)^.typ=f32bit then begin if is_mem then exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L, newreference(p^.left^.location.reference),R_EAX))) else emit_reg_reg(A_MOV,S_L, p^.left^.location.register,R_EAX); end else if is_mem then floatload(pfloatdef(procinfo.retdef)^.typ,p^.left^.location.reference); end; do_jmp: truelabel:=otlabel; falselabel:=oflabel; emitl(A_JMP,aktexit2label); end else begin emitl(A_JMP,aktexitlabel); end; end; procedure secondgoto(var p : ptree); begin emitl(A_JMP,p^.labelnr); end; procedure secondlabel(var p : ptree); begin emitl(A_LABEL,p^.labelnr); cleartempgen; secondpass(p^.left); end; procedure secondasm(var p : ptree); begin exprasmlist^.concatlist(p^.p_asm); end; procedure secondcase(var p : ptree); var with_sign : boolean; opsize : topsize; jmp_gt,jmp_le,jmp_lee : tasmop; hp : ptree; { register with case expression } hregister : tregister; endlabel,elselabel : plabel; { true, if we can omit the range check of the jump table } jumptable_no_range : boolean; procedure gentreejmp(p : pcaserecord); var lesslabel,greaterlabel : plabel; begin emitl(A_LABEL,p^._at); { calculate labels for left and right } if (p^.less=nil) then lesslabel:=elselabel else lesslabel:=p^.less^._at; if (p^.greater=nil) then greaterlabel:=elselabel else greaterlabel:=p^.greater^._at; { calculate labels for left and right } { no range label: } if p^._low=p^._high then begin exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister))); if greaterlabel=lesslabel then begin emitl(A_JNE,lesslabel); end else begin emitl(jmp_le,lesslabel); emitl(jmp_gt,greaterlabel); end; emitl(A_JMP,p^.statement); end else begin exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._low,hregister))); emitl(jmp_le,lesslabel); exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,p^._high,hregister))); emitl(jmp_gt,greaterlabel); emitl(A_JMP,p^.statement); end; if assigned(p^.less) then gentreejmp(p^.less); if assigned(p^.greater) then gentreejmp(p^.greater); end; procedure genlinearlist(hp : pcaserecord); var first : boolean; last : longint; {helplabel : longint;} procedure genitem(t : pcaserecord); begin if assigned(t^.less) then genitem(t^.less); if t^._low=t^._high then begin if t^._low-last=1 then exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister))) else if t^._low-last=0 then exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize,hregister,hregister))) else exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last,hregister))); last:=t^._low; emitl(A_JZ,t^.statement); end else begin { it begins with the smallest label, if the value } { is even smaller then jump immediately to the } { ELSE-label } if first then begin if t^._low-1=1 then exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize, hregister))) else if t^._low-1=0 then exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,opsize, hregister,hregister))) else exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize, t^._low-1,hregister))); { work around: if the lower range=0 and we do the subtraction we have to take care of the sign! } if t^._low=0 then emitl(A_JLE,elselabel) else emitl(jmp_lee,elselabel); end { if there is no unused label between the last and the } { present label then the lower limit can be checked } { immediately. else check the range in between: } else if (t^._low-last>1)then begin if t^._low-last-1=1 then exprasmlist^.concat(new(pai386,op_reg(A_DEC,opsize,hregister))) else exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._low-last-1,hregister))); emitl(jmp_lee,elselabel); end; exprasmlist^.concat(new(pai386,op_const_reg(A_SUB,opsize,t^._high-t^._low+1,hregister))); emitl(jmp_lee,t^.statement); last:=t^._high; end; first:=false; if assigned(t^.greater) then genitem(t^.greater); end; var hr : tregister; begin { case register is modified by the list evalution } if (p^.left^.location.loc=LOC_CREGISTER) then begin hr:=getregister32; case opsize of S_B : hregister:=reg32toreg8(hr); S_W : hregister:=reg32toreg16(hr); S_L : hregister:=hr; end; end; last:=0; first:=true; genitem(hp); emitl(A_JMP,elselabel); end; procedure genjumptable(hp : pcaserecord;min_,max_ : longint); var table : plabel; last : longint; hr : preference; procedure genitem(t : pcaserecord); var i : longint; begin if assigned(t^.less) then genitem(t^.less); { fill possible hole } for i:=last+1 to t^._low-1 do datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str (elselabel))))); for i:=t^._low to t^._high do datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str (t^.statement))))); last:=t^._high; if assigned(t^.greater) then genitem(t^.greater); end; begin if not(jumptable_no_range) then begin exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,min_,hregister))); { case expr less than min_ => goto elselabel } emitl(jmp_le,elselabel); exprasmlist^.concat(new(pai386,op_const_reg(A_CMP,opsize,max_,hregister))); emitl(jmp_gt,elselabel); end; getlabel(table); { extend with sign } if opsize=S_W then begin exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_WL,hregister, reg16toreg32(hregister)))); hregister:=reg16toreg32(hregister); end else if opsize=S_B then begin exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVZX,S_BL,hregister, reg8toreg32(hregister)))); hregister:=reg8toreg32(hregister); end; new(hr); reset_reference(hr^); hr^.symbol:=stringdup(lab2str(table)); hr^.offset:=(-min_)*4; hr^.index:=hregister; hr^.scalefactor:=4; exprasmlist^.concat(new(pai386,op_ref(A_JMP,S_NO,hr))); { !!!!! generate tables if not(cs_littlesize in aktswitches^ ) then datasegment^.concat(new(pai386,op_const(A_ALIGN,S_NO,4))); } datasegment^.concat(new(pai_label,init(table))); last:=min_; genitem(hp); { !!!!!!! if not(cs_littlesize in aktswitches^ ) then exprasmlist^.concat(new(pai386,op_const(A_ALIGN,S_NO,4))); } end; var lv,hv,min_label,max_label,labels : longint; max_linear_list : longint; begin getlabel(endlabel); getlabel(elselabel); with_sign:=is_signed(p^.left^.resulttype); if with_sign then begin jmp_gt:=A_JG; jmp_le:=A_JL; jmp_lee:=A_JLE; end else begin jmp_gt:=A_JA; jmp_le:=A_JB; jmp_lee:=A_JBE; end; cleartempgen; secondpass(p^.left); { determines the size of the operand } { determines the size of the operand } opsize:=bytes2Sxx[p^.left^.resulttype^.size]; { copy the case expression to a register } { copy the case expression to a register } case p^.left^.location.loc of LOC_REGISTER, LOC_CREGISTER: hregister:=p^.left^.location.register; LOC_MEM,LOC_REFERENCE : begin del_reference(p^.left^.location.reference); hregister:=getregister32; case opsize of S_B : hregister:=reg32toreg8(hregister); S_W : hregister:=reg32toreg16(hregister); end; exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference( p^.left^.location.reference),hregister))); end; else internalerror(2002); end; { now generate the jumps } if cs_optimize in aktswitches then begin { procedures are empirically passed on } { consumption can also be calculated } { but does it pay on the different } { processors? } { moreover can the size only be appro- } { ximated as it is not known if rel8, } { rel16 or rel32 jumps are used } min_label:=case_get_min(p^.nodes); max_label:=case_get_max(p^.nodes); labels:=case_count_labels(p^.nodes); { can we omit the range check of the jump table } getrange(p^.left^.resulttype,lv,hv); jumptable_no_range:=(lv=min_label) and (hv=max_label); { optimize for size ? } if cs_littlesize in aktswitches then begin if (labels<=2) or ((max_label-min_label)>3*labels) then { a linear list is always smaller than a jump tree } genlinearlist(p^.nodes) else { if the labels less or more a continuum then } genjumptable(p^.nodes,min_label,max_label); end else begin if jumptable_no_range then max_linear_list:=4 else max_linear_list:=2; { a jump table crashes the pipeline! } if opt_processors=i486 then inc(max_linear_list,3); if opt_processors=pentium then inc(max_linear_list,6); if opt_processors=pentiumpro then inc(max_linear_list,9); if (labels<=max_linear_list) then genlinearlist(p^.nodes) else begin if ((max_label-min_label)>4*labels) then begin if labels>16 then gentreejmp(p^.nodes) else genlinearlist(p^.nodes); end else genjumptable(p^.nodes,min_label,max_label); end; end; end else { it's always not bad } genlinearlist(p^.nodes); { now generate the instructions } hp:=p^.right; while assigned(hp) do begin cleartempgen; secondpass(hp^.right); emitl(A_JMP,endlabel); hp:=hp^.left; end; emitl(A_LABEL,elselabel); { ...and the else block } if assigned(p^.elseblock) then begin cleartempgen; secondpass(p^.elseblock); end; emitl(A_LABEL,endlabel); end; { generates the code for a raise statement } procedure secondraise(var p : ptree); var a : plabel; begin if assigned(p^.left) then begin { generate the address } if assigned(p^.right) then begin secondpass(p^.right); if codegenerror then exit; end else begin getlabel(a); emitl(A_LABEL,a); exprasmlist^.concat(new(pai386, op_csymbol(A_PUSH,S_L,newcsymbol(lab2str(a),0)))); end; secondpass(p^.left); if codegenerror then exit; case p^.left^.location.loc of LOC_MEM,LOC_REFERENCE : emitpushreferenceaddr(p^.left^.location.reference); LOC_CREGISTER,LOC_REGISTER : exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L, p^.left^.location.register))); else Message(sym_e_type_mismatch); end; emitcall('DO_RAISE',true); end else emitcall('DO_RERAISE',true); end; procedure secondtryexcept(var p : ptree); begin end; procedure secondtryfinally(var p : ptree); begin end; procedure secondfail(var p : ptree); var hp : preference; begin {if procinfo.exceptions then aktproccode.concat(gennasmrec(CALL,S_NO,'HELP_DESTRUCTOR_E')) else } { we should know if the constructor is called with a new or not, how can we do that ??? exprasmlist^.concat(new(pai386,op_csymbol(A_CALL,S_NO,newcsymbol('HELP_DESTRUCTOR',0)))); } exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_L,R_ESI,R_ESI))); { also reset to zero in the stack } new(hp); reset_reference(hp^); hp^.offset:=procinfo.ESI_offset; hp^.base:=procinfo.framepointer; exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_ESI,hp))); exprasmlist^.concat(new(pai_labeled,init(A_JMP,quickexitlabel))); end; procedure secondwith(var p : ptree); var ref : treference; symtable : psymtable; i : longint; begin if assigned(p^.left) then begin secondpass(p^.left); ref.symbol:=nil; gettempofsizereference(4,ref); exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L, newreference(p^.left^.location.reference),R_EDI))); exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L, R_EDI,newreference(ref)))); del_reference(p^.left^.location.reference); { the offset relative to (%ebp) is only needed here! } symtable:=p^.withsymtable; for i:=1 to p^.tablecount do begin symtable^.datasize:=ref.offset; symtable:=symtable^.next; end; { p^.right can be optimize out !!! } if p^.right<>nil then secondpass(p^.right); { clear some stuff } ungetiftemp(ref); end; end; procedure secondpass(var p : ptree); const procedures : array[ttreetyp] of secondpassproc = (secondadd,secondadd,secondadd,secondmoddiv,secondadd, secondmoddiv,secondassignment,secondload,secondnothing, secondadd,secondadd,secondadd,secondadd, secondadd,secondadd,secondin,secondadd, secondadd,secondshlshr,secondshlshr,secondadd, secondadd,secondsubscriptn,secondderef,secondaddr, seconddoubleaddr, secondordconst,secondtypeconv,secondcalln,secondnothing, secondrealconst,secondfixconst,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,secondwith,secondcase,secondlabel, secondgoto,secondsimplenewdispose,secondtryexcept,secondraise, secondnothing,secondtryfinally,secondis,secondas,seconderror, secondfail, secondnothing,secondloadvmt); var oldcodegenerror : boolean; oldswitches : Tcswitches; oldis : pinputfile; oldnr : longint; begin oldcodegenerror:=codegenerror; oldswitches:=aktswitches; oldis:=current_module^.current_inputfile; oldnr:=current_module^.current_inputfile^.line_no; codegenerror:=false; current_module^.current_inputfile:=p^.inputfile; current_module^.current_inputfile^.line_no:=p^.line; aktswitches:=p^.pragmas; if not(p^.error) then begin procedures[p^.treetype](p); p^.error:=codegenerror; codegenerror:=codegenerror or oldcodegenerror; end else codegenerror:=true; aktswitches:=oldswitches; current_module^.current_inputfile:=oldis; current_module^.current_inputfile^.line_no:=oldnr; 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; regvars_para : array[1..maxvarregs] of boolean; regvars_refs : array[1..maxvarregs] of longint; parasym : boolean; procedure searchregvars(p : psym); var i,j,k : longint; begin if (p^.typ=varsym) and (pvarsym(p)^.regable) then begin { walk through all momentary register variables } for i:=1 to maxvarregs do begin { free register ? } if regvars[i]=nil then begin regvars[i]:=pvarsym(p); regvars_para[i]:=parasym; break; end; { else throw out a variable ? } j:=pvarsym(p)^.refs; { parameter get a less value } if parasym then begin if cs_littlesize in aktswitches then dec(j,1) else dec(j,100); end; if (j>regvars_refs[i]) and (j>0) then begin for k:=maxvarregs-1 downto i do begin regvars[k+1]:=regvars[k]; regvars_para[k+1]:=regvars_para[k]; end; { calc the new refs pvarsym(p)^.refs:=j; } regvars[i]:=pvarsym(p); regvars_para[i]:=parasym; regvars_refs[i]:=j; break; end; end; end; end; procedure generatecode(var p : ptree); var { *pass modifies with every node aktlinenr and current_module^.current_inputfile, } { to constantly contain the right line numbers } oldis : pinputfile; oldnr,i : longint; regsize : topsize; regi : tregister; hr : preference; label nextreg; begin cleartempgen; oldis:=current_module^.current_inputfile; oldnr:=current_module^.current_inputfile^.line_no; { when size optimization only count occurrence } if cs_littlesize in aktswitches then t_times:=1 else { reference for repetition is 100 } t_times:=100; { clear register count } {$ifdef SUPPORT_MMX} for regi:=R_EAX to R_MM6 do begin reg_pushes[regi]:=0; is_reg_var[regi]:=false; end; {$else SUPPORT_MMX} for regi:=R_EAX to R_EDI do begin reg_pushes[regi]:=0; is_reg_var[regi]:=false; end; {$endif SUPPORT_MMX} use_esp_stackframe:=false; if not(do_firstpass(p)) then begin { max. optimizations } { only if no asm is used } if (cs_maxoptimieren in aktswitches) and ((procinfo.flags and pi_uses_asm)=0) then begin { can we omit the stack frame ? } { conditions: 1. procedure (not main block) 2. no constructor or destructor 3. no call to other procedures 4. no interrupt handler } if assigned(aktprocsym) then begin if (aktprocsym^.definition^.options and poconstructor+podestructor+poinline+pointerrupt=0) and ((procinfo.flags and pi_do_call)=0) and (lexlevel>1) then begin { use ESP as frame pointer } procinfo.framepointer:=R_ESP; use_esp_stackframe:=true; { calc parameter distance new } dec(procinfo.framepointer_offset,4); dec(procinfo.ESI_offset,4); dec(procinfo.retoffset,4); dec(procinfo.call_offset,4); aktprocsym^.definition^.parast^.call_offset:=procinfo.call_offset; end; end; if (p^.registers32<4) then begin for i:=1 to maxvarregs do regvars[i]:=nil; parasym:=false; {$ifdef tp} symtablestack^.foreach(searchregvars); {$else} symtablestack^.foreach(@searchregvars); {$endif} { copy parameter into a register ? } parasym:=true; {$ifdef tp} symtablestack^.next^.foreach(searchregvars); {$else} symtablestack^.next^.foreach(@searchregvars); {$endif} { hold needed registers free } for i:=maxvarregs downto maxvarregs-p^.registers32+1 do regvars[i]:=nil; { now assign register } for i:=1 to maxvarregs-p^.registers32 do begin if assigned(regvars[i]) then begin { it is nonsens, to copy the variable to } { a register because we need then much } { pushes ? } if reg_pushes[varregs[i]]>=regvars[i]^.refs then begin regvars[i]:=nil; goto nextreg; end; { register is no longer available for } { expressions } { search the register which is the most } { unused } usableregs:=usableregs-[varregs[i]]; is_reg_var[varregs[i]]:=true; dec(c_usableregs); { possibly no 32 bit register are needed } if (regvars[i]^.definition^.deftype=orddef) and ( (porddef(regvars[i]^.definition)^.typ=bool8bit) or (porddef(regvars[i]^.definition)^.typ=uchar) or (porddef(regvars[i]^.definition)^.typ=u8bit) or (porddef(regvars[i]^.definition)^.typ=s8bit) ) then begin regvars[i]^.reg:=reg32toreg8(varregs[i]); regsize:=S_B; end else if (regvars[i]^.definition^.deftype=orddef) and ( (porddef(regvars[i]^.definition)^.typ=u16bit) or (porddef(regvars[i]^.definition)^.typ=s16bit) ) then begin regvars[i]^.reg:=reg32toreg16(varregs[i]); regsize:=S_W; end else begin regvars[i]^.reg:=varregs[i]; regsize:=S_L; end; { parameter must be load } if regvars_para[i] then begin { procinfo is there actual, } { because we can't never be in a } { nested procedure } { when loading parameter to reg } new(hr); reset_reference(hr^); hr^.offset:=pvarsym(regvars[i])^.address+procinfo.call_offset; hr^.base:=procinfo.framepointer; procinfo.aktentrycode^.concat(new(pai386,op_ref_reg(A_MOV,regsize, hr,regvars[i]^.reg))); unused:=unused - [regvars[i]^.reg]; end; { procedure uses this register } usedinproc:=usedinproc or ($80 shr byte(varregs[i])); end; nextreg: { dummy } regsize:=S_W; end; if (verbosity and v_debug)=v_debug then begin for i:=1 to maxvarregs do begin if assigned(regvars[i]) then Message3(cg_d_register_weight,reg2str(regvars[i]^.reg), tostr(regvars[i]^.refs),regvars[i]^.name); end; end; end; end; do_secondpass(p); { all registers can be used again } usableregs:=[R_EAX,R_EBX,R_ECX,R_EDX]; {$ifdef SUPPORT_MMX} usableregs:=usableregs+[R_MM0..R_MM6]; {$endif SUPPORT_MMX} c_usableregs:=4; end; procinfo.aktproccode^.concatlist(exprasmlist); current_module^.current_inputfile:=oldis; current_module^.current_inputfile^.line_no:=oldnr; end; end. { $Log: cgi386.pas,v $ Revision 1.3.2.2 1998/08/18 13:48:34 carl + Analizeset for big endian machines Revision 1.3.2.1 1998/07/29 12:22:49 carl * bug0130, bug0134 and bug0129 fixed Revision 1.3 1998/03/28 23:09:55 florian * secondin bugfix (m68k and i386) * overflow checking bugfix (m68k and i386) -- pretty useless in secondadd, since everything is done using 32-bit * loading pointer to routines hopefully fixed (m68k) * flags problem with calls to RTL internal routines fixed (still strcmp to fix) (m68k) * #ELSE was still incorrect (didn't take care of the previous level) * problem with filenames in the command line solved * problem with mangledname solved * linking name problem solved (was case insensitive) * double id problem and potential crash solved * stop after first error * and=>test problem removed * correct read for all float types * 2 sigsegv fixes and a cosmetic fix for Internal Error * push/pop is now correct optimized (=> mov (%esp),reg) Revision 1.2 1998/03/26 11:18:30 florian - switch -Sa removed - support of a:=b:=0 removed Revision 1.1.1.1 1998/03/25 11:18:13 root * Restored version Revision 1.58 1998/03/24 21:48:30 florian * just a couple of fixes applied: - problem with fixed16 solved - internalerror 10005 problem fixed - patch for assembler reading - small optimizer fix - mem is now supported Revision 1.57 1998/03/16 22:42:19 florian * some fixes of Peter applied: ofs problem, profiler support Revision 1.56 1998/03/13 22:45:57 florian * small bug fixes applied Revision 1.55 1998/03/11 22:22:51 florian * Fixed circular unit uses, when the units are not in the current dir (from Peter) * -i shows correct info, not anymore (from Peter) * linking with shared libs works again (from Peter) Revision 1.54 1998/03/10 23:48:35 florian * a couple of bug fixes to get the compiler with -OGaxz compiler, sadly enough, it doesn't run Revision 1.53 1998/03/10 16:27:37 pierre * better line info in stabs debug * symtabletype and lexlevel separated into two fields of tsymtable + ifdef MAKELIB for direct library output, not complete + ifdef CHAINPROCSYMS for overloaded seach across units, not fully working + ifdef TESTFUNCRET for setting func result in underfunction, not working Revision 1.52 1998/03/10 01:17:16 peter * all files have the same header * messages are fully implemented, EXTDEBUG uses Comment() + AG... files for the Assembler generation Revision 1.51 1998/03/09 10:44:37 peter + string='', string<>'', string:='', string:=char optimizes (the first 2 were already in cg68k2) Revision 1.50 1998/03/06 00:52:10 peter * replaced all old messages from errore.msg, only ExtDebug and some Comment() calls are left * fixed options.pas Revision 1.49 1998/03/04 01:34:56 peter * messages for unit-handling and assembler/linker * the compiler compiles without -dGDB, but doesn't work yet + -vh for Hint Revision 1.48 1998/03/03 20:36:51 florian * bug in second_smaller fixed Revision 1.47 1998/03/03 01:08:24 florian * bug0105 and bug0106 problem solved Revision 1.46 1998/03/02 01:48:24 peter * renamed target_DOS to target_GO32V1 + new verbose system, merged old errors and verbose units into one new verbose.pas, so errors.pas is obsolete Revision 1.45 1998/03/01 22:46:06 florian + some win95 linking stuff * a couple of bugs fixed: bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098 Revision 1.44 1998/02/24 16:49:57 peter * stackframe ommiting generated 'ret $-4' + timer.pp bp7 version * innr.inc are now the same files Revision 1.43 1998/02/22 23:03:12 peter * renamed msource->mainsource and name->unitname * optimized filename handling, filename is not seperate anymore with path+name+ext, this saves stackspace and a lot of fsplit()'s * recompiling of some units in libraries fixed * shared libraries are working again + $LINKLIB to support automatic linking to libraries + libraries are saved/read from the ppufile, also allows more libraries per ppufile Revision 1.42 1998/02/21 04:09:13 carl * stupid syntax error fix Revision 1.41 1998/02/20 20:35:14 carl * Fixed entry and exit code which was ALL messed up Revision 1.40 1998/02/19 12:15:08 daniel * Optimized a statement that did pain to my eyes. Revision 1.39 1998/02/17 21:20:40 peter + Script unit + __EXIT is called again to exit a program - target_info.link/assembler calls * linking works again for dos * optimized a few filehandling functions * fixed stabs generation for procedures Revision 1.38 1998/02/15 21:16:12 peter * all assembler outputs supported by assemblerobject * cleanup with assembleroutputs, better .ascii generation * help_constructor/destructor are now added to the externals - generation of asmresponse is not outputformat depended Revision 1.37 1998/02/14 01:45:15 peter * more fixes - pmode target is removed - search_as_ld is removed, this is done in the link.pas/assemble.pas + findexe() to search for an executable (linker,assembler,binder) Revision 1.36 1998/02/13 22:26:19 peter * fixed a few SigSegv's * INIT$$ was not written for linux! * assembling and linking works again for linux and dos + assembler object, only attasmi3 supported yet * restore pp.pas with AddPath etc. Revision 1.35 1998/02/13 10:34:50 daniel * Made Motorola version compilable. * Fixed optimizer Revision 1.34 1998/02/12 17:18:57 florian * fixed to get remake3 work, but needs additional fixes (output, I don't like also that aktswitches isn't a pointer) Revision 1.33 1998/02/12 11:49:56 daniel Yes! Finally! After three retries, my patch! Changes: Complete rewrite of psub.pas. Added support for DLL's. Compiler requires less memory. Platform units for each platform. Revision 1.23 1998/02/01 19:39:50 florian * clean up * bug0029 fixed Revision 1.22 1998/01/27 22:02:29 florian * small bug fix to the compiler work, I forgot a not(...):( Revision 1.21 1998/01/27 10:49:15 florian *** empty log message *** Revision 1.20 1998/01/26 17:29:14 florian * Peter's fix for bug0046 applied Revision 1.19 1998/01/25 22:28:55 florian * a lot bug fixes on the DOM Revision 1.18 1998/01/21 21:29:50 florian * some fixes for Delphi classes Revision 1.17 1998/01/20 23:53:04 carl * bugfix 74 (FINAL, the one from Pierre was incomplete under BP) Revision 1.16 1998/01/19 10:25:14 pierre * bug in object function call in main program or unit init fixed Revision 1.15 1998/01/16 22:34:29 michael * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on in this compiler :) Revision 1.14 1998/01/16 18:03:11 florian * small bug fixes, some stuff of delphi styled constructores added Revision 1.13 1998/01/13 23:11:05 florian + class methods Revision 1.12 1998/01/07 00:16:44 michael Restored released version (plus fixes) as current Revision 1.10 1997/12/13 18:59:42 florian + I/O streams are now also declared as external, if neccessary * -Aobj generates now a correct obj file via nasm Revision 1.9 1997/12/10 23:07:16 florian * bugs fixed: 12,38 (also m68k),39,40,41 + warning if a system unit is without -Us compiled + warning if a method is virtual and private (was an error) * some indentions changed + factor does a better error recovering (omit some crashes) + problem with @type(x) removed (crashed the compiler) Revision 1.8 1997/12/09 13:35:47 carl + renamed pai_labeled386 to pai_labeled + renamed S_T to S_X Revision 1.7 1997/12/04 10:39:11 pierre + secondadd separated in file cgi386ad.inc Revision 1.5 1997/11/29 15:41:45 florian only small changes Revision 1.3 1997/11/28 15:43:15 florian Fixed stack ajustment bug, 0.9.8 compiles now 0.9.8 without problems. Revision 1.2 1997/11/28 14:26:19 florian Fixed some bugs Revision 1.1.1.1 1997/11/27 08:32:54 michael FPC Compiler CVS start Pre-CVS log: FK Florian Klaempfl PM Pierre Muller + feature added - removed * bug fixed or changed History (started with version 0.9.0): 23th october 1996: + some emit calls replaced (FK) 24th october 1996: * for bug fixed (FK) 26th october 1996: * english comments (FK) 5th november 1996: * new init and terminate code (FK) ...... some items missed 19th september 1997: * a call to a function procedure a;[ C ]; doesn't crash the stack furthermore (FK) * bug in var_reg assignment fixed did not keep p^.register32 registers free ! (PM) 22th september 1997: * stack layout for nested procedures in methods modified: ESI is no more pushed (must be loaded via framepointer) (FK) 24th september 1997: + strings constants in consts list to check for existing strings (PM) 24th september 1997: * constructor bug removed (FK) * source splitted (into cgi386 and cgi3862 for FPC) (FK) * line_no and inputfile are now in secondpass saved (FK) * patching error removed (the switch -Ox was always used because of a misplaced end) (FK) + strings constants in consts list to check for existing strings (PM) 25th september 1997: + secondload provides now the informations for open arrays (FK) + support of high for open arrays (FK) + the high parameter is now pushed for open arrays (FK) 3th october 1997: + function second_bool_to_byte for ord(boolean) (PM) 4th october 1997: + code for in_pred_x in_succ_x no bound check (PM) 13th october 1997: + added code for static modifier for objects variables and methods (PM) 14th october 1997: + second_bool_to_byte handles now also LOC_JUMP (FK) 28th october 1997: * in secondcallparan bug with param from read/write while nil defcoll^.data fixed (PM) 3rd november 1997: + added code for symdif for sets (PM) 28th october 1997: * in secondcallparan bug with param from read/write while nil defcoll^.data fixed (PM) 3rd november 1997: + added code for symdif for sets (PM) 12th november 1997: + added text write for boolean (PM) * bug in secondcallparan for LOC_FPU (assumed that the type was double) (PM) 13th november 1997: + added partial code for u32bit support (PM) 22th november 1997: * bug in stack alignment found (PM) }