{ $Id$ Copyright (c) 1998-2000 by Florian Klaempfl Generate i386 assembler for in call nodes This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published bymethodpointer the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit n386cal; {$i defines.inc} interface { $define AnsiStrRef} uses symdef,node,ncal; type ti386callparanode = class(tcallparanode) procedure secondcallparan(defcoll : TParaItem; push_from_left_to_right,inlined,is_cdecl : boolean; para_alignment,para_offset : longint);override; end; ti386callnode = class(tcallnode) procedure pass_2;override; end; ti386procinlinenode = class(tprocinlinenode) procedure pass_2;override; end; implementation uses {$ifdef delphi} sysutils, {$else} strings, {$endif} globtype,systems, cutils,verbose,globals, symconst,symbase,symsym,symtable,aasm,types, {$ifdef GDB} gdb, {$endif GDB} hcodegen,temp_gen,pass_2, cpubase,cpuasm, nmem,nld, cgai386,tgcpu,n386ld,n386util,regvars; {***************************************************************************** TI386CALLPARANODE *****************************************************************************} procedure ti386callparanode.secondcallparan(defcoll : TParaItem; push_from_left_to_right,inlined,is_cdecl : boolean;para_alignment,para_offset : longint); procedure maybe_push_high; begin { open array ? } { defcoll.data can be nil for read/write } if assigned(defcoll.paratype.def) and assigned(hightree) then begin secondpass(hightree); { this is a longint anyway ! } push_value_para(hightree,inlined,false,para_offset,4); end; end; var otlabel,oflabel : tasmlabel; { temporary variables: } tempdeftype : tdeftype; r : preference; begin { set default para_alignment to target_info.stackalignment } if para_alignment=0 then para_alignment:=aktalignment.paraalign; { push from left to right if specified } if push_from_left_to_right and assigned(right) then begin if (nf_varargs_para in flags) then tcallparanode(right).secondcallparan(defcoll,push_from_left_to_right, inlined,is_cdecl,para_alignment,para_offset) else tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right, inlined,is_cdecl,para_alignment,para_offset); end; otlabel:=truelabel; oflabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(left); { handle varargs first, because defcoll is not valid } if (nf_varargs_para in flags) then begin if push_addr_param(left.resulttype.def) then begin inc(pushedparasize,4); emitpushreferenceaddr(left.location.reference); del_reference(left.location.reference); end else push_value_para(left,inlined,is_cdecl,para_offset,para_alignment); end { filter array constructor with c styled args } else if is_array_constructor(left.resulttype.def) and (nf_cargs in left.flags) then begin { nothing, everything is already pushed } end { in codegen.handleread.. defcoll.data is set to nil } else if assigned(defcoll.paratype.def) and (defcoll.paratype.def.deftype=formaldef) then begin { allow @var } inc(pushedparasize,4); if (left.nodetype=addrn) and (not(nf_procvarload in left.flags)) then begin { always a register } if inlined then begin r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); emit_reg_ref(A_MOV,S_L, left.location.register,r); end else emit_reg(A_PUSH,S_L,left.location.register); ungetregister32(left.location.register); end else begin if not(left.location.loc in [LOC_MEM,LOC_REFERENCE]) then CGMessage(type_e_mismatch) else begin if inlined then begin getexplicitregister32(R_EDI); emit_ref_reg(A_LEA,S_L, newreference(left.location.reference),R_EDI); r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); emit_reg_ref(A_MOV,S_L,R_EDI,r); ungetregister32(R_EDI); end else emitpushreferenceaddr(left.location.reference); del_reference(left.location.reference); end; end; end { handle call by reference parameter } else if (defcoll.paratyp in [vs_var,vs_out]) then begin if (left.location.loc<>LOC_REFERENCE) then internalerror(200106041); maybe_push_high; if (defcoll.paratyp=vs_out) and assigned(defcoll.paratype.def) and not is_class(defcoll.paratype.def) and defcoll.paratype.def.needs_inittable then finalize(defcoll.paratype.def,left.location.reference,false); inc(pushedparasize,4); if inlined then begin getexplicitregister32(R_EDI); emit_ref_reg(A_LEA,S_L, newreference(left.location.reference),R_EDI); r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); emit_reg_ref(A_MOV,S_L,R_EDI,r); ungetregister32(R_EDI); end else emitpushreferenceaddr(left.location.reference); del_reference(left.location.reference); end else begin tempdeftype:=resulttype.def.deftype; if tempdeftype=filedef then CGMessage(cg_e_file_must_call_by_reference); { open array must always push the address, this is needed to also push addr of small open arrays and with cdecl functions (PFV) } if ( assigned(defcoll.paratype.def) and (is_open_array(defcoll.paratype.def) or is_array_of_const(defcoll.paratype.def)) ) or ( push_addr_param(resulttype.def) and not is_cdecl ) then begin maybe_push_high; inc(pushedparasize,4); if inlined then begin getexplicitregister32(R_EDI); emit_ref_reg(A_LEA,S_L, newreference(left.location.reference),R_EDI); r:=new_reference(procinfo^.framepointer,para_offset-pushedparasize); emit_reg_ref(A_MOV,S_L,R_EDI,r); ungetregister32(R_EDI); end else emitpushreferenceaddr(left.location.reference); del_reference(left.location.reference); end else begin push_value_para(left,inlined,is_cdecl, para_offset,para_alignment); end; end; truelabel:=otlabel; falselabel:=oflabel; { push from right to left } if not push_from_left_to_right and assigned(right) then begin if (nf_varargs_para in flags) then tcallparanode(right).secondcallparan(defcoll,push_from_left_to_right, inlined,is_cdecl,para_alignment,para_offset) else tcallparanode(right).secondcallparan(TParaItem(defcoll.next),push_from_left_to_right, inlined,is_cdecl,para_alignment,para_offset); end; end; {***************************************************************************** TI386CALLNODE *****************************************************************************} procedure ti386callnode.pass_2; var unusedregisters : tregisterset; usablecount : byte; pushed : tpushed; hr,funcretref : treference; hregister,hregister2 : 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 : tasmlabel; { lexlevel count } i : longint; { help reference pointer } r : preference; hp : tnode; pp : tbinarynode; params : tnode; inlined : boolean; inlinecode : tprocinlinenode; para_alignment, para_offset : longint; { instruction for alignement correction } { corr : paicpu;} { we must pop this size also after !! } { must_pop : boolean; } pop_size : longint; {$ifdef dummy} push_size : longint; {$endif} pop_esp : boolean; pop_allowed : boolean; regs_to_push : byte; constructorfailed : tasmlabel; label dont_call; begin reset_reference(location.reference); extended_new:=false; iolabel:=nil; inlinecode:=nil; inlined:=false; loadesi:=true; no_virtual_call:=false; unusedregisters:=unused; usablecount:=usablereg32; if ([pocall_cdecl,pocall_cppdecl,pocall_stdcall]*procdefinition.proccalloptions)<>[] then para_alignment:=4 else para_alignment:=aktalignment.paraalign; if not assigned(procdefinition) then exit; { Deciding whether we may still need the parameters happens next (JM) } if assigned(left) then params:=left.getcopy else params := nil; if (pocall_inline in procdefinition.proccalloptions) then begin inlined:=true; inlinecode:=tprocinlinenode(right); { set it to the same lexical level as the local symtable, becuase the para's are stored there } tprocdef(procdefinition).parast.symtablelevel:=aktprocsym.definition.localst.symtablelevel; if assigned(params) then inlinecode.para_offset:=gettempofsizepersistant(inlinecode.para_size); tprocdef(procdefinition).parast.address_fixup:=inlinecode.para_offset; {$ifdef extdebug} Comment(V_debug, 'inlined parasymtable is at offset ' +tostr(tprocdef(procdefinition).parast.address_fixup)); exprasmList.concat(Tai_asm_comment.Create( strpnew('inlined parasymtable is at offset ' +tostr(tprocdef(procdefinition).parast.address_fixup)))); {$endif extdebug} { disable further inlining of the same proc in the args } exclude(procdefinition.proccalloptions,pocall_inline); end; { only if no proc var } if inlined or not(assigned(right)) then is_con_or_destructor:=(procdefinition.proctypeoption in [potype_constructor,potype_destructor]); { proc variables destroy all registers } if (inlined or (right=nil)) and { virtual methods too } not(po_virtualmethod in procdefinition.procoptions) then begin if (cs_check_io in aktlocalswitches) and (po_iocheck in procdefinition.procoptions) and not(po_iocheck in aktprocsym.definition.procoptions) then begin getaddrlabel(iolabel); emitlab(iolabel); end else iolabel:=nil; { save all used registers } regs_to_push := tprocdef(procdefinition).usedregisters; pushusedregisters(pushed,regs_to_push); { give used registers through } usedinproc:=usedinproc or tprocdef(procdefinition).usedregisters; end else begin regs_to_push := $ff; pushusedregisters(pushed,regs_to_push); 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; pop_size:=0; { no inc esp for inlined procedure and for objects constructors PM } if (inlined or (right=nil)) and (procdefinition.proctypeoption=potype_constructor) and { quick'n'dirty check if it is a class or an object } (resulttype.def.deftype=orddef) then pop_allowed:=false else pop_allowed:=true; if pop_allowed then begin { Old pushedsize aligned on 4 ? } i:=oldpushedparasize and 3; if i>0 then inc(pop_size,4-i); { This parasize aligned on 4 ? } i:=procdefinition.para_size(para_alignment) and 3; if i>0 then inc(pop_size,4-i); { insert the opcode and update pushedparasize } { never push 4 or more !! } pop_size:=pop_size mod 4; if pop_size>0 then begin inc(pushedparasize,pop_size); emit_const_reg(A_SUB,S_L,pop_size,R_ESP); {$ifdef GDB} if (cs_debuginfo in aktmoduleswitches) and (exprasmList.first=exprasmList.last) then exprasmList.concat(Tai_force_line.Create); {$endif GDB} end; end; {$ifdef dummy} if pop_allowed and (cs_align in aktglobalswitches) then begin pop_esp:=true; push_size:=procdefinition.para_size(para_alignment); { !!!! here we have to take care of return type, self and nested procedures } inc(push_size,12); emit_reg_reg(A_MOV,S_L,R_ESP,R_EDI); if (push_size mod 8)=0 then emit_const_reg(A_AND,S_L,longint($fffffff8),R_ESP) else begin emit_const_reg(A_SUB,S_L,push_size,R_ESP); emit_const_reg(A_AND,S_L,longint($fffffff8),R_ESP); emit_const_reg(A_SUB,S_L,push_size,R_ESP); end; emit_reg(A_PUSH,S_L,R_EDI); end else {$endif dummy} pop_esp:=false; if (not is_void(resulttype.def)) and ret_in_param(resulttype.def) 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} if inlined then begin reset_reference(funcretref); funcretref.offset:=gettempofsizepersistant(procdefinition.rettype.def.size); funcretref.base:=procinfo^.framepointer; end else gettempofsizereference(procdefinition.rettype.def.size,funcretref); end; if assigned(params) then begin { be found elsewhere } if inlined then para_offset:=tprocdef(procdefinition).parast.address_fixup+ tprocdef(procdefinition).parast.datasize else para_offset:=0; if not(inlined) and assigned(right) then tcallparanode(params).secondcallparan(TParaItem(tabstractprocdef(right.resulttype.def).Para.first), (pocall_leftright in procdefinition.proccalloptions),inlined, (([pocall_cdecl,pocall_cppdecl]*procdefinition.proccalloptions)<>[]), para_alignment,para_offset) else tcallparanode(params).secondcallparan(TParaItem(procdefinition.Para.first), (pocall_leftright in procdefinition.proccalloptions),inlined, (([pocall_cdecl,pocall_cppdecl]*procdefinition.proccalloptions)<>[]), para_alignment,para_offset); end; if inlined then inlinecode.retoffset:=gettempofsizepersistant(Align(resulttype.def.size,aktalignment.paraalign)); if ret_in_param(resulttype.def) then begin { This must not be counted for C code complex return address is removed from stack by function itself ! } {$ifdef OLD_C_STACK} inc(pushedparasize,4); { lets try without it PM } {$endif not OLD_C_STACK} if inlined then begin getexplicitregister32(R_EDI); emit_ref_reg(A_LEA,S_L, newreference(funcretref),R_EDI); r:=new_reference(procinfo^.framepointer,inlinecode.retoffset); emit_reg_ref(A_MOV,S_L,R_EDI,r); ungetregister32(R_EDI); end else emitpushreferenceaddr(funcretref); end; { procedure variable ? } if inlined or (right=nil) then begin { overloaded operator have no symtable } { push self } if assigned(symtableproc) and (symtableproc.symtabletype=withsymtable) then begin { dirty trick to avoid the secondcall below } methodpointer:=ccallparanode.create(nil,nil); methodpointer.location.loc:=LOC_REGISTER; getexplicitregister32(R_ESI); methodpointer.location.register:=R_ESI; { ARGHHH this is wrong !!! if we can init from base class for a child class that the wrong VMT will be transfered to constructor !! } methodpointer.resulttype:= twithnode(twithsymtable(symtableproc).withnode).left.resulttype; { make a reference } new(r); reset_reference(r^); { if assigned(ptree(twithsymtable(symtable).withnode)^.pref) then begin r^:=ptree(twithsymtable(symtable).withnode)^.pref^; end else begin r^.offset:=symtable.datasize; r^.base:=procinfo^.framepointer; end; } r^:=twithnode(twithsymtable(symtableproc).withnode).withreference^; if ((not(nf_islocal in twithnode(twithsymtable(symtableproc).withnode).flags)) and (not twithsymtable(symtableproc).direct_with)) or is_class_or_interface(methodpointer.resulttype.def) then emit_ref_reg(A_MOV,S_L,r,R_ESI) else emit_ref_reg(A_LEA,S_L,r,R_ESI); end; { push self } if assigned(symtableproc) and ((symtableproc.symtabletype=objectsymtable) or (symtableproc.symtabletype=withsymtable)) then begin if assigned(methodpointer) then begin { if methodpointer^.resulttype.def=classrefdef then begin two possibilities: 1. constructor 2. class method end else } begin case methodpointer.nodetype of typen: begin { direct call to inherited method } if (po_abstractmethod in procdefinition.procoptions) then begin CGMessage(cg_e_cant_call_abstract_method); goto dont_call; end; { generate no virtual call } no_virtual_call:=true; if (sp_static in symtableprocentry.symoptions) 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; { if no VMT just use $0 bug0214 PM } getexplicitregister32(R_ESI); if not(oo_has_vmt in tobjectdef(methodpointer.resulttype.def).objectoptions) then emit_const_reg(A_MOV,S_L,0,R_ESI) else begin emit_sym_ofs_reg(A_MOV,S_L, newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname), 0,R_ESI); end; { emit_reg(A_PUSH,S_L,R_ESI); this is done below !! } end else { this is a member call, so ESI isn't modfied } loadesi:=false; { a class destructor needs a flag } if is_class(tobjectdef(methodpointer.resulttype.def)) and {assigned(aktprocsym) and (aktprocsym.definition.proctypeoption=potype_destructor)} (procdefinition.proctypeoption=potype_destructor) then begin push_int(0); emit_reg(A_PUSH,S_L,R_ESI); end; if not(is_con_or_destructor and is_class(methodpointer.resulttype.def) and {assigned(aktprocsym) and (aktprocsym.definition.proctypeoption in [potype_constructor,potype_destructor])} (procdefinition.proctypeoption in [potype_constructor,potype_destructor]) ) then emit_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 is_object(methodpointer.resulttype.def) and assigned(aktprocsym) then begin if not(aktprocsym.definition.proctypeoption in [potype_constructor,potype_destructor]) then CGMessage(cg_w_member_cd_call_from_method); end; { class destructors get there flag above } { constructor flags ? } if is_con_or_destructor and not( is_class(methodpointer.resulttype.def) and assigned(aktprocsym) and (aktprocsym.definition.proctypeoption=potype_destructor)) then begin { a constructor needs also a flag } if is_class(methodpointer.resulttype.def) then push_int(0); push_int(0); end; end; hnewn: begin { extended syntax of new } { ESI must be zero } getexplicitregister32(R_ESI); emit_reg_reg(A_XOR,S_L,R_ESI,R_ESI); emit_reg(A_PUSH,S_L,R_ESI); { insert the vmt } emit_sym(A_PUSH,S_L, newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname)); extended_new:=true; end; hdisposen: begin secondpass(methodpointer); { destructor with extended syntax called from dispose } { hdisposen always deliver LOC_REFERENCE } getexplicitregister32(R_ESI); emit_ref_reg(A_LEA,S_L, newreference(methodpointer.location.reference),R_ESI); del_reference(methodpointer.location.reference); emit_reg(A_PUSH,S_L,R_ESI); emit_sym(A_PUSH,S_L, newasmsymbol(tobjectdef(methodpointer.resulttype.def).vmt_mangledname)); end; else begin { call to an instance member } if (symtableproc.symtabletype<>withsymtable) then begin secondpass(methodpointer); getexplicitregister32(R_ESI); case methodpointer.location.loc of LOC_CREGISTER, LOC_REGISTER: begin emit_reg_reg(A_MOV,S_L,methodpointer.location.register,R_ESI); ungetregister32(methodpointer.location.register); end; else begin if (methodpointer.resulttype.def.deftype=classrefdef) or is_class_or_interface(methodpointer.resulttype.def) then emit_ref_reg(A_MOV,S_L, newreference(methodpointer.location.reference),R_ESI) else emit_ref_reg(A_LEA,S_L, newreference(methodpointer.location.reference),R_ESI); del_reference(methodpointer.location.reference); end; end; end; { when calling a class method, we have to load ESI with the VMT ! But, not for a class method via self } if not(po_containsself in procdefinition.procoptions) then begin if (po_classmethod in procdefinition.procoptions) and not(methodpointer.resulttype.def.deftype=classrefdef) then begin { class method needs current VMT } getexplicitregister32(R_ESI); new(r); reset_reference(r^); r^.base:=R_ESI; r^.offset:= tprocdef(procdefinition)._class.vmt_offset; emit_ref_reg(A_MOV,S_L,r,R_ESI); end; { direct call to destructor: remove data } if (procdefinition.proctypeoption=potype_destructor) and is_class(methodpointer.resulttype.def) then emit_const(A_PUSH,S_L,1); { direct call to class constructor, don't allocate memory } if (procdefinition.proctypeoption=potype_constructor) and is_class(methodpointer.resulttype.def) then begin emit_const(A_PUSH,S_L,0); emit_const(A_PUSH,S_L,0); end else begin { constructor call via classreference => allocate memory } if (procdefinition.proctypeoption=potype_constructor) and (methodpointer.resulttype.def.deftype=classrefdef) and is_class(tclassrefdef(methodpointer.resulttype.def).pointertype.def) then emit_const(A_PUSH,S_L,1); emit_reg(A_PUSH,S_L,R_ESI); end; end; if is_con_or_destructor then begin { classes don't get a VMT pointer pushed } if is_object(methodpointer.resulttype.def) then begin if (procdefinition.proctypeoption=potype_constructor) then begin { it's no bad idea, to insert the VMT } emit_sym(A_PUSH,S_L,newasmsymbol( tobjectdef(methodpointer.resulttype.def).vmt_mangledname)); 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 (po_classmethod in procdefinition.procoptions) and not( assigned(aktprocsym) and (po_classmethod in aktprocsym.definition.procoptions) ) then begin { class method needs current VMT } getexplicitregister32(R_ESI); new(r); reset_reference(r^); r^.base:=R_ESI; r^.offset:= tprocdef(procdefinition)._class.vmt_offset; emit_ref_reg(A_MOV,S_L,r,R_ESI); end else begin { member call, ESI isn't modified } loadesi:=false; end; { direct call to destructor: don't remove data! } if is_class(procinfo^._class) then begin if (procdefinition.proctypeoption=potype_destructor) then begin emit_const(A_PUSH,S_L,0); emit_reg(A_PUSH,S_L,R_ESI); end else if (procdefinition.proctypeoption=potype_constructor) then begin emit_const(A_PUSH,S_L,0); emit_const(A_PUSH,S_L,0); end else emit_reg(A_PUSH,S_L,R_ESI); end else if is_object(procinfo^._class) then begin emit_reg(A_PUSH,S_L,R_ESI); if is_con_or_destructor then begin if (procdefinition.proctypeoption=potype_constructor) then begin { it's no bad idea, to insert the VMT } emit_sym(A_PUSH,S_L,newasmsymbol( procinfo^._class.vmt_mangledname)); end { destructors haven't to dispose the instance, if this is } { a direct call } else push_int(0); end; end else Internalerror(200006165); end; end; { call to BeforeDestruction? } if (procdefinition.proctypeoption=potype_destructor) and assigned(methodpointer) and (methodpointer.nodetype<>typen) and is_class(tobjectdef(methodpointer.resulttype.def)) and (inlined or (right=nil)) then begin emit_reg(A_PUSH,S_L,R_ESI); new(r); reset_reference(r^); r^.base:=R_ESI; getexplicitregister32(R_EDI); emit_ref_reg(A_MOV,S_L,r,R_EDI); new(r); reset_reference(r^); r^.offset:=72; r^.base:=R_EDI; emit_ref(A_CALL,S_NO,r); ungetregister32(R_EDI); end; { push base pointer ?} if (lexlevel>=normal_function_level) and assigned(tprocdef(procdefinition).parast) and ((tprocdef(procdefinition).parast.symtablelevel)>normal_function_level) 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; emit_reg(A_PUSH,S_L,R_ESI); end; } if lexlevel=(tprocdef(procdefinition).parast.symtablelevel) then begin new(r); reset_reference(r^); r^.offset:=procinfo^.framepointer_offset; r^.base:=procinfo^.framepointer; emit_ref(A_PUSH,S_L,r) end { this is only true if the difference is one !! but it cannot be more !! } else if (lexlevel=tprocdef(procdefinition).parast.symtablelevel-1) then begin emit_reg(A_PUSH,S_L,procinfo^.framepointer) end else if (lexlevel>tprocdef(procdefinition).parast.symtablelevel) then begin hregister:=getregister32; new(r); reset_reference(r^); r^.offset:=procinfo^.framepointer_offset; r^.base:=procinfo^.framepointer; emit_ref_reg(A_MOV,S_L,r,hregister); for i:=(tprocdef(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; emit_ref_reg(A_MOV,S_L,r,hregister); end; emit_reg(A_PUSH,S_L,hregister); ungetregister32(hregister); end else internalerror(25000); end; saveregvars(regs_to_push); if (po_virtualmethod in procdefinition.procoptions) and not(no_virtual_call) then begin { static functions contain the vmt_address in ESI } { also class methods } { Here it is quite tricky because it also depends } { on the methodpointer PM } getexplicitregister32(R_ESI); if assigned(aktprocsym) then begin if (((sp_static in aktprocsym.symoptions) or (po_classmethod in aktprocsym.definition.procoptions)) and ((methodpointer=nil) or (methodpointer.nodetype=typen))) or (po_staticmethod in procdefinition.procoptions) or ((procdefinition.proctypeoption=potype_constructor) and { esi contains the vmt if we call a constructor via a class ref } assigned(methodpointer) and (methodpointer.resulttype.def.deftype=classrefdef) ) or { is_interface(tprocdef(procdefinition)._class) or } { ESI is loaded earlier } (po_classmethod in procdefinition.procoptions) then begin new(r); reset_reference(r^); r^.base:=R_ESI; end else begin new(r); reset_reference(r^); r^.base:=R_ESI; { this is one point where we need vmt_offset (PM) } r^.offset:= tprocdef(procdefinition)._class.vmt_offset; getexplicitregister32(R_EDI); emit_ref_reg(A_MOV,S_L,r,R_EDI); new(r); reset_reference(r^); r^.base:=R_EDI; end; end else { aktprocsym should be assigned, also in main program } internalerror(12345); { begin new(r); reset_reference(r^); r^.base:=R_ESI; emit_ref_reg(A_MOV,S_L,r,R_EDI); new(r); reset_reference(r^); r^.base:=R_EDI; end; } if tprocdef(procdefinition).extnumber=-1 then internalerror(44584); r^.offset:=tprocdef(procdefinition)._class.vmtmethodoffset(tprocdef(procdefinition).extnumber); if not(is_interface(tprocdef(procdefinition)._class)) and not(is_cppclass(tprocdef(procdefinition)._class)) then begin if (cs_check_object_ext in aktlocalswitches) then begin emit_sym(A_PUSH,S_L, newasmsymbol(tprocdef(procdefinition)._class.vmt_mangledname)); emit_reg(A_PUSH,S_L,r^.base); emitcall('FPC_CHECK_OBJECT_EXT'); end else if (cs_check_range in aktlocalswitches) then begin emit_reg(A_PUSH,S_L,r^.base); emitcall('FPC_CHECK_OBJECT'); end; end; emit_ref(A_CALL,S_NO,r); ungetregister32(R_EDI); end else if not inlined then begin { We can call interrupts from within the smae code by just pushing the flags and CS PM } if (po_interrupt in procdefinition.procoptions) then begin emit_none(A_PUSHF,S_L); emit_reg(A_PUSH,S_L,R_CS); end; emitcall(tprocdef(procdefinition).mangledname); end else { inlined proc } { inlined code is in inlinecode } begin { set poinline again } include(procdefinition.proccalloptions,pocall_inline); { process the inlinecode } secondpass(inlinecode); { free the args } if tprocdef(procdefinition).parast.datasize>0 then ungetpersistanttemp(tprocdef(procdefinition).parast.address_fixup); end; end else { now procedure variable case } begin secondpass(right); if (po_interrupt in procdefinition.procoptions) then begin emit_none(A_PUSHF,S_L); emit_reg(A_PUSH,S_L,R_CS); end; { procedure of object? } if (po_methodpointer in procdefinition.procoptions) then begin { method pointer can't be in a register } hregister:=R_NO; { do some hacking if we call a method pointer } { which is a class member } { else ESI is overwritten ! } if (right.location.reference.base=R_ESI) or (right.location.reference.index=R_ESI) then begin del_reference(right.location.reference); getexplicitregister32(R_EDI); emit_ref_reg(A_MOV,S_L, newreference(right.location.reference),R_EDI); hregister:=R_EDI; end; { load self, but not if it's already explicitly pushed } if not(po_containsself in procdefinition.procoptions) then begin { load ESI } inc(right.location.reference.offset,4); getexplicitregister32(R_ESI); emit_ref_reg(A_MOV,S_L, newreference(right.location.reference),R_ESI); dec(right.location.reference.offset,4); { push self pointer } emit_reg(A_PUSH,S_L,R_ESI); end; saveregvars($ff); if hregister=R_NO then emit_ref(A_CALL,S_NO,newreference(right.location.reference)) else begin ungetregister32(hregister); emit_reg(A_CALL,S_NO,hregister); end; del_reference(right.location.reference); end else begin saveregvars($ff); case right.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_CALL,S_NO,right.location.register); ungetregister32(right.location.register); end else begin emit_ref(A_CALL,S_NO,newreference(right.location.reference)); del_reference(right.location.reference); end; end; end; end; { this was only for normal functions displaced here so we also get it to work for procvars PM } if (not inlined) and (pocall_clearstack in procdefinition.proccalloptions) then begin { we also add the pop_size which is included in pushedparasize } pop_size:=0; { better than an add on all processors } if pushedparasize=4 then begin getexplicitregister32(R_EDI); emit_reg(A_POP,S_L,R_EDI); ungetregister32(R_EDI); end { 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 aktglobalswitches) and (aktoptprocessor=ClassP5) and (procinfo^._class=nil) then begin getexplicitregister32(R_EDI); emit_reg(A_POP,S_L,R_EDI); ungetregister32(R_EDI); exprasmList.concat(Tairegalloc.Alloc(R_ESI)); emit_reg(A_POP,S_L,R_ESI); exprasmList.concat(Tairegalloc.Alloc(R_ESI)); end else if pushedparasize<>0 then emit_const_reg(A_ADD,S_L,pushedparasize,R_ESP); end; if pop_esp then emit_reg(A_POP,S_L,R_ESP); dont_call: pushedparasize:=oldpushedparasize; unused:=unusedregisters; usablereg32:=usablecount; {$ifdef TEMPREGDEBUG} testregisters32; {$endif TEMPREGDEBUG} { a constructor could be a function with boolean result } { if calling constructor called fail we must jump directly to quickexitlabel PM but only if it is a call of an inherited constructor } if (inlined or (right=nil)) and (procdefinition.proctypeoption=potype_constructor) and assigned(methodpointer) and (methodpointer.nodetype=typen) and (aktprocsym.definition.proctypeoption=potype_constructor) then begin emitjmp(C_Z,faillabel); end; { call to AfterConstruction? } if is_class(resulttype.def) and (inlined or (right=nil)) and (procdefinition.proctypeoption=potype_constructor) and assigned(methodpointer) and (methodpointer.nodetype<>typen) then begin getlabel(constructorfailed); emitjmp(C_Z,constructorfailed); emit_reg(A_PUSH,S_L,R_ESI); new(r); reset_reference(r^); r^.base:=R_ESI; getexplicitregister32(R_EDI); emit_ref_reg(A_MOV,S_L,r,R_EDI); new(r); reset_reference(r^); r^.offset:=68; r^.base:=R_EDI; emit_ref(A_CALL,S_NO,r); ungetregister32(R_EDI); exprasmList.concat(Tairegalloc.Alloc(R_EAX)); emitlab(constructorfailed); emit_reg_reg(A_MOV,S_L,R_ESI,R_EAX); end; { handle function results } { structured results are easy to handle.... } { needed also when result_no_used !! } if (not is_void(resulttype.def)) and ret_in_param(resulttype.def) then begin location.loc:=LOC_MEM; location.reference.symbol:=nil; location.reference:=funcretref; end; { we have only to handle the result if it is used, but } { ansi/widestrings must be registered, so we can dispose them } if (not is_void(resulttype.def)) and ((nf_return_value_used in flags) or is_ansistring(resulttype.def) or is_widestring(resulttype.def)) then begin { a contructor could be a function with boolean result } if (inlined or (right=nil)) and (procdefinition.proctypeoption=potype_constructor) and { quick'n'dirty check if it is a class or an object } (resulttype.def.deftype=orddef) then begin { this fails if popsize > 0 PM } location.loc:=LOC_FLAGS; 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:=getexplicitregister32(R_EAX); emit_reg_reg(A_MOV,S_L,R_EAX,hregister); location.register:=hregister; end; end; end { structed results are easy to handle.... } else if ret_in_param(resulttype.def) then begin {location.loc:=LOC_MEM; stringdispose(location.reference.symbol); location.reference:=funcretref; already done above (PM) } end else begin if (resulttype.def.deftype in [orddef,enumdef]) then begin location.loc:=LOC_REGISTER; case resulttype.def.size of 4 : 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:=getexplicitregister32(R_EAX); emit_reg_reg(A_MOV,S_L,R_EAX,hregister); location.register:=hregister; end; end; 1 : 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:=getexplicitregister32(R_EAX); emit_reg_reg(A_MOV,S_B,R_AL,reg32toreg8(hregister)); location.register:=reg32toreg8(hregister); end; end; 2 : 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:=getexplicitregister32(R_EAX); emit_reg_reg(A_MOV,S_W,R_AX,reg32toreg16(hregister)); location.register:=reg32toreg16(hregister); end; end; 8 : begin {$ifdef test_dest_loc} {$error Don't know what to do here} {$endif test_dest_loc} if R_EDX in unused then begin hregister2:=getexplicitregister32(R_EDX); hregister:=getexplicitregister32(R_EAX); end else begin hregister:=getexplicitregister32(R_EAX); hregister2:=getexplicitregister32(R_EDX); end; emit_reg_reg(A_MOV,S_L,R_EAX,hregister); emit_reg_reg(A_MOV,S_L,R_EDX,hregister2); location.registerlow:=hregister; location.registerhigh:=hregister2; end; else internalerror(7); end end else if (resulttype.def.deftype=floatdef) then begin location.loc:=LOC_FPU; inc(fpuvaroffset); end else if is_ansistring(resulttype.def) or is_widestring(resulttype.def) then begin hregister:=getexplicitregister32(R_EAX); emit_reg_reg(A_MOV,S_L,R_EAX,hregister); if tstringdef(resulttype.def).string_typ=st_widestring then begin gettempwidestringreference(hr); decrstringref(resulttype.def,hr); end else begin gettempansistringreference(hr); decrstringref(resulttype.def,hr); end; emit_reg_ref(A_MOV,S_L,hregister, newreference(hr)); ungetregister32(hregister); location.loc:=LOC_MEM; location.reference:=hr; end else begin 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:=getexplicitregister32(R_EAX); emit_reg_reg(A_MOV,S_L,R_EAX,hregister); location.register:=hregister; end; end; end; end; { perhaps i/o check ? } if iolabel<>nil then begin emit_sym(A_PUSH,S_L,iolabel); emitcall('FPC_IOCHECK'); end; if pop_size>0 then emit_const_reg(A_ADD,S_L,pop_size,R_ESP); { restore registers } popusedregisters(pushed); { at last, restore instance pointer (SELF) } if loadesi then maybe_loadself; pp:=tbinarynode(params); while assigned(pp) do begin if assigned(pp.left) then begin if (pp.left.location.loc in [LOC_REFERENCE,LOC_MEM]) then ungetiftemp(pp.left.location.reference); { process also all nodes of an array of const } if pp.left.nodetype=arrayconstructorn then begin if assigned(tarrayconstructornode(pp.left).left) then begin hp:=pp.left; while assigned(hp) do begin if (tarrayconstructornode(tunarynode(hp).left).location.loc in [LOC_REFERENCE,LOC_MEM]) then ungetiftemp(tarrayconstructornode(hp).left.location.reference); hp:=tbinarynode(hp).right; end; end; end; end; pp:=tbinarynode(pp.right); end; if inlined then ungetpersistanttemp(inlinecode.retoffset); if assigned(params) then params.free; { from now on the result can be freed normally } if inlined and ret_in_param(resulttype.def) then persistanttemptonormal(funcretref.offset); { if return value is not used } if (not(nf_return_value_used in flags)) and (not is_void(resulttype.def)) then begin if location.loc in [LOC_MEM,LOC_REFERENCE] then begin { data which must be finalized ? } if (resulttype.def.needs_inittable) then finalize(resulttype.def,location.reference,false); { release unused temp } ungetiftemp(location.reference) end else if location.loc=LOC_FPU then begin { release FPU stack } emit_reg(A_FSTP,S_NO,R_ST0); { dec(fpuvaroffset); do NOT decrement as the increment before is not called for unused results PM } end; end; end; {***************************************************************************** TI386PROCINLINENODE *****************************************************************************} procedure ti386procinlinenode.pass_2; var st : tsymtable; oldprocsym : tprocsym; ps, i : longint; tmpreg: tregister; oldprocinfo : pprocinfo; oldinlining_procedure, nostackframe,make_global : boolean; inlineentrycode,inlineexitcode : TAAsmoutput; oldexitlabel,oldexit2label,oldquickexitlabel:tasmlabel; oldunused,oldusableregs : tregisterset; oldc_usableregs : longint; oldreg_pushes : regvar_longintarray; oldregvar_loaded, oldis_reg_var : regvar_booleanarray; {$ifdef TEMPREGDEBUG} oldreg_user : regvar_ptreearray; oldreg_releaser : regvar_ptreearray; {$endif TEMPREGDEBUG} {$ifdef GDB} startlabel,endlabel : tasmlabel; pp : pchar; mangled_length : longint; {$endif GDB} begin { deallocate the registers used for the current procedure's regvars } if assigned(aktprocsym.definition.regvarinfo) then begin with pregvarinfo(aktprocsym.definition.regvarinfo)^ do for i := 1 to maxvarregs do if assigned(regvars[i]) then store_regvar(exprasmlist,regvars[i].reg); oldunused := unused; oldusableregs := usableregs; oldc_usableregs := c_usableregs; oldreg_pushes := reg_pushes; oldis_reg_var := is_reg_var; oldregvar_loaded := regvar_loaded; {$ifdef TEMPREGDEBUG} oldreg_user := reg_user; oldreg_releaser := reg_releaser; {$endif TEMPREGDEBUG} { make sure the register allocator knows what the regvars in the } { inlined code block are (JM) } resetusableregisters; clearregistercount; cleartempgen; if assigned(inlineprocsym.definition.regvarinfo) then with pregvarinfo(inlineprocsym.definition.regvarinfo)^ do for i := 1 to maxvarregs do if assigned(regvars[i]) then begin case regsize(regvars[i].reg) of S_B: tmpreg := reg8toreg32(regvars[i].reg); S_W: tmpreg := reg16toreg32(regvars[i].reg); S_L: tmpreg := regvars[i].reg; end; usableregs:=usableregs-[tmpreg]; is_reg_var[tmpreg]:=true; dec(c_usableregs); end; end; oldinlining_procedure:=inlining_procedure; oldexitlabel:=aktexitlabel; oldexit2label:=aktexit2label; oldquickexitlabel:=quickexitlabel; getlabel(aktexitlabel); getlabel(aktexit2label); oldprocsym:=aktprocsym; { we're inlining a procedure } inlining_procedure:=true; { save old procinfo } getmem(oldprocinfo,sizeof(tprocinfo)); move(procinfo^,oldprocinfo^,sizeof(tprocinfo)); { set the return value } aktprocsym:=inlineprocsym; procinfo^.returntype:=aktprocsym.definition.rettype; procinfo^.return_offset:=retoffset; procinfo^.para_offset:=para_offset; { arg space has been filled by the parent secondcall } st:=aktprocsym.definition.localst; { set it to the same lexical level } st.symtablelevel:=oldprocsym.definition.localst.symtablelevel; if st.datasize>0 then begin st.address_fixup:=gettempofsizepersistant(st.datasize)+st.datasize; {$ifdef extdebug} Comment(V_debug,'local symtable is at offset '+tostr(st.address_fixup)); exprasmList.concat(Tai_asm_comment.Create(strpnew( 'local symtable is at offset '+tostr(st.address_fixup)))); {$endif extdebug} end; exprasmList.concat(Tai_Marker.Create(InlineStart)); {$ifdef extdebug} exprasmList.concat(Tai_asm_comment.Create(strpnew('Start of inlined proc'))); {$endif extdebug} {$ifdef GDB} if (cs_debuginfo in aktmoduleswitches) then begin getaddrlabel(startlabel); getaddrlabel(endlabel); emitlab(startlabel); inlineprocsym.definition.localst.symtabletype:=inlinelocalsymtable; inlineprocsym.definition.parast.symtabletype:=inlineparasymtable; { Here we must include the para and local symtable info } inlineprocsym.concatstabto(withdebuglist); { set it back for safety } inlineprocsym.definition.localst.symtabletype:=localsymtable; inlineprocsym.definition.parast.symtabletype:=parasymtable; mangled_length:=length(oldprocsym.definition.mangledname); getmem(pp,mangled_length+50); strpcopy(pp,'192,0,0,'+startlabel.name); if (target_info.use_function_relative_addresses) then begin strpcopy(strend(pp),'-'); strpcopy(strend(pp),oldprocsym.definition.mangledname); end; withdebugList.concat(Tai_stabn.Create(strnew(pp))); end; {$endif GDB} { takes care of local data initialization } inlineentrycode:=TAAsmoutput.Create; inlineexitcode:=TAAsmoutput.Create; ps:=para_size; make_global:=false; { to avoid warning } genentrycode(inlineentrycode,make_global,0,ps,nostackframe,true); if po_assembler in aktprocsym.definition.procoptions then inlineentrycode.insert(Tai_marker.Create(asmblockstart)); exprasmList.concatlist(inlineentrycode); secondpass(inlinetree); genexitcode(inlineexitcode,0,false,true); if po_assembler in aktprocsym.definition.procoptions then inlineexitcode.concat(Tai_marker.Create(asmblockend)); exprasmList.concatlist(inlineexitcode); inlineentrycode.free; inlineexitcode.free; {$ifdef extdebug} exprasmList.concat(Tai_asm_comment.Create(strpnew('End of inlined proc'))); {$endif extdebug} exprasmList.concat(Tai_Marker.Create(InlineEnd)); {we can free the local data now, reset also the fixup address } if st.datasize>0 then begin ungetpersistanttemp(st.address_fixup-st.datasize); st.address_fixup:=0; end; { restore procinfo } move(oldprocinfo^,procinfo^,sizeof(tprocinfo)); freemem(oldprocinfo,sizeof(tprocinfo)); {$ifdef GDB} if (cs_debuginfo in aktmoduleswitches) then begin emitlab(endlabel); strpcopy(pp,'224,0,0,'+endlabel.name); if (target_info.use_function_relative_addresses) then begin strpcopy(strend(pp),'-'); strpcopy(strend(pp),oldprocsym.definition.mangledname); end; withdebugList.concat(Tai_stabn.Create(strnew(pp))); freemem(pp,mangled_length+50); end; {$endif GDB} { restore } aktprocsym:=oldprocsym; aktexitlabel:=oldexitlabel; aktexit2label:=oldexit2label; quickexitlabel:=oldquickexitlabel; inlining_procedure:=oldinlining_procedure; { reallocate the registers used for the current procedure's regvars, } { since they may have been used and then deallocated in the inlined } { procedure (JM) } if assigned(aktprocsym.definition.regvarinfo) then begin unused := oldunused; usableregs := oldusableregs; c_usableregs := oldc_usableregs; reg_pushes := oldreg_pushes; is_reg_var := oldis_reg_var; regvar_loaded := oldregvar_loaded; {$ifdef TEMPREGDEBUG} reg_user := oldreg_user; reg_releaser := oldreg_releaser; {$endif TEMPREGDEBUG} end; end; begin ccallparanode:=ti386callparanode; ccallnode:=ti386callnode; cprocinlinenode:=ti386procinlinenode; end. { $Log$ Revision 1.27 2001-07-08 21:00:16 peter * various widestring updates, it works now mostly without charset mapping supported Revision 1.26 2001/07/01 20:16:20 peter * alignmentinfo record added * -Oa argument supports more alignment settings that can be specified per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN RECORDMAX,LOCALMIN,LOCALMAX. It is possible to set the mimimum required alignment and the maximum usefull alignment. The final alignment will be choosen per variable size dependent on these settings Revision 1.25 2001/06/04 11:48:02 peter * better const to var checking Revision 1.24 2001/05/19 21:22:53 peter * function returning int64 inlining fixed Revision 1.23 2001/05/16 15:11:42 jonas * added missign begin..end pair (noticed by Carl) Revision 1.22 2001/04/18 22:02:01 peter * registration of targets and assemblers Revision 1.21 2001/04/13 01:22:18 peter * symtable change to classes * range check generation and errors fixed, make cycle DEBUG=1 works * memory leaks fixed Revision 1.20 2001/04/02 21:20:36 peter * resulttype rewrite Revision 1.19 2001/03/11 22:58:51 peter * getsym redesign, removed the globals srsym,srsymtable Revision 1.18 2001/01/27 21:29:35 florian * behavior -Oa optimized Revision 1.17 2001/01/08 21:46:46 peter * don't push high value for open array with cdecl;external; Revision 1.16 2000/12/25 00:07:32 peter + new tlinkedlist class (merge of old tstringqueue,tcontainer and tlinkedlist objects) Revision 1.15 2000/12/09 10:45:40 florian * AfterConstructor isn't called anymore when a constructor failed Revision 1.14 2000/12/07 17:19:46 jonas * new constant handling: from now on, hex constants >$7fffffff are parsed as unsigned constants (otherwise, $80000000 got sign extended and became $ffffffff80000000), all constants in the longint range become longints, all constants >$7fffffff and <=cardinal($ffffffff) are cardinals and the rest are int64's. * added lots of longint typecast to prevent range check errors in the compiler and rtl * type casts of symbolic ordinal constants are now preserved * fixed bug where the original resulttype.def wasn't restored correctly after doing a 64bit rangecheck Revision 1.13 2000/12/05 11:44:33 jonas + new integer regvar handling, should be much more efficient Revision 1.12 2000/12/03 22:26:54 florian * fixed web buzg 1275: problem with int64 functions results Revision 1.11 2000/11/29 00:30:46 florian * unused units removed from uses clause * some changes for widestrings Revision 1.10 2000/11/23 13:26:34 jonas * fix for webbug 1066/1126 Revision 1.9 2000/11/22 15:12:06 jonas * fixed inline-related problems (partially "merges") Revision 1.8 2000/11/17 09:54:58 florian * INT_CHECK_OBJECT_* isn't applied to interfaces anymore Revision 1.7 2000/11/12 23:24:14 florian * interfaces are basically running Revision 1.6 2000/11/07 23:40:49 florian + AfterConstruction and BeforeDestruction impemented Revision 1.5 2000/11/06 23:15:01 peter * added copyvaluepara call again Revision 1.4 2000/11/04 14:25:23 florian + merged Attila's changes for interfaces, not tested yet Revision 1.3 2000/11/04 13:12:14 jonas * check for nil pointers before calling getcopy Revision 1.2 2000/10/31 22:02:56 peter * symtable splitted, no real code changes Revision 1.1 2000/10/15 09:33:31 peter * moved n386*.pas to i386/ cpu_target dir Revision 1.2 2000/10/14 10:14:48 peter * moehrendorf oct 2000 rewrite Revision 1.1 2000/10/10 17:31:56 florian * initial revision }