{ $Id$ Copyright (c) 1998-2000 by Florian Klaempfl Generate i386 assembler for type converting nodes This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } {$ifdef TP} {$E+,F+,N+,D+,L+,Y+} {$endif} unit cg386cnv; interface uses tree; procedure loadshortstring(p:ptree); procedure loadlongstring(p:ptree); procedure loadansi2short(source,dest : ptree); procedure secondtypeconv(var p : ptree); procedure secondas(var p : ptree); procedure secondis(var p : ptree); implementation uses cobjects,verbose,globtype,globals,systems, symconst,symtable,aasm,types, hcodegen,temp_gen,pass_2,pass_1, cpubase,cpuasm, cgai386,tgeni386; procedure push_shortstring_length(p:ptree); var hightree : ptree; begin if is_open_string(p^.resulttype) then begin getsymonlyin(p^.symtable,'high'+pvarsym(p^.symtableentry)^.name); hightree:=genloadnode(pvarsym(srsym),p^.symtable); firstpass(hightree); secondpass(hightree); push_value_para(hightree,false,false,0,4); disposetree(hightree); end else begin push_int(pstringdef(p^.resulttype)^.len); end; end; procedure loadshortstring(p:ptree); { Load a string, handles stringdef and orddef (char) types } begin case p^.right^.resulttype^.deftype of stringdef: begin if (p^.right^.treetype=stringconstn) and (str_length(p^.right)=0) then emit_const_ref( A_MOV,S_B,0,newreference(p^.left^.location.reference)) else begin emitpushreferenceaddr(p^.left^.location.reference); emitpushreferenceaddr(p^.right^.location.reference); push_shortstring_length(p^.left); emitcall('FPC_SHORTSTR_COPY'); maybe_loadesi; end; end; orddef: begin if p^.right^.treetype=ordconstn then emit_const_ref( A_MOV,S_W,p^.right^.value*256+1,newreference(p^.left^.location.reference)) else begin { not so elegant (goes better with extra register } {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} if (p^.right^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then begin emit_reg_reg(A_MOV,S_L,makereg32(p^.right^.location.register),R_EDI); ungetregister(p^.right^.location.register); end else begin emit_ref_reg(A_MOV,S_L,newreference(p^.right^.location.reference),R_EDI); del_reference(p^.right^.location.reference); end; emit_const_reg(A_SHL,S_L,8,R_EDI); emit_const_reg(A_OR,S_L,1,R_EDI); emit_reg_ref(A_MOV,S_W,R_DI,newreference(p^.left^.location.reference)); {$ifndef noAllocEdi} ungetregister32(R_EDI); {$endif noAllocEdi} end; end; else CGMessage(type_e_mismatch); end; end; procedure loadlongstring(p:ptree); { Load a string, handles stringdef and orddef (char) types } var r : preference; begin case p^.right^.resulttype^.deftype of stringdef: begin if (p^.right^.treetype=stringconstn) and (str_length(p^.right)=0) then emit_const_ref(A_MOV,S_L,0,newreference(p^.left^.location.reference)) else begin emitpushreferenceaddr(p^.left^.location.reference); emitpushreferenceaddr(p^.right^.location.reference); push_shortstring_length(p^.left); emitcall('FPC_LONGSTR_COPY'); maybe_loadesi; end; end; orddef: begin emit_const_ref(A_MOV,S_L,1,newreference(p^.left^.location.reference)); r:=newreference(p^.left^.location.reference); inc(r^.offset,4); if p^.right^.treetype=ordconstn then emit_const_ref(A_MOV,S_B,p^.right^.value,r) else begin case p^.right^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg_ref(A_MOV,S_B,p^.right^.location.register,r); ungetregister(p^.right^.location.register); end; LOC_MEM,LOC_REFERENCE: begin if not(R_EAX in unused) then emit_reg(A_PUSH,S_L,R_EAX); emit_ref_reg(A_MOV,S_B,newreference(p^.right^.location.reference),R_AL); emit_reg_ref(A_MOV,S_B,R_AL,r); if not(R_EAX in unused) then emit_reg(A_POP,S_L,R_EAX); del_reference(p^.right^.location.reference); end else internalerror(20799); end; end; end; else CGMessage(type_e_mismatch); end; end; procedure loadansi2short(source,dest : ptree); var pushed : tpushed; regs_to_push: byte; begin { Find out which registers have to be pushed (JM) } regs_to_push := $ff; remove_non_regvars_from_loc(source^.location,regs_to_push); remove_non_regvars_from_loc(dest^.location,regs_to_push); { Push them (JM) } pushusedregisters(pushed,regs_to_push); case source^.location.loc of LOC_REFERENCE,LOC_MEM: begin { Now release the location and registers (see cgai386.pas: } { loadansistring for more info on the order) (JM) } ungetiftemp(source^.location.reference); del_reference(source^.location.reference); emit_push_mem(source^.location.reference); end; LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH,S_L,source^.location.register); { Now release the register (JM) } ungetregister32(source^.location.register); end; end; push_shortstring_length(dest); emitpushreferenceaddr(dest^.location.reference); { Only now release the destination (JM) } del_reference(dest^.location.reference); emitcall('FPC_ANSISTR_TO_SHORTSTR'); popusedregisters(pushed); maybe_loadesi; end; {***************************************************************************** SecondTypeConv *****************************************************************************} type tsecondconvproc = procedure(var pto,pfrom : ptree;convtyp : tconverttype); procedure second_int_to_int(var pto,pfrom : ptree;convtyp : tconverttype); var op : tasmop; opsize : topsize; hregister, hregister2 : tregister; l : pasmlabel; begin { insert range check if not explicit conversion } if not(pto^.explizit) then emitrangecheck(pfrom,pto^.resulttype); { is the result size smaller ? } if pto^.resulttype^.sizepfrom^.resulttype^.size then begin { remove reference } if not(pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then begin del_reference(pfrom^.location.reference); { we can do this here as we need no temp inside } ungetiftemp(pfrom^.location.reference); end; { get op and opsize, handle separate for constants, because movz doesn't support constant values } if (pfrom^.location.loc=LOC_MEM) and (pfrom^.location.reference.is_immediate) then begin if is_64bitint(pto^.resulttype) then opsize:=S_L else opsize:=def_opsize(pto^.resulttype); op:=A_MOV; end else begin opsize:=def2def_opsize(pfrom^.resulttype,pto^.resulttype); if opsize in [S_B,S_W,S_L] then op:=A_MOV else if is_signed(pfrom^.resulttype) then op:=A_MOVSX else op:=A_MOVZX; end; { load the register we need } if pfrom^.location.loc<>LOC_REGISTER then hregister:=getregister32 else hregister:=pfrom^.location.register; { set the correct register size and location } clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; { do we need a second register for a 64 bit type ? } if is_64bitint(pto^.resulttype) then begin hregister2:=getregister32; pto^.location.registerhigh:=hregister2; end; case pto^.resulttype^.size of 1: pto^.location.register:=makereg8(hregister); 2: pto^.location.register:=makereg16(hregister); 4,8: pto^.location.register:=makereg32(hregister); end; { insert the assembler code } if pfrom^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then emit_reg_reg(op,opsize,pfrom^.location.register,pto^.location.register) else emit_ref_reg(op,opsize, newreference(pfrom^.location.reference),pto^.location.register); { do we need a sign extension for int64? } if is_64bitint(pto^.resulttype) then begin emit_reg_reg(A_XOR,S_L, hregister2,hregister2); if (porddef(pto^.resulttype)^.typ=s64bit) and is_signed(pfrom^.resulttype) then begin getlabel(l); emit_const_reg(A_TEST,S_L,$80000000,makereg32(hregister)); emitjmp(C_Z,l); emit_reg(A_NOT,S_L, hregister2); emitlab(l); end; end; end; end; procedure second_string_to_string(var pto,pfrom : ptree;convtyp : tconverttype); var pushed : tpushed; begin { does anybody know a better solution than this big case statement ? } { ok, a proc table would do the job } case pstringdef(pto^.resulttype)^.string_typ of st_shortstring: case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); copyshortstring(pto^.location.reference,pfrom^.location.reference, pstringdef(pto^.resulttype)^.len,false,true); { done by copyshortstring now (JM) } { del_reference(pfrom^.location.reference); } ungetiftemp(pfrom^.location.reference); end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_ansistring: begin gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); loadansi2short(pfrom,pto); { this is done in secondtypeconv (FK) removetemps(exprasmlist,temptoremove); destroys:=true; } end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; st_longstring: case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin {!!!!!!!} internalerror(8888); end; st_ansistring: begin {!!!!!!!} internalerror(8888); end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; st_ansistring: case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin clear_location(pto^.location); pto^.location.loc:=LOC_REFERENCE; gettempansistringreference(pto^.location.reference); decrstringref(cansistringdef,pto^.location.reference); pushusedregisters(pushed,$ff); emit_push_lea_loc(pfrom^.location,true); emit_push_lea_loc(pto^.location,false); emitcall('FPC_SHORTSTR_TO_ANSISTR'); maybe_loadesi; popusedregisters(pushed); end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; st_widestring: case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring: begin {!!!!!!!} internalerror(8888); end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_ansistring: begin {!!!!!!!} internalerror(8888); end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; end; end; procedure second_cstring_to_pchar(var pto,pfrom : ptree;convtyp : tconverttype); var hr : preference; begin clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; pto^.location.register:=getregister32; case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring : begin inc(pfrom^.location.reference.offset); emit_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference), pto^.location.register); end; st_ansistring : begin if (pfrom^.treetype=stringconstn) and (str_length(pfrom)=0) then begin new(hr); reset_reference(hr^); hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); emit_ref_reg(A_LEA,S_L,hr,pto^.location.register); end else emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), pto^.location.register); end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; end; procedure second_string_to_chararray(var pto,pfrom : ptree;convtyp : tconverttype); var l1 : pasmlabel; hr : preference; begin case pstringdef(pfrom^.resulttype)^.string_typ of st_shortstring : begin inc(pto^.location.reference.offset); end; st_ansistring : begin clear_location(pto^.location); pto^.location.loc:=LOC_REFERENCE; reset_reference(pto^.location.reference); getlabel(l1); case pfrom^.location.loc of LOC_CREGISTER,LOC_REGISTER: pto^.location.reference.base:=pfrom^.location.register; LOC_MEM,LOC_REFERENCE: begin pto^.location.reference.base:=getregister32; emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), pto^.location.reference.base); del_reference(pfrom^.location.reference); end; end; emit_const_reg(A_CMP,S_L,0,pto^.location.reference.base); emitjmp(C_NZ,l1); new(hr); reset_reference(hr^); hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); emit_ref_reg(A_LEA,S_L,hr,pto^.location.reference.base); emitlab(l1); end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; end; procedure second_array_to_pointer(var pto,pfrom : ptree;convtyp : tconverttype); begin del_reference(pfrom^.location.reference); clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; pto^.location.register:=getregister32; emit_ref_reg(A_LEA,S_L,newreference(pfrom^.location.reference), pto^.location.register); end; procedure second_pointer_to_array(var pto,pfrom : ptree;convtyp : tconverttype); begin clear_location(pto^.location); pto^.location.loc:=LOC_REFERENCE; reset_reference(pto^.location.reference); case pfrom^.location.loc of LOC_REGISTER : pto^.location.reference.base:=pfrom^.location.register; LOC_CREGISTER : begin pto^.location.reference.base:=getregister32; emit_reg_reg(A_MOV,S_L,pfrom^.location.register,pto^.location.reference.base); end else begin del_reference(pfrom^.location.reference); pto^.location.reference.base:=getregister32; emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), pto^.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(var pto,pfrom : ptree;convtyp : tconverttype); var pushed : tpushed; l : longint; begin { calc the length of the array } l:=parraydef(pfrom^.resulttype)^.highrange-parraydef(pfrom^.resulttype)^.lowrange+1; { this is a type conversion which copies the data, so we can't } { return a reference } clear_location(pto^.location); pto^.location.loc:=LOC_MEM; case pstringdef(pto^.resulttype)^.string_typ of st_shortstring : begin if l>255 then begin CGMessage(type_e_mismatch); l:=255; end; gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); pushusedregisters(pushed,$ff); if l>=pto^.resulttype^.size then push_int(pto^.resulttype^.size-1) else push_int(l); { we've also to release the registers ... } del_reference(pfrom^.location.reference); { ... here only the temp. location is released } emit_push_lea_loc(pfrom^.location,true); emitpushreferenceaddr(pto^.location.reference); emitcall('FPC_CHARARRAY_TO_SHORTSTR'); maybe_loadesi; popusedregisters(pushed); end; st_ansistring : begin gettempansistringreference(pto^.location.reference); decrstringref(cansistringdef,pto^.location.reference); release_loc(pfrom^.location); pushusedregisters(pushed,$ff); push_int(l); emitpushreferenceaddr(pfrom^.location.reference); emitpushreferenceaddr(pto^.location.reference); emitcall('FPC_CHARARRAY_TO_ANSISTR'); popusedregisters(pushed); maybe_loadesi; end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; end; procedure second_char_to_string(var pto,pfrom : ptree;convtyp : tconverttype); var pushed : tpushed; begin clear_location(pto^.location); pto^.location.loc:=LOC_MEM; case pstringdef(pto^.resulttype)^.string_typ of st_shortstring : begin gettempofsizereference(256,pto^.location.reference); { call loadstring with correct left and right } pto^.right:=pfrom; pto^.left:=pto; loadshortstring(pto); pto^.left:=nil; { reset left tree, which is empty } { pto^.right is not disposed for typeconv !! PM } disposetree(pto^.right); pto^.right:=nil; end; st_ansistring : begin gettempansistringreference(pto^.location.reference); decrstringref(cansistringdef,pto^.location.reference); release_loc(pfrom^.location); pushusedregisters(pushed,$ff); emit_pushw_loc(pfrom^.location); emitpushreferenceaddr(pto^.location.reference); emitcall('FPC_CHAR_TO_ANSISTR'); popusedregisters(pushed); maybe_loadesi; end; else internalerror(4179); end; end; procedure second_int_to_real(var pto,pfrom : ptree;convtyp : tconverttype); var r : preference; hregister : tregister; l1,l2 : pasmlabel; begin { for u32bit a solution is to push $0 and to load a comp } { does this first, it destroys maybe EDI } hregister:=R_EDI; if porddef(pfrom^.resulttype)^.typ=u32bit then push_int(0); if (pfrom^.location.loc=LOC_REGISTER) or (pfrom^.location.loc=LOC_CREGISTER) then begin {$ifndef noAllocEdi} if not (porddef(pfrom^.resulttype)^.typ in [u32bit,s32bit,u64bit,s64bit]) then getexplicitregister32(R_EDI); {$endif noAllocEdi} case porddef(pfrom^.resulttype)^.typ of s8bit : emit_reg_reg(A_MOVSX,S_BL,pfrom^.location.register,R_EDI); u8bit : emit_reg_reg(A_MOVZX,S_BL,pfrom^.location.register,R_EDI); s16bit : emit_reg_reg(A_MOVSX,S_WL,pfrom^.location.register,R_EDI); u16bit : emit_reg_reg(A_MOVZX,S_WL,pfrom^.location.register,R_EDI); u32bit,s32bit: hregister:=pfrom^.location.register; u64bit,s64bit: begin emit_reg(A_PUSH,S_L,pfrom^.location.registerhigh); hregister:=pfrom^.location.registerlow; end; end; ungetregister(pfrom^.location.register); end else begin r:=newreference(pfrom^.location.reference); {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} case porddef(pfrom^.resulttype)^.typ of s8bit: emit_ref_reg(A_MOVSX,S_BL,r,R_EDI); u8bit: emit_ref_reg(A_MOVZX,S_BL,r,R_EDI); s16bit: emit_ref_reg(A_MOVSX,S_WL,r,R_EDI); u16bit: emit_ref_reg(A_MOVZX,S_WL,r,R_EDI); u32bit,s32bit: emit_ref_reg(A_MOV,S_L,r,R_EDI); u64bit,s64bit: begin inc(r^.offset,4); emit_ref_reg(A_MOV,S_L,r,R_EDI); emit_reg(A_PUSH,S_L,R_EDI); r:=newreference(pfrom^.location.reference); emit_ref_reg(A_MOV,S_L,r,R_EDI); end; end; del_reference(pfrom^.location.reference); ungetiftemp(pfrom^.location.reference); end; { for 64 bit integers, the high dword is already pushed } emit_reg(A_PUSH,S_L,hregister); {$ifndef noAllocEdi} if hregister = R_EDI then ungetregister32(R_EDI); {$endif noAllocEdi} r:=new_reference(R_ESP,0); case porddef(pfrom^.resulttype)^.typ of u32bit: begin emit_ref(A_FILD,S_IQ,r); emit_const_reg(A_ADD,S_L,8,R_ESP); end; s64bit: begin emit_ref(A_FILD,S_IQ,r); emit_const_reg(A_ADD,S_L,8,R_ESP); end; u64bit: begin { unsigned 64 bit ints are harder to handle: } { we load bits 0..62 and then check bit 63: } { if it is 1 then we add $80000000 000000000 } { as double } inc(r^.offset,4); {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} emit_ref_reg(A_MOV,S_L,r,R_EDI); r:=new_reference(R_ESP,4); emit_const_ref(A_AND,S_L,$7fffffff,r); emit_const_reg(A_TEST,S_L,$80000000,R_EDI); {$ifndef noAllocEdi} ungetregister32(R_EDI); {$endif noAllocEdi} r:=new_reference(R_ESP,0); emit_ref(A_FILD,S_IQ,r); getdatalabel(l1); getlabel(l2); emitjmp(C_Z,l2); consts^.concat(new(pai_label,init(l1))); { I got this constant from a test progtram (FK) } consts^.concat(new(pai_const,init_32bit(0))); consts^.concat(new(pai_const,init_32bit(1138753536))); r:=new_reference(R_NO,0); r^.symbol:=l1; emit_ref(A_FADD,S_FL,r); emitlab(l2); emit_const_reg(A_ADD,S_L,8,R_ESP); end else begin emit_ref(A_FILD,S_IL,r); {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} emit_reg(A_POP,S_L,R_EDI); {$ifndef noAllocEdi} ungetregister32(R_EDI); {$endif noAllocEdi} end; end; inc(fpuvaroffset); clear_location(pto^.location); pto^.location.loc:=LOC_FPU; end; procedure second_real_to_fix(var pto,pfrom : ptree;convtyp : tconverttype); var rreg : tregister; ref : treference; begin { real must be on fpu stack } if (pfrom^.location.loc<>LOC_FPU) then emit_ref(A_FLD,S_FL,newreference(pfrom^.location.reference)); push_int($1f3f); push_int(65536); reset_reference(ref); ref.base:=R_ESP; emit_ref(A_FIMUL,S_IL,newreference(ref)); ref.offset:=4; emit_ref(A_FSTCW,S_NO,newreference(ref)); ref.offset:=6; emit_ref(A_FLDCW,S_NO,newreference(ref)); ref.offset:=0; emit_ref(A_FISTP,S_IL,newreference(ref)); ref.offset:=4; emit_ref(A_FLDCW,S_NO,newreference(ref)); rreg:=getregister32; emit_reg(A_POP,S_L,rreg); { better than an add on all processors } {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} emit_reg(A_POP,S_L,R_EDI); {$ifndef noAllocEdi} ungetregister32(R_EDI); {$endif noAllocEdi} clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; pto^.location.register:=rreg; inc(fpuvaroffset); end; procedure second_real_to_real(var pto,pfrom : ptree;convtyp : tconverttype); begin case pfrom^.location.loc of LOC_FPU : ; LOC_CFPUREGISTER: begin pto^.location:=pfrom^.location; exit; end; LOC_MEM, LOC_REFERENCE: begin floatload(pfloatdef(pfrom^.resulttype)^.typ, pfrom^.location.reference); { we have to free the reference } del_reference(pfrom^.location.reference); end; end; clear_location(pto^.location); pto^.location.loc:=LOC_FPU; end; procedure second_fix_to_real(var pto,pfrom : ptree;convtyp : tconverttype); var popeax,popebx,popecx,popedx : boolean; startreg : tregister; hl : pasmlabel; r : treference; begin if (pfrom^.location.loc=LOC_REGISTER) or (pfrom^.location.loc=LOC_CREGISTER) then begin startreg:=pfrom^.location.register; ungetregister(startreg); popeax:=(startreg<>R_EAX) and not (R_EAX in unused); if popeax then emit_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 emit_ref_reg(A_MOV,S_L,newreference( pfrom^.location.reference),R_EAX); del_reference(pfrom^.location.reference); startreg:=R_NO; end; popebx:=(startreg<>R_EBX) and not (R_EBX in unused); if popebx then emit_reg(A_PUSH,S_L,R_EBX); popecx:=(startreg<>R_ECX) and not (R_ECX in unused); if popecx then emit_reg(A_PUSH,S_L,R_ECX); popedx:=(startreg<>R_EDX) and not (R_EDX in unused); if popedx then emit_reg(A_PUSH,S_L,R_EDX); emit_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); emitjmp(C_Z,hl); emit_const_reg(A_RCL,S_L,1,R_EBX); emit_reg_reg(A_BSR,S_L,R_EAX,R_EDX); emit_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); emit_const_reg(A_ADD,S_W,1007,R_DX); emit_const_reg(A_SHL,S_W,5,R_DX); emit_const_reg_reg(A_SHLD,S_W,11,R_DX,R_BX); emit_const_reg_reg(A_SHLD,S_L,20,R_EAX,R_EBX); emit_const_reg(A_SHL,S_L,20,R_EAX); emitlab(hl); { better than an add on all processors } emit_reg(A_PUSH,S_L,R_EBX); emit_reg(A_PUSH,S_L,R_EAX); reset_reference(r); r.base:=R_ESP; emit_ref(A_FLD,S_FL,newreference(r)); emit_const_reg(A_ADD,S_L,8,R_ESP); if popedx then emit_reg(A_POP,S_L,R_EDX); if popecx then emit_reg(A_POP,S_L,R_ECX); if popebx then emit_reg(A_POP,S_L,R_EBX); if popeax then emit_reg(A_POP,S_L,R_EAX); clear_location(pto^.location); pto^.location.loc:=LOC_FPU; end; procedure second_cord_to_pointer(var pto,pfrom : ptree;convtyp : tconverttype); begin { this can't happend, because constants are already processed in pass 1 } internalerror(47423985); end; procedure second_int_to_fix(var pto,pfrom : ptree;convtyp : tconverttype); var hregister : tregister; begin if (pfrom^.location.loc=LOC_REGISTER) then hregister:=pfrom^.location.register else if (pfrom^.location.loc=LOC_CREGISTER) then hregister:=getregister32 else begin del_reference(pfrom^.location.reference); hregister:=getregister32; case porddef(pfrom^.resulttype)^.typ of s8bit : emit_ref_reg(A_MOVSX,S_BL,newreference(pfrom^.location.reference), hregister); u8bit : emit_ref_reg(A_MOVZX,S_BL,newreference(pfrom^.location.reference), hregister); s16bit : emit_ref_reg(A_MOVSX,S_WL,newreference(pfrom^.location.reference), hregister); u16bit : emit_ref_reg(A_MOVZX,S_WL,newreference(pfrom^.location.reference), hregister); u32bit,s32bit : emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), hregister); {!!!! u32bit } end; end; emit_const_reg(A_SHL,S_L,16,hregister); clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; pto^.location.register:=hregister; end; procedure second_proc_to_procvar(var pto,pfrom : ptree;convtyp : tconverttype); begin { method pointer ? } if assigned(pfrom^.left) then begin set_location(pto^.location,pfrom^.location); end else begin clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; pto^.location.register:=getregister32; del_reference(pfrom^.location.reference); emit_ref_reg(A_LEA,S_L, newreference(pfrom^.location.reference),pto^.location.register); end; end; procedure second_bool_to_int(var pto,pfrom : ptree;convtyp : tconverttype); var oldtruelabel,oldfalselabel,hlabel : pasmlabel; hregister : tregister; newsize, opsize : topsize; op : tasmop; begin oldtruelabel:=truelabel; oldfalselabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(pfrom); { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (pto^.explizit) and (pfrom^.resulttype^.size=pto^.resulttype^.size) and (pfrom^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then begin set_location(pto^.location,pfrom^.location); truelabel:=oldtruelabel; falselabel:=oldfalselabel; exit; end; clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; del_reference(pfrom^.location.reference); case pfrom^.resulttype^.size of 1 : begin case pto^.resulttype^.size of 1 : opsize:=S_B; 2 : opsize:=S_BW; 4 : opsize:=S_BL; end; end; 2 : begin case pto^.resulttype^.size of 1 : begin if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then pfrom^.location.register:=reg16toreg8(pfrom^.location.register); opsize:=S_B; end; 2 : opsize:=S_W; 4 : opsize:=S_WL; end; end; 4 : begin case pto^.resulttype^.size of 1 : begin if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then pfrom^.location.register:=reg32toreg8(pfrom^.location.register); opsize:=S_B; end; 2 : begin if pfrom^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then pfrom^.location.register:=reg32toreg16(pfrom^.location.register); opsize:=S_W; end; 4 : opsize:=S_L; end; end; end; if opsize in [S_B,S_W,S_L] then op:=A_MOV else if is_signed(pto^.resulttype) then op:=A_MOVSX else op:=A_MOVZX; hregister:=getregister32; case pto^.resulttype^.size of 1 : begin pto^.location.register:=reg32toreg8(hregister); newsize:=S_B; end; 2 : begin pto^.location.register:=reg32toreg16(hregister); newsize:=S_W; end; 4 : begin pto^.location.register:=hregister; newsize:=S_L; end; else internalerror(10060); end; case pfrom^.location.loc of LOC_MEM, LOC_REFERENCE : emit_ref_reg(op,opsize, newreference(pfrom^.location.reference),pto^.location.register); LOC_REGISTER, LOC_CREGISTER : begin { remove things like movb %al,%al } if pfrom^.location.register<>pto^.location.register then emit_reg_reg(op,opsize, pfrom^.location.register,pto^.location.register); end; LOC_FLAGS : begin emit_flag2reg(pfrom^.location.resflags,pto^.location.register); end; LOC_JUMP : begin getlabel(hlabel); emitlab(truelabel); emit_const_reg(A_MOV,newsize,1,pto^.location.register); emitjmp(C_None,hlabel); emitlab(falselabel); emit_reg_reg(A_XOR,newsize,pto^.location.register, pto^.location.register); emitlab(hlabel); end; else internalerror(10061); end; truelabel:=oldtruelabel; falselabel:=oldfalselabel; end; procedure second_int_to_bool(var pto,pfrom : ptree;convtyp : tconverttype); var hregister : tregister; flags : tresflags; opsize : topsize; begin clear_location(pto^.location); { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (pto^.explizit) and (pfrom^.resulttype^.size=pto^.resulttype^.size) and (pfrom^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then begin set_location(pto^.location,pfrom^.location); exit; end; pto^.location.loc:=LOC_REGISTER; del_reference(pfrom^.location.reference); opsize:=def_opsize(pfrom^.resulttype); case pfrom^.location.loc of LOC_MEM,LOC_REFERENCE : begin hregister:=def_getreg(pfrom^.resulttype); emit_ref_reg(A_MOV,opsize, newreference(pfrom^.location.reference),hregister); emit_reg_reg(A_OR,opsize,hregister,hregister); flags:=F_NE; end; LOC_FLAGS : begin hregister:=getregister32; flags:=pfrom^.location.resflags; end; LOC_REGISTER,LOC_CREGISTER : begin hregister:=pfrom^.location.register; emit_reg_reg(A_OR,opsize,hregister,hregister); flags:=F_NE; end; else internalerror(10062); end; case pto^.resulttype^.size of 1 : pto^.location.register:=makereg8(hregister); 2 : pto^.location.register:=makereg16(hregister); 4 : pto^.location.register:=makereg32(hregister); else internalerror(10064); end; emit_flag2reg(flags,pto^.location.register); end; procedure second_load_smallset(var pto,pfrom : ptree;convtyp : tconverttype); var href : treference; pushedregs : tpushed; begin href.symbol:=nil; pushusedregisters(pushedregs,$ff); gettempofsizereference(32,href); emitpushreferenceaddr(pfrom^.location.reference); emitpushreferenceaddr(href); emitcall('FPC_SET_LOAD_SMALL'); maybe_loadesi; popusedregisters(pushedregs); clear_location(pto^.location); pto^.location.loc:=LOC_MEM; pto^.location.reference:=href; end; procedure second_ansistring_to_pchar(var pto,pfrom : ptree;convtyp : tconverttype); var l1 : pasmlabel; hr : preference; begin clear_location(pto^.location); pto^.location.loc:=LOC_REGISTER; getlabel(l1); case pfrom^.location.loc of LOC_CREGISTER,LOC_REGISTER: pto^.location.register:=pfrom^.location.register; LOC_MEM,LOC_REFERENCE: begin pto^.location.register:=getregister32; emit_ref_reg(A_MOV,S_L,newreference(pfrom^.location.reference), pto^.location.register); del_reference(pfrom^.location.reference); end; end; emit_const_reg(A_CMP,S_L,0,pto^.location.register); emitjmp(C_NZ,l1); new(hr); reset_reference(hr^); hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); emit_ref_reg(A_LEA,S_L,hr,pto^.location.register); emitlab(l1); end; procedure second_pchar_to_string(var pto,pfrom : ptree;convtyp : tconverttype); var pushed : tpushed; regs_to_push: byte; begin case pstringdef(pto^.resulttype)^.string_typ of st_shortstring: begin pto^.location.loc:=LOC_REFERENCE; gettempofsizereference(pto^.resulttype^.size,pto^.location.reference); pushusedregisters(pushed,$ff); case pfrom^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH,S_L,pfrom^.location.register); ungetregister32(pfrom^.location.register); end; LOC_REFERENCE,LOC_MEM: begin { Now release the registers (see cgai386.pas: } { loadansistring for more info on the order) (JM) } del_reference(pfrom^.location.reference); emit_push_mem(pfrom^.location.reference); end; end; emitpushreferenceaddr(pto^.location.reference); emitcall('FPC_PCHAR_TO_SHORTSTR'); maybe_loadesi; popusedregisters(pushed); end; st_ansistring: begin pto^.location.loc:=LOC_REFERENCE; gettempansistringreference(pto^.location.reference); decrstringref(cansistringdef,pto^.location.reference); { Find out which regs have to be pushed (JM) } regs_to_push := $ff; remove_non_regvars_from_loc(pfrom^.location,regs_to_push); pushusedregisters(pushed,regs_to_push); case pfrom^.location.loc of LOC_REFERENCE,LOC_MEM: begin { Now release the registers (see cgai386.pas: } { loadansistring for more info on the order) (JM) } del_reference(pfrom^.location.reference); emit_push_mem(pfrom^.location.reference); end; LOC_REGISTER,LOC_CREGISTER: begin { Now release the registers (see cgai386.pas: } { loadansistring for more info on the order) (JM) } emit_reg(A_PUSH,S_L,pfrom^.location.register); ungetregister32(pfrom^.location.register); end; end; emitpushreferenceaddr(pto^.location.reference); emitcall('FPC_PCHAR_TO_ANSISTR'); maybe_loadesi; popusedregisters(pushed); end; else begin internalerror(12121); end; end; end; procedure second_nothing(var pto,pfrom : ptree;convtyp : tconverttype); begin end; {**************************************************************************** SecondTypeConv ****************************************************************************} procedure secondtypeconv(var p : ptree); const secondconvert : array[tconverttype] of tsecondconvproc = ( second_nothing, {equal} second_nothing, {not_possible} second_string_to_string, second_char_to_string, second_pchar_to_string, second_nothing, {cchar_to_pchar} second_cstring_to_pchar, second_ansistring_to_pchar, second_string_to_chararray, second_chararray_to_string, second_array_to_pointer, second_pointer_to_array, second_int_to_int, second_int_to_bool, second_bool_to_int, { bool_to_bool } second_bool_to_int, second_real_to_real, second_int_to_real, second_int_to_fix, second_real_to_fix, second_fix_to_real, second_proc_to_procvar, second_nothing, {arrayconstructor_to_set} second_load_smallset, second_cord_to_pointer ); {$ifdef TESTOBJEXT2} var r : preference; nillabel : plabel; {$endif TESTOBJEXT2} begin { this isn't good coding, I think tc_bool_2_int, shouldn't be } { type conversion (FK) } if not(p^.convtyp in [tc_bool_2_int,tc_bool_2_bool]) then begin secondpass(p^.left); set_location(p^.location,p^.left^.location); if codegenerror then exit; end; { the second argument only is for maybe_range_checking !} secondconvert[p^.convtyp](p,p^.left,p^.convtyp); {$ifdef TESTOBJEXT2} { Check explicit conversions to objects pointers !! } if p^.explizit and (p^.resulttype^.deftype=pointerdef) and (ppointerdef(p^.resulttype)^.definition^.deftype=objectdef) and not (pobjectdef(ppointerdef(p^.resulttype)^.definition)^.isclass) and ((pobjectdef(ppointerdef(p^.resulttype)^.definition)^.options and oo_hasvmt)<>0) and (cs_check_range in aktlocalswitches) then begin new(r); reset_reference(r^); if p^.location.loc in [LOC_REGISTER,LOC_CREGISTER] then r^.base:=p^.location.register else begin {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} emit_mov_loc_reg(p^.location,R_EDI); r^.base:=R_EDI; end; { NIL must be accepted !! } emit_reg_reg(A_OR,S_L,r^.base,r^.base); {$ifndef noAllocEdi} ungetregister32(R_EDI); {$endif noAllocEdi} getlabel(nillabel); emitjmp(C_E,nillabel); { this is one point where we need vmt_offset (PM) } r^.offset:= pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_offset; {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} emit_ref_reg(A_MOV,S_L,r,R_EDI); emit_sym(A_PUSH,S_L, newasmsymbol(pobjectdef(ppointerdef(p^.resulttype)^.definition)^.vmt_mangledname)); emit_reg(A_PUSH,S_L,R_EDI); {$ifndef noAllocEdi} ungetregister32(R_EDI); {$endif noAllocEdi} emitcall('FPC_CHECK_OBJECT_EXT'); emitlab(nillabel); end; {$endif TESTOBJEXT2} end; {***************************************************************************** SecondIs *****************************************************************************} procedure secondis(var p : ptree); var pushed : tpushed; begin { save all used registers } pushusedregisters(pushed,$ff); secondpass(p^.left); clear_location(p^.location); p^.location.loc:=LOC_FLAGS; p^.location.resflags:=F_NE; { push instance to check: } case p^.left^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH, S_L,p^.left^.location.register); ungetregister32(p^.left^.location.register); end; LOC_MEM,LOC_REFERENCE: begin emit_ref(A_PUSH, S_L,newreference(p^.left^.location.reference)); del_reference(p^.left^.location.reference); end; else internalerror(100); end; { generate type checking } secondpass(p^.right); case p^.right^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH, S_L,p^.right^.location.register); ungetregister32(p^.right^.location.register); end; LOC_MEM,LOC_REFERENCE: begin emit_ref(A_PUSH, S_L,newreference(p^.right^.location.reference)); del_reference(p^.right^.location.reference); end; else internalerror(100); end; emitcall('FPC_DO_IS'); emit_reg_reg(A_OR,S_B,R_AL,R_AL); popusedregisters(pushed); maybe_loadesi; end; {***************************************************************************** SecondAs *****************************************************************************} procedure secondas(var p : ptree); var pushed : tpushed; begin secondpass(p^.left); { save all used registers } pushusedregisters(pushed,$ff); { push instance to check: } case p^.left^.location.loc of LOC_REGISTER,LOC_CREGISTER: emit_reg(A_PUSH, S_L,p^.left^.location.register); LOC_MEM,LOC_REFERENCE: emit_ref(A_PUSH, S_L,newreference(p^.left^.location.reference)); else internalerror(100); end; { we doesn't modifiy the left side, we check only the type } set_location(p^.location,p^.left^.location); { generate type checking } secondpass(p^.right); case p^.right^.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH, S_L,p^.right^.location.register); ungetregister32(p^.right^.location.register); end; LOC_MEM,LOC_REFERENCE: begin emit_ref(A_PUSH, S_L,newreference(p^.right^.location.reference)); del_reference(p^.right^.location.reference); end; else internalerror(100); end; emitcall('FPC_DO_AS'); { restore register, this restores automatically the } { result } popusedregisters(pushed); maybe_loadesi; end; end. { $Log$ Revision 1.106 2000-05-26 20:16:00 jonas * fixed wrong register deallocations in several ansistring related procedures. The IDE's now function fine when compiled with -OG3p3r Revision 1.105 2000/04/10 12:23:19 jonas * modified copyshortstring so it takes an extra paramter which allows it to delete the sref itself (so the reg deallocations are put in the right place for the optimizer) Revision 1.104 2000/03/31 22:56:45 pierre * fix the handling of value parameters in cdecl function Revision 1.103 2000/02/19 10:12:47 florian * fixed one more internalerror 10 Revision 1.102 2000/02/09 13:22:46 peter * log truncated Revision 1.101 2000/01/13 16:52:48 jonas * moved deallocation of registers used in reference that points to string after copyshortstring (this routine doesn't require extra regs) Revision 1.100 2000/01/09 12:35:00 jonas * changed edi allocation to use getexplicitregister32/ungetregister (adapted tgeni386 a bit for this) and enabled it by default * fixed very big and stupid bug of mine in cg386mat that broke the include() code (and make cycle :( ) if you compiled without -dnewoptimizations Revision 1.99 2000/01/09 01:44:19 jonas + (de)allocation info for EDI to fix reported bug on mailinglist. Also some (de)allocation info for ESI added. Between -dallocEDI because at this time of the night bugs could easily slip in ;) Revision 1.98 2000/01/07 01:14:20 peter * updated copyright to 2000 Revision 1.97 1999/12/22 01:01:46 peter - removed freelabel() * added undefined label detection in internal assembler, this prevents a lot of ld crashes and wrong .o files * .o files aren't written anymore if errors have occured * inlining of assembler labels is now correct Revision 1.96 1999/12/21 11:49:51 pierre * array of char to short string bug fixed Revision 1.95 1999/12/01 12:42:31 peter * fixed bug 698 * removed some notes about unused vars Revision 1.94 1999/11/29 22:15:25 pierre * fix for internalerror(12) on ord(booleanarray[1]) Revision 1.93 1999/11/06 14:34:17 peter * truncated log to 20 revs Revision 1.92 1999/10/25 10:32:43 peter * ansistring 2 chararray support * optimized ansitring 2 pchar Revision 1.91 1999/10/22 14:36:04 peter * fixed esi reload with as Revision 1.90 1999/10/06 08:32:00 peter * fixed empty const ansistring 2 pchar Revision 1.89 1999/09/26 21:30:15 peter + constant pointer support which can happend with typecasting like const p=pointer(1) * better procvar parsing in typed consts Revision 1.88 1999/09/26 13:26:04 florian * exception patch of Romio nevertheless the excpetion handling needs some corections regarding register saving * gettempansistring is again a procedure Revision 1.87 1999/09/23 21:20:37 peter * fixed temp allocation for short->ansi Revision 1.86 1999/09/01 09:42:13 peter * update for new push_lea_loc Revision 1.85 1999/08/19 13:08:46 pierre * emit_??? used Revision 1.84 1999/08/05 14:58:03 florian * some fixes for the floating point registers * more things for the new code generator Revision 1.83 1999/08/04 13:45:19 florian + floating point register variables !! * pairegalloc is now generated for register variables Revision 1.82 1999/08/04 00:22:43 florian * renamed i386asm and i386base to cpuasm and cpubase }