From fc6d300a9541b11cf1030bb8457506bfe919bb94 Mon Sep 17 00:00:00 2001 From: Jonas Maebe Date: Sat, 29 Sep 2001 21:32:46 +0000 Subject: [PATCH] * almost all second pass typeconvnode helpers are now processor independent * fixed converting boolean to int64/qword * fixed register allocation bugs which could cause internalerror 10 * isnode and asnode are completely processor indepent now as well * fpc_do_as now returns its class argument (necessary to be able to use it properly with compilerproc) --- compiler/i386/cpunode.pas | 12 +- compiler/i386/n386cnv.pas | 515 +++++--------------------------------- compiler/ncgcnv.pas | 436 ++++++++++++++++++++++++++++++++ compiler/ncnv.pas | 156 ++++++++++-- rtl/inc/compproc.inc | 14 +- rtl/inc/objpas.inc | 15 +- 6 files changed, 659 insertions(+), 489 deletions(-) create mode 100644 compiler/ncgcnv.pas diff --git a/compiler/i386/cpunode.pas b/compiler/i386/cpunode.pas index 55be0911f1..f5446afa80 100644 --- a/compiler/i386/cpunode.pas +++ b/compiler/i386/cpunode.pas @@ -29,7 +29,7 @@ unit cpunode; implementation uses - ncgbas,ncgflw, + ncgbas,ncgflw,ncgcnv, n386ld,n386add,n386cal,n386con,n386flw,n386mat,n386mem, n386set,n386inl,n386opt, { this not really a node } @@ -38,7 +38,15 @@ unit cpunode; end. { $Log$ - Revision 1.5 2001-09-28 20:39:33 jonas + Revision 1.6 2001-09-29 21:32:47 jonas + * almost all second pass typeconvnode helpers are now processor independent + * fixed converting boolean to int64/qword + * fixed register allocation bugs which could cause internalerror 10 + * isnode and asnode are completely processor indepent now as well + * fpc_do_as now returns its class argument (necessary to be able to use it + properly with compilerproc) + + Revision 1.5 2001/09/28 20:39:33 jonas * changed all flow control structures (except for exception handling related things) to processor independent code (in new ncgflw unit) + generic cgobj unit which contains lots of code generator helpers with diff --git a/compiler/i386/n386cnv.pas b/compiler/i386/n386cnv.pas index 3614c14671..84d7045729 100644 --- a/compiler/i386/n386cnv.pas +++ b/compiler/i386/n386cnv.pas @@ -27,30 +27,30 @@ unit n386cnv; interface uses - node,ncnv,types; + node,ncnv,ncgcnv,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_real;virtual; - procedure second_cord_to_pointer;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_char_to_char;virtual; - procedure second_nothing;virtual; + ti386typeconvnode = class(tcgtypeconvnode) + protected + procedure second_int_to_int;override; + { procedure second_string_to_string;override; } + { procedure second_cstring_to_pchar;override; } + { procedure second_string_to_chararray;override; } + { procedure second_array_to_pointer;override; } + { procedure second_pointer_to_array;override; } + { procedure second_chararray_to_string;override; } + { procedure second_char_to_string;override; } + procedure second_int_to_real;override; + { procedure second_real_to_real;override; } + { procedure second_cord_to_pointer;override; } + { procedure second_proc_to_procvar;override; } + { procedure second_bool_to_int;override; } + procedure second_int_to_bool;override; + { procedure second_load_smallset;override; } + { procedure second_ansistring_to_pchar;override; } + { procedure second_pchar_to_string;override; } + { procedure second_class_to_intf;override; } + { procedure second_char_to_char;override; } procedure pass_2;override; procedure second_call_helper(c : tconverttype); end; @@ -201,141 +201,6 @@ implementation end; - procedure ti386typeconvnode.second_cstring_to_pchar; - var - hr : preference; - begin - clear_location(location); - location.loc:=LOC_REGISTER; - case tstringdef(left.resulttype.def).string_typ of - st_shortstring : - begin - inc(left.location.reference.offset); - del_reference(left.location.reference); - location.register:=getregister32; - 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'); - location.register:=getregister32; - emit_ref_reg(A_LEA,S_L,hr,location.register); - end - else - begin - del_reference(left.location.reference); - location.register:=getregister32; - emit_ref_reg(A_MOV,S_L,newreference(left.location.reference), - location.register); - end; - end; - st_longstring: - begin - {!!!!!!!} - internalerror(8888); - end; - st_widestring: - begin - if (left.nodetype=stringconstn) and - (str_length(left)=0) then - begin - new(hr); - reset_reference(hr^); - hr^.symbol:=newasmsymbol('FPC_EMPTYCHAR'); - location.register:=getregister32; - emit_ref_reg(A_LEA,S_L,hr,location.register); - end - else - begin - del_reference(left.location.reference); - location.register:=getregister32; - emit_ref_reg(A_MOV,S_L,newreference(left.location.reference), - location.register); - end; - end; - end; - end; - - - procedure ti386typeconvnode.second_string_to_chararray; - var - arrsize: longint; - begin - with tarraydef(resulttype.def) do - arrsize := highrange-lowrange+1; - if (left.nodetype = stringconstn) and - { left.length+1 since there's always a terminating #0 character (JM) } - (tstringconstnode(left).len+1 >= arrsize) and - (tstringdef(left.resulttype.def).string_typ=st_shortstring) then - begin - inc(location.reference.offset); - exit; - end - else - { should be handled already in resulttype pass (JM) } - internalerror(200108292); - 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; - - - procedure ti386typeconvnode.second_char_to_string; - - begin - clear_location(location); - location.loc:=LOC_MEM; - case tstringdef(resulttype.def).string_typ of - st_shortstring : - begin - gettempofsizereference(256,location.reference); - loadshortstring(left,self); - end; - { the rest is removed in the resulttype pass and coverted to compilerprocs } - else - internalerror(4179); - end; - end; - - procedure ti386typeconvnode.second_int_to_real; var @@ -454,175 +319,6 @@ implementation 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(tfloatdef(left.resulttype.def).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_cord_to_pointer; - begin - { this can't happend, because constants are already processed in - pass 1 } - internalerror(47423985); - 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 : tasmlabel; - 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.def.size=resulttype.def.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.def.size of - 1 : begin - case resulttype.def.size of - 1 : opsize:=S_B; - 2 : opsize:=S_BW; - 4 : opsize:=S_BL; - end; - end; - 2 : begin - case resulttype.def.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.def.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.def) then - op:=A_MOVSX - else - op:=A_MOVZX; - hregister:=getregister32; - case resulttype.def.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; @@ -630,8 +326,8 @@ implementation opsize : topsize; begin clear_location(location); - { byte(boolean) or word(wordbool) or longint(longbool) must - be accepted for var parameters } + { byte(boolean) or word(wordbool) or longint(longbool) must } + { be accepted for var parameters } if (nf_explizit in flags) and (left.resulttype.def.size=resulttype.def.size) and (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then @@ -640,7 +336,7 @@ implementation exit; end; location.loc:=LOC_REGISTER; - del_reference(left.location.reference); + del_location(left.location); opsize:=def_opsize(left.resulttype.def); case left.location.loc of LOC_MEM,LOC_REFERENCE : @@ -676,103 +372,6 @@ implementation 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_loadself; - popusedregisters(pushedregs); - clear_location(location); - location.loc:=LOC_MEM; - location.reference:=href; - end; - - - procedure ti386typeconvnode.second_ansistring_to_pchar; - var - l1 : tasmlabel; - 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_class_to_intf; - var - hreg : tregister; - l1 : tasmlabel; - 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,tobjectdef(left.resulttype.def).implementedinterfaces.ioffsets( - tobjectdef(left.resulttype.def).implementedinterfaces.searchintf(resulttype.def))^,hreg); - emitlab(l1); - location.loc:=LOC_REGISTER; - location.register:=hreg; - end; - - - procedure ti386typeconvnode.second_char_to_char; - begin - {$warning todo: add RTL routine for widechar-char conversion } - { Quick hack to atleast generate 'working' code (PFV) } - second_int_to_int; - end; - - - procedure ti386typeconvnode.second_nothing; - begin - end; - - {**************************************************************************** TI386TYPECONVNODE ****************************************************************************} @@ -781,33 +380,33 @@ implementation const secondconvert : array[tconverttype] of pointer = ( - @ti386typeconvnode.second_nothing, {equal} - @ti386typeconvnode.second_nothing, {not_possible} - @ti386typeconvnode.second_nothing, {second_string_to_string, handled in resulttype pass } - @ti386typeconvnode.second_char_to_string, - @ti386typeconvnode.second_nothing, { pchar_to_string, handled in resulttype pass } - @ti386typeconvnode.second_nothing, {cchar_to_pchar} - @ti386typeconvnode.second_cstring_to_pchar, - @ti386typeconvnode.second_ansistring_to_pchar, - @ti386typeconvnode.second_string_to_chararray, - @ti386typeconvnode.second_nothing, { chararray_to_string, handled in resulttype pass } - @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_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, - @ti386typeconvnode.second_char_to_char, - @ti386typeconvnode.second_nothing { normal_2_smallset } + @second_nothing, {equal} + @second_nothing, {not_possible} + @second_nothing, {second_string_to_string, handled in resulttype pass } + @second_char_to_string, + @second_nothing, { pchar_to_string, handled in resulttype pass } + @second_nothing, {cchar_to_pchar} + @second_cstring_to_pchar, + @second_ansistring_to_pchar, + @second_string_to_chararray, + @second_nothing, { chararray_to_string, handled in resulttype pass } + @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_proc_to_procvar, + @second_nothing, { arrayconstructor_to_set } + @second_nothing, { second_load_smallset, handled in first pass } + @second_cord_to_pointer, + @second_nothing, { interface 2 string } + @second_nothing, { interface 2 guid } + @second_class_to_intf, + @second_char_to_char, + @second_nothing { normal_2_smallset } ); type tprocedureofobject = procedure of object; @@ -1001,7 +600,15 @@ begin end. { $Log$ - Revision 1.23 2001-09-03 13:27:42 jonas + Revision 1.24 2001-09-29 21:32:47 jonas + * almost all second pass typeconvnode helpers are now processor independent + * fixed converting boolean to int64/qword + * fixed register allocation bugs which could cause internalerror 10 + * isnode and asnode are completely processor indepent now as well + * fpc_do_as now returns its class argument (necessary to be able to use it + properly with compilerproc) + + Revision 1.23 2001/09/03 13:27:42 jonas * compilerproc implementation of set addition/substraction/... * changed the declaration of some set helpers somewhat to accomodate the above change diff --git a/compiler/ncgcnv.pas b/compiler/ncgcnv.pas new file mode 100644 index 0000000000..a65e98eaa2 --- /dev/null +++ b/compiler/ncgcnv.pas @@ -0,0 +1,436 @@ +{ + $Id$ + Copyright (c) 2000 by Florian Klaempfl + + Generate assembler for nodes that handle type conversions which are + the same for all (most) processors + + 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 ncgcnv; + +{$i defines.inc} + +interface + + uses + node,ncnv; + + type + tcgtypeconvnode = class(ttypeconvnode) + procedure second_cstring_to_pchar;override; + procedure second_string_to_chararray;override; + procedure second_array_to_pointer;override; + procedure second_pointer_to_array;override; + procedure second_char_to_string;override; + procedure second_real_to_real;override; + procedure second_cord_to_pointer;override; + procedure second_proc_to_procvar;override; + procedure second_bool_to_int;override; + procedure second_ansistring_to_pchar;override; + procedure second_class_to_intf;override; + procedure second_char_to_char;override; + end; + + implementation + + uses + globtype, + cutils,cclasses,globals,verbose, + aasm,symconst,symsym,symtable,symdef,symtype,types, + ncon,ncal, + htypechk, + cpubase,cpuasm, + pass_2, + cgbase, + cga,cgobj,cgcpu, +{$ifdef i386} + n386util, +{$endif i386} + tgcpu,temp_gen + ; + + + procedure tcgtypeconvnode.second_cstring_to_pchar; + + var + hr : treference; + + begin + clear_location(location); + location.loc:=LOC_REGISTER; + case tstringdef(left.resulttype.def).string_typ of + st_shortstring : + begin + inc(left.location.reference.offset); + del_reference(left.location.reference); + location.register:=getregister32; + cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference, + location.register); + end; + st_ansistring : + begin + if (left.nodetype=stringconstn) and + (str_length(left)=0) then + begin + reset_reference(hr); + hr.symbol:=newasmsymbol('FPC_EMPTYCHAR'); + location.register:=getregister32; + cg.a_loadaddress_ref_reg(exprasmlist,hr,location.register); + end + else + begin + del_reference(left.location.reference); + location.register:=getregister32; + cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference, + location.register); + end; + end; + st_longstring: + begin + {!!!!!!!} + internalerror(8888); + end; + st_widestring: + begin + if (left.nodetype=stringconstn) and + (str_length(left)=0) then + begin + reset_reference(hr); + hr.symbol:=newasmsymbol('FPC_EMPTYCHAR'); + location.register:=getregister32; + cg.a_loadaddress_ref_reg(exprasmlist,hr,location.register); + end + else + begin + del_reference(left.location.reference); + location.register:=getregister32; +{$warning Todo: convert widestrings to ascii when typecasting them to pchars} + cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference, + location.register); + end; + end; + end; + end; + + + procedure tcgtypeconvnode.second_string_to_chararray; + + var + arrsize: longint; + + begin + with tarraydef(resulttype.def) do + arrsize := highrange-lowrange+1; + if (left.nodetype = stringconstn) and + { left.length+1 since there's always a terminating #0 character (JM) } + (tstringconstnode(left).len+1 >= arrsize) and + (tstringdef(left.resulttype.def).string_typ=st_shortstring) then + begin + inc(location.reference.offset); + exit; + end + else + { should be handled already in resulttype pass (JM) } + internalerror(200108292); + end; + + + procedure tcgtypeconvnode.second_array_to_pointer; + + begin + del_reference(left.location.reference); + clear_location(location); + location.loc:=LOC_REGISTER; + location.register:=getregister32; + cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference, + location.register); + end; + + + procedure tcgtypeconvnode.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; + cg.a_load_reg_reg(exprasmlist,OS_32,left.location.register, + location.reference.base); + end + else + begin + del_reference(left.location.reference); + location.reference.base:=getregister32; + cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference, + location.reference.base); + end; + end; + end; + + + procedure tcgtypeconvnode.second_char_to_string; + + begin + clear_location(location); + location.loc:=LOC_MEM; + case tstringdef(resulttype.def).string_typ of + st_shortstring : + begin + gettempofsizereference(256,location.reference); + loadshortstring(left,self); + end; + { the rest is removed in the resulttype pass and converted to compilerprocs } + else + internalerror(4179); + end; + end; + + + procedure tcgtypeconvnode.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(tfloatdef(left.resulttype.def).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 tcgtypeconvnode.second_cord_to_pointer; + begin + { this can't happen because constants are already processed in + pass 1 } + internalerror(47423985); + end; + + + procedure tcgtypeconvnode.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; + del_reference(left.location.reference); + location.register:=getregister32; + cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference, + location.register); + end; + end; + + + procedure tcgtypeconvnode.second_bool_to_int; + + var + oldtruelabel,oldfalselabel,hlabel : tasmlabel; + newsize, + opsize : tcgsize; + + 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.def.size=resulttype.def.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_location(left.location); + location.register:=getregister32; + { size of the boolean we're converting } + opsize := def_cgsize(left.resulttype.def); + { size of the destination } + newsize := def_cgsize(resulttype.def); + { the the source size is bigger than the destination, we can } + { simply decrease the sources size (since wordbool(true) = } + { boolean(true) etc... (JM) } + case newsize of + OS_8,OS_S8: + begin + opsize := OS_8; +{$ifdef i386} + location.register := makereg8(location.register); + if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then + makereg8(left.location.register); +{$endif i386} + end; + OS_16,OS_S16: + begin +{$ifdef i386} + location.register := makereg16(location.register); +{$endif i386} + if opsize in [OS_32,OS_S32] then + begin + opsize := OS_16; +{$ifdef i386} + if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then + makereg16(left.location.register); +{$endif i386} + end + end; + end; + case left.location.loc of + LOC_MEM, + LOC_REFERENCE : + cg.a_load_ref_reg(exprasmlist,opsize,left.location.reference, + location.register); + LOC_REGISTER, + LOC_CREGISTER : + if left.location.register<>location.register then + cg.a_load_reg_reg(exprasmlist,opsize,left.location.register, + location.register); + LOC_FLAGS : + cg.g_flags2reg(exprasmlist,left.location.resflags,location.register); + LOC_JUMP : + begin + getlabel(hlabel); + cg.a_label(exprasmlist,truelabel); + cg.a_load_const_reg(exprasmlist,newsize,1,location.register); + cg.a_jmp_cond(exprasmlist,OC_NONE,hlabel); + cg.a_label(exprasmlist,falselabel); + cg.a_load_const_reg(exprasmlist,newsize,0,location.register); + cg.a_label(exprasmlist,hlabel); + end; + else + internalerror(10061); + end; + truelabel:=oldtruelabel; + falselabel:=oldfalselabel; + end; + + + procedure tcgtypeconvnode.second_ansistring_to_pchar; + var + l1 : tasmlabel; + hr : treference; + 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 + del_reference(left.location.reference); + location.register:=getregister32; + cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference, + location.register); + end; + end; + cg.a_cmp_const_reg_label(exprasmlist,OS_32,OC_NE,0,location.register, + l1); + reset_reference(hr); + hr.symbol:=newasmsymbol('FPC_EMPTYCHAR'); + cg.a_loadaddress_ref_reg(exprasmlist,hr,location.register); + cg.a_label(exprasmlist,l1); + end; + + + procedure tcgtypeconvnode.second_class_to_intf; + var + hreg : tregister; + l1 : tasmlabel; + begin + case left.location.loc of + LOC_MEM, + LOC_REFERENCE: + begin + del_reference(left.location.reference); + hreg:=getregister32; + cg.a_load_ref_reg(exprasmlist,OS_32,left.location.reference, + hreg); + end; + LOC_CREGISTER: + begin + hreg:=getregister32; + cg.a_load_reg_reg(exprasmlist,OS_32,left.location.register, + hreg); + end; + LOC_REGISTER: + hreg:=left.location.register; + else internalerror(121120001); + end; + getlabel(l1); + cg.a_cmp_const_reg_label(exprasmlist,OS_32,OC_EQ,0,hreg,l1); + cg.a_op_const_reg(exprasmlist,OP_ADD, + tobjectdef(left.resulttype.def).implementedinterfaces.ioffsets( + tobjectdef(left.resulttype.def).implementedinterfaces.searchintf( + resulttype.def))^,hreg); + cg.a_label(exprasmlist,l1); + location.loc:=LOC_REGISTER; + location.register:=hreg; + end; + + + procedure tcgtypeconvnode.second_char_to_char; + begin + {$warning todo: add RTL routine for widechar-char conversion } + { Quick hack to atleast generate 'working' code (PFV) } + second_int_to_int; + end; + +begin + ctypeconvnode := tcgtypeconvnode; +end. + +{ + $Log$ + Revision 1.1 2001-09-29 21:32:47 jonas + * almost all second pass typeconvnode helpers are now processor independent + * fixed converting boolean to int64/qword + * fixed register allocation bugs which could cause internalerror 10 + * isnode and asnode are completely processor indepent now as well + * fpc_do_as now returns its class argument (necessary to be able to use it + properly with compilerproc) + + +} diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index bbeea2beaf..72fc5b8112 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -76,6 +76,28 @@ interface function first_class_to_intf : tnode;virtual; function first_char_to_char : tnode;virtual; function first_call_helper(c : tconverttype) : tnode; + + procedure second_int_to_int;virtual;abstract; + procedure second_string_to_string;virtual;abstract; + procedure second_cstring_to_pchar;virtual;abstract; + procedure second_string_to_chararray;virtual;abstract; + procedure second_array_to_pointer;virtual;abstract; + procedure second_pointer_to_array;virtual;abstract; + procedure second_chararray_to_string;virtual;abstract; + procedure second_char_to_string;virtual;abstract; + procedure second_int_to_real;virtual;abstract; + procedure second_real_to_real;virtual;abstract; + procedure second_cord_to_pointer;virtual;abstract; + procedure second_proc_to_procvar;virtual;abstract; + procedure second_bool_to_int;virtual;abstract; + procedure second_int_to_bool;virtual;abstract; + procedure second_load_smallset;virtual;abstract; + procedure second_ansistring_to_pchar;virtual;abstract; + procedure second_pchar_to_string;virtual;abstract; + procedure second_class_to_intf;virtual;abstract; + procedure second_char_to_char;virtual;abstract; + procedure second_nothing; virtual; + end; ttypeconvnodeclass = class of ttypeconvnode; @@ -117,6 +139,7 @@ implementation *****************************************************************************} procedure inserttypeconv(var p:tnode;const t:ttype); + begin if not assigned(p.resulttype.def) then begin @@ -397,8 +420,10 @@ implementation function ttypeconvnode.resulttype_cord_to_pointer : tnode; + var t : tnode; + begin result:=nil; if left.nodetype=ordconstn then @@ -427,6 +452,7 @@ implementation end; function ttypeconvnode.resulttype_chararray_to_string : tnode; + begin result := ccallnode.createinternres( 'fpc_chararray_to_'+lower(tstringdef(resulttype.def).stringtypname), @@ -435,8 +461,10 @@ implementation end; function ttypeconvnode.resulttype_string_to_chararray : tnode; + var arrsize: longint; + begin with tarraydef(resulttype.def) do begin @@ -460,12 +488,15 @@ implementation left := nil; end; + function ttypeconvnode.resulttype_string_to_string : tnode; + var procname: string[31]; stringpara : tcallparanode; pw : pcompilerwidestring; pc : pchar; + begin result:=nil; if left.nodetype=stringconstn then @@ -520,11 +551,13 @@ implementation function ttypeconvnode.resulttype_char_to_string : tnode; + var procname: string[31]; para : tcallparanode; hp : tstringconstnode; ws : pcompilerwidestring; + begin result:=nil; if left.nodetype=ordconstn then @@ -559,8 +592,10 @@ implementation function ttypeconvnode.resulttype_char_to_char : tnode; + var hp : tordconstnode; + begin result:=nil; if left.nodetype=ordconstn then @@ -587,8 +622,10 @@ implementation function ttypeconvnode.resulttype_int_to_real : tnode; + var t : trealconstnode; + begin result:=nil; if left.nodetype=ordconstn then @@ -601,8 +638,10 @@ implementation function ttypeconvnode.resulttype_real_to_real : tnode; + var t : tnode; + begin result:=nil; if left.nodetype=realconstn then @@ -614,6 +653,7 @@ implementation function ttypeconvnode.resulttype_cchar_to_pchar : tnode; + begin result:=nil; if is_pwidechar(resulttype.def) then @@ -628,6 +668,7 @@ implementation function ttypeconvnode.resulttype_cstring_to_pchar : tnode; + begin result:=nil; if is_pwidechar(resulttype.def) then @@ -636,8 +677,10 @@ implementation function ttypeconvnode.resulttype_arrayconstructor_to_set : tnode; + var hp : tnode; + begin result:=nil; if left.nodetype<>arrayconstructorn then @@ -652,6 +695,7 @@ implementation function ttypeconvnode.resulttype_pchar_to_string : tnode; + begin result := ccallnode.createinternres( 'fpc_pchar_to_'+lower(tstringdef(resulttype.def).stringtypname), @@ -711,9 +755,11 @@ implementation function ttypeconvnode.det_resulttype:tnode; + var hp : tnode; aprocdef : tprocdef; + begin result:=nil; resulttype:=totype; @@ -1048,6 +1094,7 @@ implementation function ttypeconvnode.first_cord_to_pointer : tnode; + begin result:=nil; internalerror(200104043); @@ -1055,6 +1102,7 @@ implementation function ttypeconvnode.first_int_to_int : tnode; + begin first_int_to_int:=nil; if (left.location.loc<>LOC_REGISTER) and @@ -1068,6 +1116,7 @@ implementation function ttypeconvnode.first_cstring_to_pchar : tnode; + begin first_cstring_to_pchar:=nil; registers32:=1; @@ -1076,6 +1125,7 @@ implementation function ttypeconvnode.first_string_to_chararray : tnode; + begin first_string_to_chararray:=nil; registers32:=1; @@ -1084,6 +1134,7 @@ implementation function ttypeconvnode.first_char_to_string : tnode; + begin first_char_to_string:=nil; location.loc:=LOC_MEM; @@ -1098,6 +1149,7 @@ implementation function ttypeconvnode.first_array_to_pointer : tnode; + begin first_array_to_pointer:=nil; if registers32<1 then @@ -1107,6 +1159,7 @@ implementation function ttypeconvnode.first_int_to_real : tnode; + begin first_int_to_real:=nil; {$ifdef m68k} @@ -1144,6 +1197,7 @@ implementation function ttypeconvnode.first_pointer_to_array : tnode; + begin first_pointer_to_array:=nil; if registers32<1 then @@ -1153,6 +1207,7 @@ implementation function ttypeconvnode.first_cchar_to_pchar : tnode; + begin first_cchar_to_pchar:=nil; internalerror(200104021); @@ -1160,6 +1215,7 @@ implementation function ttypeconvnode.first_bool_to_int : tnode; + begin first_bool_to_int:=nil; { byte(boolean) or word(wordbool) or longint(longbool) must @@ -1168,6 +1224,17 @@ implementation (left.resulttype.def.size=resulttype.def.size) and (left.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then exit; + { when converting to 64bit, first convert to a 32bit int and then } + { convert to a 64bit int (only necessary for 32bit processors) (JM) } + if resulttype.def.size > sizeof(aword) then + begin + result := ctypeconvnode.create(left,u32bittype); + result.toggleflag(nf_explizit); + result := ctypeconvnode.create(result,resulttype); + left := nil; + firstpass(result); + exit; + end; location.loc:=LOC_REGISTER; if registers32<1 then registers32:=1; @@ -1175,6 +1242,7 @@ implementation function ttypeconvnode.first_int_to_bool : tnode; + begin first_int_to_bool:=nil; { byte(boolean) or word(wordbool) or longint(longbool) must @@ -1204,6 +1272,7 @@ implementation function ttypeconvnode.first_char_to_char : tnode; + begin first_char_to_char:=nil; location.loc:=LOC_REGISTER; @@ -1225,12 +1294,29 @@ implementation function ttypeconvnode.first_load_smallset : tnode; + + var + srsym: ttypesym; + p: tcallparanode; + begin - first_load_smallset:=nil; + if not searchsystype('FPC_SMALL_SET',srsym) then + internalerror(200108313); + p := ccallparanode.create(left,nil); + { reused } + left := nil; + { convert parameter explicitely to fpc_small_set } + p.left := ctypeconvnode.create(p.left,srsym.restype); + p.left.toggleflag(nf_explizit); + { create call, adjust resulttype } + result := + ccallnode.createinternres('fpc_set_load_small',p,resulttype); + firstpass(result); end; function ttypeconvnode.first_ansistring_to_pchar : tnode; + begin first_ansistring_to_pchar:=nil; location.loc:=LOC_REGISTER; @@ -1254,6 +1340,7 @@ implementation registers32:=1; end; + function ttypeconvnode.first_call_helper(c : tconverttype) : tnode; const @@ -1345,6 +1432,19 @@ implementation end; + function ttypeconvnode.docompare(p: tnode) : boolean; + begin + docompare := + inherited docompare(p) and + (convtype = ttypeconvnode(p).convtype); + end; + + + procedure ttypeconvnode.second_nothing; + begin + end; + + {***************************************************************************** TISNODE *****************************************************************************} @@ -1391,16 +1491,16 @@ implementation function tisnode.pass_1 : tnode; + + var + paras: tcallparanode; + begin - result:=nil; - firstpass(left); - firstpass(right); - if codegenerror then - exit; - - left_right_max; - - location.loc:=LOC_FLAGS; + paras := ccallparanode.create(left,ccallparanode.create(right,nil)); + left := nil; + right := nil; + result := ccallnode.createintern('fpc_do_is',paras); + firstpass(result); end; @@ -1449,26 +1549,20 @@ implementation function tasnode.pass_1 : tnode; + + var + paras: tcallparanode; + begin - result:=nil; - firstpass(right); - firstpass(left); - if codegenerror then - exit; - - left_right_max; - - set_location(location,left.location); + paras := ccallparanode.create(left,ccallparanode.create(right,nil)); + left := nil; + right := nil; + result := ccallnode.createinternres('fpc_do_as',paras, + resulttype); + firstpass(result); end; - function ttypeconvnode.docompare(p: tnode) : boolean; - begin - docompare := - inherited docompare(p) and - (convtype = ttypeconvnode(p).convtype); - end; - begin ctypeconvnode:=ttypeconvnode; casnode:=tasnode; @@ -1476,7 +1570,15 @@ begin end. { $Log$ - Revision 1.37 2001-09-03 13:27:42 jonas + Revision 1.38 2001-09-29 21:32:46 jonas + * almost all second pass typeconvnode helpers are now processor independent + * fixed converting boolean to int64/qword + * fixed register allocation bugs which could cause internalerror 10 + * isnode and asnode are completely processor indepent now as well + * fpc_do_as now returns its class argument (necessary to be able to use it + properly with compilerproc) + + Revision 1.37 2001/09/03 13:27:42 jonas * compilerproc implementation of set addition/substraction/... * changed the declaration of some set helpers somewhat to accomodate the above change diff --git a/rtl/inc/compproc.inc b/rtl/inc/compproc.inc index 64384a6876..96fedfe0d5 100644 --- a/rtl/inc/compproc.inc +++ b/rtl/inc/compproc.inc @@ -99,7 +99,7 @@ Procedure fpc_widestr_Unique(Var S : WideString); compilerproc; Function fpc_Val_Real_AnsiStr(Const S : AnsiString; Var Code : ValSInt): ValReal; compilerproc; Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; Var Code : ValSInt): ValUInt; compilerproc; Function fpc_Val_SInt_AnsiStr (DestSize: longint; Const S : AnsiString; Var Code : ValSInt): ValSInt; compilerproc; -Function fpc_Val_qword_AnsiStr (Const S : AnsiString; Var Code : ValSInt): qword;compilerproc; +Function fpc_Val_qword_AnsiStr (Const S : AnsiString; Var Code : ValSInt): qword;compilerproc; Function fpc_Val_int64_AnsiStr (Const S : AnsiString; Var Code : ValSInt): Int64; compilerproc; procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring); compilerproc; Procedure fpc_AnsiStr_Cardinal(C : Cardinal;Len : Longint; Var S : AnsiString); compilerproc; @@ -165,7 +165,7 @@ function fpc_mul_qword(f1,f2 : qword;checkoverflow : longbool) : qword; compiler function fpc_mul_int64(f1,f2 : int64;checkoverflow : longbool) : int64; compilerproc; function fpc_do_is(aclass : tclass;aobject : tobject) : boolean; compilerproc; -procedure fpc_do_as(aclass : tclass;aobject : tobject); compilerproc; +function fpc_do_as(aclass : tclass;aobject : tobject): tobject; compilerproc; procedure fpc_intf_decr_ref(var i: pointer); compilerproc; procedure fpc_intf_incr_ref(const i: pointer); compilerproc; procedure fpc_intf_assign(var D: pointer; const S: pointer); compilerproc; @@ -247,7 +247,15 @@ Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;var Buf); compiler { $Log$ - Revision 1.10 2001-09-05 15:22:09 jonas + Revision 1.11 2001-09-29 21:32:47 jonas + * almost all second pass typeconvnode helpers are now processor independent + * fixed converting boolean to int64/qword + * fixed register allocation bugs which could cause internalerror 10 + * isnode and asnode are completely processor indepent now as well + * fpc_do_as now returns its class argument (necessary to be able to use it + properly with compilerproc) + + Revision 1.10 2001/09/05 15:22:09 jonas * made multiplying, dividing and mod'ing of int64 and qword processor independent with compilerprocs (+ small optimizations by using shift/and where possible) diff --git a/rtl/inc/objpas.inc b/rtl/inc/objpas.inc index fe2f2aaa40..17f2e944b7 100644 --- a/rtl/inc/objpas.inc +++ b/rtl/inc/objpas.inc @@ -27,10 +27,11 @@ { the reverse order of the parameters make code generation easier } - procedure fpc_do_as(aclass : tclass;aobject : tobject);[public,alias: 'FPC_DO_AS']; {$ifdef hascompilerproc} compilerproc; {$endif} + function fpc_do_as(aclass : tclass;aobject : tobject): tobject;[public,alias: 'FPC_DO_AS']; {$ifdef hascompilerproc} compilerproc; {$endif} begin if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then - handleerror(219); + handleerrorframe(219,get_frame); + result := aobject; end; {$ifndef HASINTF} @@ -692,7 +693,15 @@ { $Log$ - Revision 1.16 2001-08-01 15:00:10 jonas + Revision 1.17 2001-09-29 21:32:47 jonas + * almost all second pass typeconvnode helpers are now processor independent + * fixed converting boolean to int64/qword + * fixed register allocation bugs which could cause internalerror 10 + * isnode and asnode are completely processor indepent now as well + * fpc_do_as now returns its class argument (necessary to be able to use it + properly with compilerproc) + + Revision 1.16 2001/08/01 15:00:10 jonas + "compproc" helpers * renamed several helpers so that their name is the same as their "public alias", which should facilitate the conversion of processor