{ $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. **************************************************************************** } unit n386cnv; {$i defines.inc} interface uses node,ncnv,types; type ti386typeconvnode = class(ttypeconvnode) procedure second_int_to_int;virtual; procedure second_string_to_string;virtual; procedure second_cstring_to_pchar;virtual; procedure second_string_to_chararray;virtual; procedure second_array_to_pointer;virtual; procedure second_pointer_to_array;virtual; procedure second_chararray_to_string;virtual; procedure second_char_to_string;virtual; procedure second_int_to_real;virtual; procedure second_real_to_fix;virtual; procedure second_real_to_real;virtual; procedure second_fix_to_real;virtual; procedure second_cord_to_pointer;virtual; procedure second_int_to_fix;virtual; procedure second_proc_to_procvar;virtual; procedure second_bool_to_int;virtual; procedure second_int_to_bool;virtual; procedure second_load_smallset;virtual; procedure second_ansistring_to_pchar;virtual; procedure second_pchar_to_string;virtual; procedure second_class_to_intf;virtual; procedure second_nothing;virtual; procedure pass_2;override; procedure second_call_helper(c : tconverttype); end; ti386asnode = class(tasnode) procedure pass_2;override; end; ti386isnode = class(tisnode) procedure pass_2;override; end; implementation uses verbose,globals,systems, symconst,symdef,aasm, hcodegen,temp_gen,pass_2, ncon,ncal, cpubase,cpuasm, cgai386,tgcpu,n386util; {***************************************************************************** SecondTypeConv *****************************************************************************} procedure ti386typeconvnode.second_int_to_int; var op : tasmop; opsize : topsize; hregister, hregister2 : tregister; l : pasmlabel; begin { insert range check if not explicit conversion } if not(nf_explizit in flags) then emitrangecheck(left,resulttype); { is the result size smaller ? } if resulttype^.sizeleft.resulttype^.size then begin { remove reference } if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then begin del_reference(left.location.reference); { we can do this here as we need no temp inside } ungetiftemp(left.location.reference); end; { get op and opsize, handle separate for constants, because movz doesn't support constant values } if (left.location.loc=LOC_MEM) and (left.location.reference.is_immediate) then begin if is_64bitint(resulttype) then opsize:=S_L else opsize:=def_opsize(resulttype); op:=A_MOV; end else begin opsize:=def2def_opsize(left.resulttype,resulttype); if opsize in [S_B,S_W,S_L] then op:=A_MOV else if is_signed(left.resulttype) then op:=A_MOVSX else op:=A_MOVZX; end; { load the register we need } if left.location.loc<>LOC_REGISTER then hregister:=getregister32 else hregister:=left.location.register; { set the correct register size and location } clear_location(location); location.loc:=LOC_REGISTER; { do we need a second register for a 64 bit type ? } if is_64bitint(resulttype) then begin hregister2:=getregister32; location.registerhigh:=hregister2; end; case resulttype^.size of 1: location.register:=makereg8(hregister); 2: location.register:=makereg16(hregister); 4,8: location.register:=makereg32(hregister); end; { insert the assembler code } if left.location.loc in [LOC_CREGISTER,LOC_REGISTER] then emit_reg_reg(op,opsize,left.location.register,location.register) else emit_ref_reg(op,opsize, newreference(left.location.reference),location.register); { do we need a sign extension for int64? } if is_64bitint(resulttype) then { special case for constants (JM) } if is_constintnode(left) then begin if tordconstnode(left).value >= 0 then emit_reg_reg(A_XOR,S_L, hregister2,hregister2) else emit_const_reg(A_MOV,S_L,longint($ffffffff),hregister2); end else begin emit_reg_reg(A_XOR,S_L, hregister2,hregister2); if (porddef(resulttype)^.typ=s64bit) and is_signed(left.resulttype) then begin getlabel(l); emit_const_reg(A_TEST,S_L,longint($80000000),makereg32(hregister)); emitjmp(C_Z,l); emit_reg(A_NOT,S_L, hregister2); emitlab(l); end; end; end; end; procedure ti386typeconvnode.second_string_to_string; var pushed : tpushed; regs_to_push: byte; begin { does anybody know a better solution than this big case statement ? } { ok, a proc table would do the job } case pstringdef(resulttype)^.string_typ of st_shortstring: case pstringdef(left.resulttype)^.string_typ of st_shortstring: begin gettempofsizereference(resulttype^.size,location.reference); copyshortstring(location.reference,left.location.reference, pstringdef(resulttype)^.len,false,true); { done by copyshortstring now (JM) } { del_reference(left.location.reference); } ungetiftemp(left.location.reference); end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_ansistring: begin gettempofsizereference(resulttype^.size,location.reference); loadansi2short(left,self); { this is done in secondtypeconv (FK) removetemps(exprasmlist,temptoremove); destroys:=true; } end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; st_longstring: case pstringdef(left.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(left.resulttype)^.string_typ of st_shortstring: begin clear_location(location); location.loc:=LOC_REFERENCE; gettempansistringreference(location.reference); decrstringref(cansistringdef,location.reference); { We don't need the source regs anymore (JM) } regs_to_push := $ff; remove_non_regvars_from_loc(left.location,regs_to_push); pushusedregisters(pushed,regs_to_push); release_loc(left.location); emit_push_lea_loc(left.location,true); emit_push_lea_loc(location,false); saveregvars(regs_to_push); 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(left.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 ti386typeconvnode.second_cstring_to_pchar; var hr : preference; begin clear_location(location); location.loc:=LOC_REGISTER; location.register:=getregister32; case pstringdef(left.resulttype)^.string_typ of st_shortstring : begin inc(left.location.reference.offset); emit_ref_reg(A_LEA,S_L,newreference(left.location.reference), location.register); end; st_ansistring : begin if (left.nodetype=stringconstn) and (str_length(left)=0) then begin new(hr); reset_reference(hr^); hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); emit_ref_reg(A_LEA,S_L,hr,location.register); end else emit_ref_reg(A_MOV,S_L,newreference(left.location.reference), location.register); end; st_longstring: begin {!!!!!!!} internalerror(8888); end; st_widestring: begin {!!!!!!!} internalerror(8888); end; end; end; procedure ti386typeconvnode.second_string_to_chararray; var pushedregs: tpushed; //l1 : pasmlabel; //hr : preference; arrsize, strtype: longint; regstopush: byte; begin with parraydef(resulttype)^ do begin if highrange= arrsize) and (pstringdef(left.resulttype)^.string_typ=st_shortstring) then begin inc(location.reference.offset); exit; end; clear_location(location); location.loc := LOC_REFERENCE; gettempofsizereference(arrsize,location.reference); regstopush := $ff; remove_non_regvars_from_loc(left.location,regstopush); pushusedregisters(pushedregs,regstopush); emit_push_lea_loc(location,false); case pstringdef(left.resulttype)^.string_typ of st_shortstring : begin { 0 means shortstring } strtype := 0; del_reference(left.location.reference); emit_push_lea_loc(left.location,true); ungetiftemp(left.location.reference); end; st_ansistring : begin { 1 means ansistring } strtype := 1; case left.location.loc of LOC_CREGISTER,LOC_REGISTER: begin ungetregister(left.location.register); emit_push_loc(left.location); end; LOC_MEM,LOC_REFERENCE: begin del_reference(left.location.reference); emit_push_loc(left.location); ungetiftemp(left.location.reference); end; end; end; st_longstring: begin {!!!!!!!} { 2 means longstring, but still needs support in FPC_STR_TO_CHARARRAY, which is in i386.inc and/or generic.inc (JM) } strtype := 2; internalerror(8888); end; st_widestring: begin {!!!!!!!} { 3 means widestring, but still needs support in FPC_STR_TO_CHARARRAY, which is in i386.inc and/or generic.inc (JM) } strtype := 3; internalerror(8888); end; end; push_int(arrsize); push_int(strtype); saveregvars(regstopush); emitcall('FPC_STR_TO_CHARARRAY'); popusedregisters(pushedregs); end; procedure ti386typeconvnode.second_array_to_pointer; begin del_reference(left.location.reference); clear_location(location); location.loc:=LOC_REGISTER; location.register:=getregister32; emit_ref_reg(A_LEA,S_L,newreference(left.location.reference), location.register); end; procedure ti386typeconvnode.second_pointer_to_array; begin clear_location(location); location.loc:=LOC_REFERENCE; reset_reference(location.reference); case left.location.loc of LOC_REGISTER : location.reference.base:=left.location.register; LOC_CREGISTER : begin location.reference.base:=getregister32; emit_reg_reg(A_MOV,S_L,left.location.register,location.reference.base); end else begin del_reference(left.location.reference); location.reference.base:=getregister32; emit_ref_reg(A_MOV,S_L,newreference(left.location.reference), location.reference.base); end; end; end; { generates the code for the type conversion from an array of char } { to a string } procedure ti386typeconvnode.second_chararray_to_string; var pushed : tpushed; regstopush: byte; l : longint; begin { calc the length of the array } l:=parraydef(left.resulttype)^.highrange-parraydef(left.resulttype)^.lowrange+1; { this is a type conversion which copies the data, so we can't } { return a reference } clear_location(location); location.loc:=LOC_MEM; case pstringdef(resulttype)^.string_typ of st_shortstring : begin if l>255 then begin CGMessage(type_e_mismatch); l:=255; end; gettempofsizereference(resulttype^.size,location.reference); { we've also to release the registers ... } { Yes, but before pushusedregisters since that one resets unused! } { This caused web bug 1073 (JM) } regstopush := $ff; remove_non_regvars_from_loc(left.location,regstopush); pushusedregisters(pushed,regstopush); if l>=resulttype^.size then push_int(resulttype^.size-1) else push_int(l); { ... here only the temp. location is released } emit_push_lea_loc(left.location,true); del_reference(left.location.reference); emitpushreferenceaddr(location.reference); saveregvars(regstopush); emitcall('FPC_CHARARRAY_TO_SHORTSTR'); maybe_loadesi; popusedregisters(pushed); end; st_ansistring : begin gettempansistringreference(location.reference); decrstringref(cansistringdef,location.reference); regstopush := $ff; remove_non_regvars_from_loc(left.location,regstopush); pushusedregisters(pushed,regstopush); push_int(l); emitpushreferenceaddr(left.location.reference); release_loc(left.location); emitpushreferenceaddr(location.reference); saveregvars(regstopush); 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 ti386typeconvnode.second_char_to_string; var pushed : tpushed; begin clear_location(location); location.loc:=LOC_MEM; case pstringdef(resulttype)^.string_typ of st_shortstring : begin gettempofsizereference(256,location.reference); loadshortstring(left,self); end; st_ansistring : begin gettempansistringreference(location.reference); decrstringref(cansistringdef,location.reference); release_loc(left.location); pushusedregisters(pushed,$ff); emit_pushw_loc(left.location); emitpushreferenceaddr(location.reference); saveregvars($ff); emitcall('FPC_CHAR_TO_ANSISTR'); popusedregisters(pushed); maybe_loadesi; end; else internalerror(4179); end; end; procedure ti386typeconvnode.second_int_to_real; 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(left.resulttype)^.typ=u32bit then push_int(0); if (left.location.loc=LOC_REGISTER) or (left.location.loc=LOC_CREGISTER) then begin {$ifndef noAllocEdi} if not (porddef(left.resulttype)^.typ in [u32bit,s32bit,u64bit,s64bit]) then getexplicitregister32(R_EDI); {$endif noAllocEdi} case porddef(left.resulttype)^.typ of s8bit : emit_reg_reg(A_MOVSX,S_BL,left.location.register,R_EDI); u8bit : emit_reg_reg(A_MOVZX,S_BL,left.location.register,R_EDI); s16bit : emit_reg_reg(A_MOVSX,S_WL,left.location.register,R_EDI); u16bit : emit_reg_reg(A_MOVZX,S_WL,left.location.register,R_EDI); u32bit,s32bit: hregister:=left.location.register; u64bit,s64bit: begin emit_reg(A_PUSH,S_L,left.location.registerhigh); hregister:=left.location.registerlow; end; end; ungetregister(left.location.register); end else begin r:=newreference(left.location.reference); {$ifndef noAllocEdi} getexplicitregister32(R_EDI); {$endif noAllocEdi} case porddef(left.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(left.location.reference); emit_ref_reg(A_MOV,S_L,r,R_EDI); end; end; del_reference(left.location.reference); ungetiftemp(left.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(left.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,longint($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(Tai_label.Create(l1)); { I got this constant from a test progtram (FK) } Consts.concat(Tai_const.Create_32bit(0)); Consts.concat(Tai_const.Create_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(location); location.loc:=LOC_FPU; end; procedure ti386typeconvnode.second_real_to_fix; var rreg : tregister; ref : treference; begin { real must be on fpu stack } if (left.location.loc<>LOC_FPU) then emit_ref(A_FLD,S_FL,newreference(left.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(location); location.loc:=LOC_REGISTER; location.register:=rreg; inc(fpuvaroffset); end; procedure ti386typeconvnode.second_real_to_real; begin case left.location.loc of LOC_FPU : ; LOC_CFPUREGISTER: begin location:=left.location; exit; end; LOC_MEM, LOC_REFERENCE: begin floatload(pfloatdef(left.resulttype)^.typ, left.location.reference); { we have to free the reference } del_reference(left.location.reference); end; end; clear_location(location); location.loc:=LOC_FPU; end; procedure ti386typeconvnode.second_fix_to_real; var popeax,popebx,popecx,popedx : boolean; startreg : tregister; hl : pasmlabel; r : treference; begin if (left.location.loc=LOC_REGISTER) or (left.location.loc=LOC_CREGISTER) then begin startreg:=left.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( left.location.reference),R_EAX); del_reference(left.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(location); location.loc:=LOC_FPU; end; procedure ti386typeconvnode.second_cord_to_pointer; begin { this can't happend, because constants are already processed in pass 1 } internalerror(47423985); end; procedure ti386typeconvnode.second_int_to_fix; var hregister : tregister; begin if (left.location.loc=LOC_REGISTER) then hregister:=left.location.register else if (left.location.loc=LOC_CREGISTER) then hregister:=getregister32 else begin del_reference(left.location.reference); hregister:=getregister32; case porddef(left.resulttype)^.typ of s8bit : emit_ref_reg(A_MOVSX,S_BL,newreference(left.location.reference), hregister); u8bit : emit_ref_reg(A_MOVZX,S_BL,newreference(left.location.reference), hregister); s16bit : emit_ref_reg(A_MOVSX,S_WL,newreference(left.location.reference), hregister); u16bit : emit_ref_reg(A_MOVZX,S_WL,newreference(left.location.reference), hregister); u32bit,s32bit : emit_ref_reg(A_MOV,S_L,newreference(left.location.reference), hregister); {!!!! u32bit } end; end; emit_const_reg(A_SHL,S_L,16,hregister); clear_location(location); location.loc:=LOC_REGISTER; location.register:=hregister; end; procedure ti386typeconvnode.second_proc_to_procvar; begin { method pointer ? } if assigned(tcallnode(left).left) then begin set_location(location,left.location); end else begin clear_location(location); location.loc:=LOC_REGISTER; location.register:=getregister32; del_reference(left.location.reference); emit_ref_reg(A_LEA,S_L, newreference(left.location.reference),location.register); end; end; procedure ti386typeconvnode.second_bool_to_int; var oldtruelabel,oldfalselabel,hlabel : pasmlabel; hregister : tregister; newsize, opsize : topsize; op : tasmop; begin oldtruelabel:=truelabel; oldfalselabel:=falselabel; getlabel(truelabel); getlabel(falselabel); secondpass(left); { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (nf_explizit in flags) and (left.resulttype^.size=resulttype^.size) and (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then begin set_location(location,left.location); truelabel:=oldtruelabel; falselabel:=oldfalselabel; exit; end; clear_location(location); location.loc:=LOC_REGISTER; del_reference(left.location.reference); case left.resulttype^.size of 1 : begin case resulttype^.size of 1 : opsize:=S_B; 2 : opsize:=S_BW; 4 : opsize:=S_BL; end; end; 2 : begin case resulttype^.size of 1 : begin if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then left.location.register:=reg16toreg8(left.location.register); opsize:=S_B; end; 2 : opsize:=S_W; 4 : opsize:=S_WL; end; end; 4 : begin case resulttype^.size of 1 : begin if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then left.location.register:=reg32toreg8(left.location.register); opsize:=S_B; end; 2 : begin if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then left.location.register:=reg32toreg16(left.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(resulttype) then op:=A_MOVSX else op:=A_MOVZX; hregister:=getregister32; case resulttype^.size of 1 : begin location.register:=reg32toreg8(hregister); newsize:=S_B; end; 2 : begin location.register:=reg32toreg16(hregister); newsize:=S_W; end; 4 : begin location.register:=hregister; newsize:=S_L; end; else internalerror(10060); end; case left.location.loc of LOC_MEM, LOC_REFERENCE : emit_ref_reg(op,opsize, newreference(left.location.reference),location.register); LOC_REGISTER, LOC_CREGISTER : begin { remove things like movb %al,%al } if left.location.register<>location.register then emit_reg_reg(op,opsize, left.location.register,location.register); end; LOC_FLAGS : begin emit_flag2reg(left.location.resflags,location.register); end; LOC_JUMP : begin getlabel(hlabel); emitlab(truelabel); emit_const_reg(A_MOV,newsize,1,location.register); emitjmp(C_None,hlabel); emitlab(falselabel); emit_reg_reg(A_XOR,newsize,location.register, location.register); emitlab(hlabel); end; else internalerror(10061); end; truelabel:=oldtruelabel; falselabel:=oldfalselabel; end; procedure ti386typeconvnode.second_int_to_bool; var hregister : tregister; resflags : tresflags; opsize : topsize; begin clear_location(location); { byte(boolean) or word(wordbool) or longint(longbool) must be accepted for var parameters } if (nf_explizit in flags) and (left.resulttype^.size=resulttype^.size) and (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then begin set_location(location,left.location); exit; end; location.loc:=LOC_REGISTER; del_reference(left.location.reference); opsize:=def_opsize(left.resulttype); case left.location.loc of LOC_MEM,LOC_REFERENCE : begin hregister:=def_getreg(left.resulttype); emit_ref_reg(A_MOV,opsize, newreference(left.location.reference),hregister); emit_reg_reg(A_OR,opsize,hregister,hregister); resflags:=F_NE; end; LOC_FLAGS : begin hregister:=getregister32; resflags:=left.location.resflags; end; LOC_REGISTER,LOC_CREGISTER : begin hregister:=left.location.register; emit_reg_reg(A_OR,opsize,hregister,hregister); resflags:=F_NE; end; else internalerror(10062); end; case resulttype^.size of 1 : location.register:=makereg8(hregister); 2 : location.register:=makereg16(hregister); 4 : location.register:=makereg32(hregister); else internalerror(10064); end; emit_flag2reg(resflags,location.register); end; procedure ti386typeconvnode.second_load_smallset; var href : treference; pushedregs : tpushed; begin href.symbol:=nil; pushusedregisters(pushedregs,$ff); gettempofsizereference(32,href); emit_push_mem_size(left.location.reference,4); emitpushreferenceaddr(href); saveregvars($ff); emitcall('FPC_SET_LOAD_SMALL'); maybe_loadesi; popusedregisters(pushedregs); clear_location(location); location.loc:=LOC_MEM; location.reference:=href; end; procedure ti386typeconvnode.second_ansistring_to_pchar; var l1 : pasmlabel; hr : preference; begin clear_location(location); location.loc:=LOC_REGISTER; getlabel(l1); case left.location.loc of LOC_CREGISTER,LOC_REGISTER: location.register:=left.location.register; LOC_MEM,LOC_REFERENCE: begin location.register:=getregister32; emit_ref_reg(A_MOV,S_L,newreference(left.location.reference), location.register); del_reference(left.location.reference); end; end; emit_const_reg(A_CMP,S_L,0,location.register); emitjmp(C_NZ,l1); new(hr); reset_reference(hr^); hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); emit_ref_reg(A_LEA,S_L,hr,location.register); emitlab(l1); end; procedure ti386typeconvnode.second_pchar_to_string; var pushed : tpushed; regs_to_push: byte; begin case pstringdef(resulttype)^.string_typ of st_shortstring: begin location.loc:=LOC_REFERENCE; gettempofsizereference(resulttype^.size,location.reference); pushusedregisters(pushed,$ff); case left.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH,S_L,left.location.register); ungetregister32(left.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(left.location.reference); emit_push_mem(left.location.reference); end; end; emitpushreferenceaddr(location.reference); saveregvars($ff); emitcall('FPC_PCHAR_TO_SHORTSTR'); maybe_loadesi; popusedregisters(pushed); end; st_ansistring: begin location.loc:=LOC_REFERENCE; gettempansistringreference(location.reference); decrstringref(cansistringdef,location.reference); { Find out which regs have to be pushed (JM) } regs_to_push := $ff; remove_non_regvars_from_loc(left.location,regs_to_push); pushusedregisters(pushed,regs_to_push); case left.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(left.location.reference); emit_push_mem(left.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,left.location.register); ungetregister32(left.location.register); end; end; emitpushreferenceaddr(location.reference); saveregvars(regs_to_push); emitcall('FPC_PCHAR_TO_ANSISTR'); maybe_loadesi; popusedregisters(pushed); end; else begin internalerror(12121); end; end; end; procedure ti386typeconvnode.second_class_to_intf; var hreg : tregister; l1 : pasmlabel; begin case left.location.loc of LOC_MEM, LOC_REFERENCE: begin del_reference(left.location.reference); hreg:=getregister32; exprasmList.concat(Taicpu.Op_ref_reg( A_MOV,S_L,newreference(left.location.reference),hreg)); end; LOC_CREGISTER: begin hreg:=getregister32; exprasmList.concat(Taicpu.Op_reg_reg( A_MOV,S_L,left.location.register,hreg)); end; LOC_REGISTER: hreg:=left.location.register; else internalerror(121120001); end; emit_reg_reg(A_TEST,S_L,hreg,hreg); getlabel(l1); emitjmp(C_Z,l1); emit_const_reg(A_ADD,S_L,pobjectdef(left.resulttype)^.implementedinterfaces^.ioffsets( pobjectdef(left.resulttype)^.implementedinterfaces^.searchintf(resulttype))^,hreg); emitlab(l1); location.loc:=LOC_REGISTER; location.register:=hreg; end; procedure ti386typeconvnode.second_nothing; begin end; {**************************************************************************** TI386TYPECONVNODE ****************************************************************************} procedure ti386typeconvnode.second_call_helper(c : tconverttype); const secondconvert : array[tconverttype] of pointer = ( @ti386typeconvnode.second_nothing, {equal} @ti386typeconvnode.second_nothing, {not_possible} @ti386typeconvnode.second_string_to_string, @ti386typeconvnode.second_char_to_string, @ti386typeconvnode.second_pchar_to_string, @ti386typeconvnode.second_nothing, {cchar_to_pchar} @ti386typeconvnode.second_cstring_to_pchar, @ti386typeconvnode.second_ansistring_to_pchar, @ti386typeconvnode.second_string_to_chararray, @ti386typeconvnode.second_chararray_to_string, @ti386typeconvnode.second_array_to_pointer, @ti386typeconvnode.second_pointer_to_array, @ti386typeconvnode.second_int_to_int, @ti386typeconvnode.second_int_to_bool, @ti386typeconvnode.second_bool_to_int, { bool_to_bool } @ti386typeconvnode.second_bool_to_int, @ti386typeconvnode.second_real_to_real, @ti386typeconvnode.second_int_to_real, @ti386typeconvnode.second_int_to_fix, @ti386typeconvnode.second_real_to_fix, @ti386typeconvnode.second_fix_to_real, @ti386typeconvnode.second_proc_to_procvar, @ti386typeconvnode.second_nothing, {arrayconstructor_to_set} @ti386typeconvnode.second_load_smallset, @ti386typeconvnode.second_cord_to_pointer, @ti386typeconvnode.second_nothing, { interface 2 string } @ti386typeconvnode.second_nothing, { interface 2 guid } @ti386typeconvnode.second_class_to_intf ); type tprocedureofobject = procedure of object; var r : packed record proc : pointer; obj : pointer; end; begin { this is a little bit dirty but it works } { and should be quite portable too } r.proc:=secondconvert[c]; r.obj:=self; tprocedureofobject(r){$ifdef FPC}();{$endif FPC} end; procedure ti386typeconvnode.pass_2; {$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(convtype in [tc_bool_2_int,tc_bool_2_bool]) then begin secondpass(left); set_location(location,left.location); if codegenerror then exit; end; second_call_helper(convtype); {$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; {***************************************************************************** TI386ISNODE *****************************************************************************} procedure ti386isnode.pass_2; var pushed : tpushed; begin { save all used registers } pushusedregisters(pushed,$ff); secondpass(left); clear_location(location); location.loc:=LOC_FLAGS; location.resflags:=F_NE; { push instance to check: } case left.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH, S_L,left.location.register); ungetregister32(left.location.register); end; LOC_MEM,LOC_REFERENCE: begin emit_ref(A_PUSH, S_L,newreference(left.location.reference)); del_reference(left.location.reference); end; else internalerror(100); end; { generate type checking } secondpass(right); case right.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH, S_L,right.location.register); ungetregister32(right.location.register); end; LOC_MEM,LOC_REFERENCE: begin emit_ref(A_PUSH, S_L,newreference(right.location.reference)); del_reference(right.location.reference); end; else internalerror(100); end; saveregvars($ff); emitcall('FPC_DO_IS'); emit_reg_reg(A_OR,S_B,R_AL,R_AL); popusedregisters(pushed); maybe_loadesi; end; {***************************************************************************** TI386ASNODE *****************************************************************************} procedure ti386asnode.pass_2; var pushed : tpushed; begin secondpass(left); { save all used registers } pushusedregisters(pushed,$ff); { push instance to check: } case left.location.loc of LOC_REGISTER,LOC_CREGISTER: emit_reg(A_PUSH, S_L,left.location.register); LOC_MEM,LOC_REFERENCE: emit_ref(A_PUSH, S_L,newreference(left.location.reference)); else internalerror(100); end; { we doesn't modifiy the left side, we check only the type } set_location(location,left.location); { generate type checking } secondpass(right); case right.location.loc of LOC_REGISTER,LOC_CREGISTER: begin emit_reg(A_PUSH, S_L,right.location.register); ungetregister32(right.location.register); end; LOC_MEM,LOC_REFERENCE: begin emit_ref(A_PUSH, S_L,newreference(right.location.reference)); del_reference(right.location.reference); end; else internalerror(100); end; saveregvars($ff); emitcall('FPC_DO_AS'); { restore register, this restores automatically the } { result } popusedregisters(pushed); maybe_loadesi; end; begin ctypeconvnode:=ti386typeconvnode; cisnode:=ti386isnode; casnode:=ti386asnode; end. { $Log$ Revision 1.12 2001-01-08 21:45:11 peter * internalerror for string to chararray Revision 1.11 2000/12/25 00:07:32 peter + new tlinkedlist class (merge of old tstringqueue,tcontainer and tlinkedlist objects) Revision 1.10 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 wasn't restored correctly after doing a 64bit rangecheck Revision 1.9 2000/12/05 11:44:33 jonas + new integer regvar handling, should be much more efficient Revision 1.8 2000/11/29 00:30:46 florian * unused units removed from uses clause * some changes for widestrings Revision 1.7 2000/11/16 15:27:48 jonas * fixed web bug 1242 Revision 1.6 2000/11/13 11:30:56 florian * some bugs with interfaces and NIL fixed Revision 1.5 2000/11/12 23:24:14 florian * interfaces are basically running Revision 1.4 2000/11/11 16:00:10 jonas * optimize converting of 8/16/32 bit constants to 64bit ones Revision 1.3 2000/11/04 14:25:23 florian + merged Attila's changes for interfaces, not tested yet 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.1 2000/10/14 10:14:48 peter * moehrendorf oct 2000 rewrite }