diff options
Diffstat (limited to 'closures/compiler/ncgcon.pas')
| -rw-r--r-- | closures/compiler/ncgcon.pas | 493 |
1 files changed, 493 insertions, 0 deletions
diff --git a/closures/compiler/ncgcon.pas b/closures/compiler/ncgcon.pas new file mode 100644 index 0000000000..b64d25ed00 --- /dev/null +++ b/closures/compiler/ncgcon.pas @@ -0,0 +1,493 @@ +{ + Copyright (c) 1998-2002 by Florian Klaempfl + + Generate assembler for constant nodes 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 ncgcon; + +{$i fpcdefs.inc} + +interface + + uses + node,ncon; + + type + tcgdataconstnode = class(tdataconstnode) + procedure pass_generate_code;override; + end; + + tcgrealconstnode = class(trealconstnode) + procedure pass_generate_code;override; + end; + + tcgordconstnode = class(tordconstnode) + procedure pass_generate_code;override; + end; + + tcgpointerconstnode = class(tpointerconstnode) + procedure pass_generate_code;override; + end; + + tcgstringconstnode = class(tstringconstnode) + procedure pass_generate_code;override; + end; + + tcgsetconstnode = class(tsetconstnode) + procedure pass_generate_code;override; + end; + + tcgnilnode = class(tnilnode) + procedure pass_generate_code;override; + end; + + tcgguidconstnode = class(tguidconstnode) + procedure pass_generate_code;override; + end; + + +implementation + + uses + globtype,widestr,systems, + verbose,globals,cutils, + symconst,symdef,aasmbase,aasmtai,aasmdata,aasmcpu,defutil, + cpuinfo,cpubase, + cgbase,cgobj,cgutils, + ncgutil, cclasses,asmutils + ; + + +{***************************************************************************** + TCGREALCONSTNODE +*****************************************************************************} + + procedure tcgdataconstnode.pass_generate_code; + var + l : tasmlabel; + i : longint; + b : byte; + begin + location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(maxalign)); + current_asmdata.getdatalabel(l); + maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]); + new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata,l.name,const_align(maxalign)); + current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(l)); + data.seek(0); + for i:=0 to data.size-1 do + begin + data.read(b,1); + current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(b)); + end; + location.reference.symbol:=l; + end; + +{***************************************************************************** + TCGREALCONSTNODE +*****************************************************************************} + + procedure tcgrealconstnode.pass_generate_code; + { I suppose the parser/pass_1 must make sure the generated real } + { constants are actually supported by the target processor? (JM) } + const + floattype2ait:array[tfloattype] of taitype= + (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_real_80bit,ait_comp_64bit,ait_comp_64bit,ait_real_128bit); + + { Since the value is stored always as bestreal, we share a single pool + between all float types. This requires type and hiloswapped flag to + be matched along with the value } + type + tfloatkey = record + value: bestreal; + typ: tfloattype; + swapped: boolean; + end; + + var + lastlabel : tasmlabel; + realait : taitype; + entry : PHashSetItem; + key: tfloatkey; +{$ifdef ARM} + hiloswapped : boolean; +{$endif ARM} + + begin + location_reset_ref(location,LOC_CREFERENCE,def_cgsize(resultdef),const_align(resultdef.alignment)); + lastlabel:=nil; + realait:=floattype2ait[tfloatdef(resultdef).floattype]; +{$ifdef ARM} + hiloswapped:=is_double_hilo_swapped; +{$endif ARM} + { const already used ? } + if not assigned(lab_real) then + begin + { there may be gap between record fields, zero it out } + fillchar(key,sizeof(key),0); + key.value:=value_real; + key.typ:=tfloatdef(resultdef).floattype; +{$ifdef ARM} + key.swapped:=hiloswapped; +{$endif ARM} + entry := current_asmdata.ConstPools[sp_floats].FindOrAdd(@key, sizeof(key)); + + lab_real := TAsmLabel(entry^.Data); // is it needed anymore? + + { :-(, we must generate a new entry } + if not assigned(lab_real) then + begin + current_asmdata.getdatalabel(lastlabel); + entry^.Data:=lastlabel; + lab_real:=lastlabel; + maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]); + new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(resultdef.alignment)); + current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lastlabel)); + case realait of + ait_real_32bit : + begin + current_asmdata.asmlists[al_typedconsts].concat(Tai_real_32bit.Create(ts32real(value_real))); + { range checking? } + if floating_point_range_check_error and + (tai_real_32bit(current_asmdata.asmlists[al_typedconsts].last).value=MathInf.Value) then + Message(parser_e_range_check_error); + end; + + ait_real_64bit : + begin +{$ifdef ARM} + if hiloswapped then + current_asmdata.asmlists[al_typedconsts].concat(Tai_real_64bit.Create_hiloswapped(ts64real(value_real))) + else +{$endif ARM} + current_asmdata.asmlists[al_typedconsts].concat(Tai_real_64bit.Create(ts64real(value_real))); + + { range checking? } + if floating_point_range_check_error and + (tai_real_64bit(current_asmdata.asmlists[al_typedconsts].last).value=MathInf.Value) then + Message(parser_e_range_check_error); + end; + + ait_real_80bit : + begin + current_asmdata.asmlists[al_typedconsts].concat(Tai_real_80bit.Create(value_real,resultdef.size)); + + { range checking? } + if floating_point_range_check_error and + (tai_real_80bit(current_asmdata.asmlists[al_typedconsts].last).value=MathInf.Value) then + Message(parser_e_range_check_error); + end; +{$ifdef cpufloat128} + ait_real_128bit : + begin + current_asmdata.asmlists[al_typedconsts].concat(Tai_real_128bit.Create(value_real)); + + { range checking? } + if floating_point_range_check_error and + (tai_real_128bit(current_asmdata.asmlists[al_typedconsts].last).value=MathInf.Value) then + Message(parser_e_range_check_error); + end; +{$endif cpufloat128} + + { the round is necessary for native compilers where comp isn't a float } + ait_comp_64bit : + if (value_real>9223372036854775807.0) or (value_real<-9223372036854775808.0) then + message(parser_e_range_check_error) + else + current_asmdata.asmlists[al_typedconsts].concat(Tai_comp_64bit.Create(round(value_real))); + else + internalerror(10120); + end; + end; + end; + location.reference.symbol:=lab_real; + end; + +{***************************************************************************** + TCGORDCONSTNODE +*****************************************************************************} + + procedure tcgordconstnode.pass_generate_code; + begin + location_reset(location,LOC_CONSTANT,def_cgsize(resultdef)); +{$ifdef cpu64bitalu} + location.value:=value.svalue; +{$else cpu64bitalu} + location.value64:=value.svalue; +{$endif cpu64bitalu} + end; + + +{***************************************************************************** + TCGPOINTERCONSTNODE +*****************************************************************************} + + procedure tcgpointerconstnode.pass_generate_code; + begin + { an integer const. behaves as a memory reference } + location_reset(location,LOC_CONSTANT,OS_ADDR); + location.value:=aint(value); + end; + + +{***************************************************************************** + TCGSTRINGCONSTNODE +*****************************************************************************} + + procedure tcgstringconstnode.pass_generate_code; + var + lastlabel: tasmlabel; + pc: pchar; + l: longint; + href: treference; + pool: THashSet; + entry: PHashSetItem; + + const + PoolMap: array[tconststringtype] of TConstPoolType = ( + sp_conststr, + sp_shortstr, + sp_longstr, + sp_ansistr, + sp_widestr, + sp_unicodestr + ); + begin + { for empty ansistrings we could return a constant 0 } + if (cst_type in [cst_ansistring,cst_widestring,cst_unicodestring]) and (len=0) then + begin + location_reset(location,LOC_CONSTANT,OS_ADDR); + location.value:=0; + exit; + end; + { const already used ? } + if not assigned(lab_str) then + begin + pool := current_asmdata.ConstPools[PoolMap[cst_type]]; + + if cst_type in [cst_widestring, cst_unicodestring] then + entry := pool.FindOrAdd(pcompilerwidestring(value_str)^.data,len*cwidechartype.size) + else + if cst_type = cst_ansistring then + entry := PHashSetItem(TTagHashSet(pool).FindOrAdd(value_str,len,tstringdef(resultdef).encoding)) + else + entry := pool.FindOrAdd(value_str,len); + + lab_str := TAsmLabel(entry^.Data); // is it needed anymore? + + { :-(, we must generate a new entry } + if not assigned(entry^.Data) then + begin + case cst_type of + cst_ansistring: + begin + if len=0 then + InternalError(2008032301) { empty string should be handled above } + else + lastlabel:=emit_ansistring_const(current_asmdata.AsmLists[al_typedconsts],value_str,len,tstringdef(resultdef).encoding); + end; + cst_unicodestring, + cst_widestring: + begin + if len=0 then + InternalError(2008032302) { empty string should be handled above } + else + lastlabel := emit_unicodestring_const(current_asmdata.AsmLists[al_typedconsts], + value_str, + tstringdef(resultdef).encoding, + (cst_type=cst_widestring) and (tf_winlikewidestring in target_info.flags)); + end; + cst_shortstring: + begin + current_asmdata.getdatalabel(lastlabel); + maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]); + new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(sizeof(pint))); + + current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lastlabel)); + { truncate strings larger than 255 chars } + if len>255 then + l:=255 + else + l:=len; + { include length and terminating zero for quick conversion to pchar } + getmem(pc,l+2); + move(value_str^,pc[1],l); + pc[0]:=chr(l); + pc[l+1]:=#0; + current_asmdata.asmlists[al_typedconsts].concat(Tai_string.Create_pchar(pc,l+2)); + end; + cst_conststring: + begin + current_asmdata.getdatalabel(lastlabel); + maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]); + new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(sizeof(pint))); + + current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lastlabel)); + { include terminating zero } + getmem(pc,len+1); + move(value_str^,pc[0],len); + pc[len]:=#0; + current_asmdata.asmlists[al_typedconsts].concat(Tai_string.Create_pchar(pc,len+1)); + end; + end; + lab_str:=lastlabel; + entry^.Data:=lastlabel; + end; + end; + if cst_type in [cst_ansistring, cst_widestring, cst_unicodestring] then + begin + location_reset(location, LOC_REGISTER, OS_ADDR); + reference_reset_symbol(href, lab_str, 0, const_align(sizeof(pint))); + location.register:=cg.getaddressregister(current_asmdata.CurrAsmList); + cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,href,location.register); + end + else + begin + location_reset_ref(location, LOC_CREFERENCE, def_cgsize(resultdef), const_align(sizeof(pint))); + location.reference.symbol:=lab_str; + end; + end; + + +{***************************************************************************** + TCGSETCONSTNODE +*****************************************************************************} + + procedure tcgsetconstnode.pass_generate_code; + + type + setbytes=array[0..31] of byte; + Psetbytes=^setbytes; + + procedure smallsetconst; + begin + location_reset(location,LOC_CONSTANT,int_cgsize(resultdef.size)); + if (source_info.endian=target_info.endian) then + begin + { not plongint, because that will "sign extend" the set on 64 bit platforms } + { if changed to "paword", please also modify "32-resultdef.size*8" and } + { cross-endian code below } + { Extra aint type cast to avoid range errors } + location.value:=aint(pCardinal(value_set)^) + end + else + begin + location.value:=swapendian(Pcardinal(value_set)^); + location.value:=aint( + reverse_byte (location.value and $ff) or + (reverse_byte((location.value shr 8) and $ff) shl 8) or + (reverse_byte((location.value shr 16) and $ff) shl 16) or + (reverse_byte((location.value shr 24) and $ff) shl 24) + ); + end; + if (target_info.endian=endian_big) then + location.value:=location.value shr (32-resultdef.size*8); + end; + + procedure varsetconst; + var + lastlabel : tasmlabel; + i : longint; + entry : PHashSetItem; + begin + location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(8)); + lastlabel:=nil; + { const already used ? } + if not assigned(lab_set) then + begin + entry := current_asmdata.ConstPools[sp_varsets].FindOrAdd(value_set, 32); + + lab_set := TAsmLabel(entry^.Data); // is it needed anymore? + + { :-(, we must generate a new entry } + if not assigned(entry^.Data) then + begin + current_asmdata.getdatalabel(lastlabel); + lab_set:=lastlabel; + entry^.Data:=lastlabel; + maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]); + new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(8)); + current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lastlabel)); + if (source_info.endian=target_info.endian) then + for i:=0 to 31 do + current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i])) + else + for i:=0 to 31 do + current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i]))); + end; + end; + location.reference.symbol:=lab_set; + end; + + begin + adjustforsetbase; + + { small sets are loaded as constants } + if is_smallset(resultdef) then + smallsetconst + else + varsetconst; + end; + + +{***************************************************************************** + TCGNILNODE +*****************************************************************************} + + procedure tcgnilnode.pass_generate_code; + begin + location_reset(location,LOC_CONSTANT,OS_ADDR); + location.value:=0; + end; + + +{***************************************************************************** + TCGGUIDCONSTNODE +*****************************************************************************} + + procedure tcgguidconstnode.pass_generate_code; + var + tmplabel : TAsmLabel; + i : integer; + begin + location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(16)); + { label for GUID } + current_asmdata.getdatalabel(tmplabel); + maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]); + new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,tmplabel.name,const_align(16)); + current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(tmplabel)); + current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_32bit(longint(value.D1))); + current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_16bit(value.D2)); + current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_16bit(value.D3)); + for i:=low(value.D4) to high(value.D4) do + current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(value.D4[i])); + location.reference.symbol:=tmplabel; + end; + + +begin + cdataconstnode:=tcgdataconstnode; + crealconstnode:=tcgrealconstnode; + cordconstnode:=tcgordconstnode; + cpointerconstnode:=tcgpointerconstnode; + cstringconstnode:=tcgstringconstnode; + csetconstnode:=tcgsetconstnode; + cnilnode:=tcgnilnode; + cguidconstnode:=tcgguidconstnode; +end. |