123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710 |
- {
- $Id$
- 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
- tcgrealconstnode = class(trealconstnode)
- procedure pass_2;override;
- end;
- tcgordconstnode = class(tordconstnode)
- procedure pass_2;override;
- end;
- tcgpointerconstnode = class(tpointerconstnode)
- procedure pass_2;override;
- end;
- tcgstringconstnode = class(tstringconstnode)
- procedure pass_2;override;
- end;
- tcgsetconstnode = class(tsetconstnode)
- procedure pass_2;override;
- end;
- tcgnilnode = class(tnilnode)
- procedure pass_2;override;
- end;
- tcgguidconstnode = class(tguidconstnode)
- procedure pass_2;override;
- end;
- implementation
- uses
- globtype,widestr,systems,
- verbose,globals,
- symconst,symdef,aasmbase,aasmtai,aasmcpu,defutil,
- cpuinfo,cpubase,
- cgbase,tgobj,cgobj
- {$ifdef delphi}
- ,dmisc
- {$endif}
- ;
- {*****************************************************************************
- TCGREALCONSTNODE
- *****************************************************************************}
- procedure tcgrealconstnode.pass_2;
- { 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_comp_64bit,ait_comp_64bit,ait_real_128bit);
- var
- hp1 : tai;
- lastlabel : tasmlabel;
- realait : taitype;
- begin
- location_reset(location,LOC_CREFERENCE,def_cgsize(resulttype.def));
- lastlabel:=nil;
- realait:=floattype2ait[tfloatdef(resulttype.def).typ];
- { const already used ? }
- if not assigned(lab_real) then
- begin
- { tries to find an old entry }
- hp1:=tai(Consts.first);
- while assigned(hp1) do
- begin
- if hp1.typ=ait_label then
- lastlabel:=tai_label(hp1).l
- else
- begin
- if (hp1.typ=realait) and (lastlabel<>nil) then
- begin
- if is_number_float(value_real) and
- (
- ((realait=ait_real_32bit) and (tai_real_32bit(hp1).value=value_real) and is_number_float(tai_real_32bit(hp1).value)) or
- ((realait=ait_real_64bit) and (tai_real_64bit(hp1).value=value_real) and is_number_float(tai_real_64bit(hp1).value)) or
- ((realait=ait_real_80bit) and (tai_real_80bit(hp1).value=value_real) and is_number_float(tai_real_80bit(hp1).value)) or
- {$ifdef cpufloat128}
- ((realait=ait_real_128bit) and (tai_real_128bit(hp1).value=value_real) and is_number_float(tai_real_128bit(hp1).value)) or
- {$endif cpufloat128}
- ((realait=ait_comp_64bit) and (tai_comp_64bit(hp1).value=value_real) and is_number_float(tai_comp_64bit(hp1).value))
- ) then
- begin
- { found! }
- lab_real:=lastlabel;
- break;
- end;
- end;
- lastlabel:=nil;
- end;
- hp1:=tai(hp1.next);
- end;
- { :-(, we must generate a new entry }
- if not assigned(lab_real) then
- begin
- objectlibrary.getdatalabel(lastlabel);
- lab_real:=lastlabel;
- if (cs_create_smart in aktmoduleswitches) then
- Consts.concat(Tai_cut.Create);
- consts.concat(tai_align.create(const_align(4)));
- Consts.concat(Tai_label.Create(lastlabel));
- case realait of
- ait_real_32bit :
- Consts.concat(Tai_real_32bit.Create(ts32real(value_real)));
- ait_real_64bit :
- Consts.concat(Tai_real_64bit.Create(ts64real(value_real)));
- ait_real_80bit :
- Consts.concat(Tai_real_80bit.Create(value_real));
- {$ifdef cpufloat128}
- ait_real_128bit :
- Consts.concat(Tai_real_128bit.Create(value_real));
- {$endif cpufloat128}
- {$ifdef ver1_0}
- ait_comp_64bit :
- Consts.concat(Tai_comp_64bit.Create(value_real));
- {$else ver1_0}
- { the round is necessary for native compilers where comp isn't a float }
- ait_comp_64bit :
- begin
- if (value_real>9223372036854775807.0) or (value_real<-9223372036854775808.0) then
- Message(parser_e_range_check_error)
- else
- Consts.concat(Tai_comp_64bit.Create(round(value_real)));
- end;
- {$endif ver1_0}
- else
- internalerror(10120);
- end;
- end;
- end;
- location.reference.symbol:=lab_real;
- end;
- {*****************************************************************************
- TCGORDCONSTNODE
- *****************************************************************************}
- procedure tcgordconstnode.pass_2;
- begin
- location_reset(location,LOC_CONSTANT,def_cgsize(resulttype.def));
- location.valueqword:=TConstExprUInt(value);
- end;
- {*****************************************************************************
- TCGPOINTERCONSTNODE
- *****************************************************************************}
- procedure tcgpointerconstnode.pass_2;
- begin
- { an integer const. behaves as a memory reference }
- location_reset(location,LOC_CONSTANT,OS_ADDR);
- location.value:=AWord(value);
- end;
- {*****************************************************************************
- TCGSTRINGCONSTNODE
- *****************************************************************************}
- procedure tcgstringconstnode.pass_2;
- var
- hp1,hp2 : tai;
- l1,l2,
- lastlabel : tasmlabel;
- lastlabelhp : tai;
- pc : pchar;
- same_string : boolean;
- l,j,
- i,mylength : longint;
- begin
- { for empty ansistrings we could return a constant 0 }
- if (st_type in [st_ansistring,st_widestring]) and
- (len=0) then
- begin
- location_reset(location,LOC_CONSTANT,OS_ADDR);
- location.value:=0;
- exit;
- end;
- { return a constant reference in memory }
- location_reset(location,LOC_CREFERENCE,def_cgsize(resulttype.def));
- { const already used ? }
- lastlabel:=nil;
- lastlabelhp:=nil;
- if not assigned(lab_str) then
- begin
- if is_shortstring(resulttype.def) then
- mylength:=len+2
- else
- mylength:=len+1;
- { widestrings can't be reused yet }
- if not(is_widestring(resulttype.def)) then
- begin
- { tries to found an old entry }
- hp1:=tai(Consts.first);
- while assigned(hp1) do
- begin
- if hp1.typ=ait_label then
- begin
- lastlabel:=tai_label(hp1).l;
- lastlabelhp:=hp1;
- end
- else
- begin
- { when changing that code, be careful that }
- { you don't use typed consts, which are }
- { are also written to consts }
- { currently, this is no problem, because }
- { typed consts have no leading length or }
- { they have no trailing zero }
- if (hp1.typ=ait_string) and (lastlabel<>nil) and
- (tai_string(hp1).len=mylength) then
- begin
- same_string:=true;
- { if shortstring then check the length byte first and
- set the start index to 1 }
- case st_type of
- st_shortstring:
- begin
- if len=ord(tai_string(hp1).str[0]) then
- j:=1
- else
- same_string:=false;
- end;
- st_ansistring,
- st_widestring :
- begin
- { before the string the following sequence must be found:
- <label>
- constsymbol <datalabel>
- const32 <len>
- const32 <len>
- const32 -1
- we must then return <label> to reuse
- }
- hp2:=tai(lastlabelhp.previous);
- if assigned(hp2) and
- (hp2.typ=ait_const_32bit) and
- (tai_const(hp2).value=-1) and
- assigned(hp2.previous) and
- (tai(hp2.previous).typ=ait_const_32bit) and
- (tai_const(hp2.previous).value=len) and
- assigned(hp2.previous.previous) and
- (tai(hp2.previous.previous).typ=ait_const_32bit) and
- (tai_const(hp2.previous.previous).value=len) and
- assigned(hp2.previous.previous.previous) and
- (tai(hp2.previous.previous.previous).typ=ait_const_symbol) and
- assigned(hp2.previous.previous.previous.previous) and
- (tai(hp2.previous.previous.previous.previous).typ=ait_label) then
- begin
- lastlabel:=tai_label(hp2.previous.previous.previous.previous).l;
- j:=0;
- end
- else
- same_string:=false;
- end;
- else
- same_string:=false;
- end;
- { don't check if the length byte was already wrong }
- if same_string then
- begin
- for i:=0 to len do
- begin
- if tai_string(hp1).str[j]<>value_str[i] then
- begin
- same_string:=false;
- break;
- end;
- inc(j);
- end;
- end;
- { found ? }
- if same_string then
- begin
- lab_str:=lastlabel;
- break;
- end;
- end;
- lastlabel:=nil;
- end;
- hp1:=tai(hp1.next);
- end;
- end;
- { :-(, we must generate a new entry }
- if not assigned(lab_str) then
- begin
- objectlibrary.getdatalabel(lastlabel);
- lab_str:=lastlabel;
- if (cs_create_smart in aktmoduleswitches) then
- Consts.concat(Tai_cut.Create);
- consts.concat(tai_align.create(const_align(4)));
- Consts.concat(Tai_label.Create(lastlabel));
- { generate an ansi string ? }
- case st_type of
- st_ansistring:
- begin
- { an empty ansi string is nil! }
- if len=0 then
- Consts.concat(Tai_const.Create_32bit(0))
- else
- begin
- objectlibrary.getdatalabel(l1);
- objectlibrary.getdatalabel(l2);
- Consts.concat(Tai_label.Create(l2));
- Consts.concat(Tai_const_symbol.Create(l1));
- Consts.concat(Tai_const.Create_32bit(len));
- Consts.concat(Tai_const.Create_32bit(len));
- Consts.concat(Tai_const.Create_32bit(-1));
- Consts.concat(Tai_label.Create(l1));
- getmem(pc,len+2);
- move(value_str^,pc^,len);
- pc[len]:=#0;
- { to overcome this problem we set the length explicitly }
- { with the ending null char }
- Consts.concat(Tai_string.Create_length_pchar(pc,len+1));
- { return the offset of the real string }
- lab_str:=l2;
- end;
- end;
- st_widestring:
- begin
- { an empty wide string is nil! }
- if len=0 then
- Consts.concat(Tai_const.Create_32bit(0))
- else
- begin
- objectlibrary.getdatalabel(l1);
- objectlibrary.getdatalabel(l2);
- Consts.concat(Tai_label.Create(l2));
- Consts.concat(Tai_const_symbol.Create(l1));
- { we use always UTF-16 coding for constants }
- { at least for now }
- { Consts.concat(Tai_const.Create_8bit(2)); }
- Consts.concat(Tai_const.Create_32bit(len));
- Consts.concat(Tai_const.Create_32bit(len));
- Consts.concat(Tai_const.Create_32bit(-1));
- Consts.concat(Tai_label.Create(l1));
- for i:=0 to len-1 do
- Consts.concat(Tai_const.Create_16bit(pcompilerwidestring(value_str)^.data[i]));
- { terminating zero }
- Consts.concat(Tai_const.Create_16bit(0));
- { return the offset of the real string }
- lab_str:=l2;
- end;
- end;
- st_shortstring:
- begin
- { truncate strings larger than 255 chars }
- if len>255 then
- l:=255
- else
- l:=len;
- { also length and terminating zero }
- getmem(pc,l+3);
- move(value_str^,pc[1],l+1);
- pc[0]:=chr(l);
- { to overcome this problem we set the length explicitly }
- { with the ending null char }
- pc[l+1]:=#0;
- Consts.concat(Tai_string.Create_length_pchar(pc,l+2));
- end;
- end;
- end;
- end;
- location.reference.symbol:=lab_str;
- end;
- {*****************************************************************************
- TCGSETCONSTNODE
- *****************************************************************************}
- procedure tcgsetconstnode.pass_2;
- var
- hp1 : tai;
- lastlabel : tasmlabel;
- i : longint;
- neededtyp : taitype;
- indexadjust : longint;
- type
- setbytes=array[0..31] of byte;
- Psetbytes=^setbytes;
- begin
- { xor indexadjust with indexes in a set typecasted to an array of }
- { bytes to get the correct locations, also when endianess of source }
- { and destiantion differs (JM) }
- if (source_info.endian = target_info.endian) then
- indexadjust := 0
- else
- indexadjust := 3;
- { small sets are loaded as constants }
- if tsetdef(resulttype.def).settype=smallset then
- begin
- location_reset(location,LOC_CONSTANT,OS_32);
- location.value:=PAWord(value_set)^;
- exit;
- end;
- location_reset(location,LOC_CREFERENCE,OS_NO);
- neededtyp:=ait_const_8bit;
- lastlabel:=nil;
- { const already used ? }
- if not assigned(lab_set) then
- begin
- { tries to found an old entry }
- hp1:=tai(Consts.first);
- while assigned(hp1) do
- begin
- if hp1.typ=ait_label then
- lastlabel:=tai_label(hp1).l
- else
- begin
- if (lastlabel<>nil) and (hp1.typ=neededtyp) then
- begin
- if (hp1.typ=ait_const_8bit) then
- begin
- { compare normal set }
- i:=0;
- while assigned(hp1) and (i<32) do
- begin
- if tai_const(hp1).value<>Psetbytes(value_set)^[i xor indexadjust] then
- break;
- inc(i);
- hp1:=tai(hp1.next);
- end;
- if i=32 then
- begin
- { found! }
- lab_set:=lastlabel;
- break;
- end;
- { leave when the end of consts is reached, so no
- hp1.next is done }
- if not assigned(hp1) then
- break;
- end
- else
- begin
- { compare small set }
- if plongint(value_set)^=tai_const(hp1).value then
- begin
- { found! }
- lab_set:=lastlabel;
- break;
- end;
- end;
- end;
- lastlabel:=nil;
- end;
- hp1:=tai(hp1.next);
- end;
- { :-(, we must generate a new entry }
- if not assigned(lab_set) then
- begin
- objectlibrary.getdatalabel(lastlabel);
- lab_set:=lastlabel;
- if (cs_create_smart in aktmoduleswitches) then
- Consts.concat(Tai_cut.Create);
- consts.concat(tai_align.create(const_align(4)));
- Consts.concat(Tai_label.Create(lastlabel));
- { already handled at the start of this method?? (JM)
- if tsetdef(resulttype.def).settype=smallset then
- begin
- move(value_set^,i,sizeof(longint));
- Consts.concat(Tai_const.Create_32bit(i));
- end
- else
- }
- begin
- for i:=0 to 31 do
- Consts.concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i xor indexadjust]));
- end;
- end;
- end;
- location.reference.symbol:=lab_set;
- end;
- {*****************************************************************************
- TCGNILNODE
- *****************************************************************************}
- procedure tcgnilnode.pass_2;
- begin
- location_reset(location,LOC_CONSTANT,OS_ADDR);
- location.value:=0;
- end;
- {*****************************************************************************
- TCGPOINTERCONSTNODE
- *****************************************************************************}
- procedure tcgguidconstnode.pass_2;
- var
- tmplabel : TAsmLabel;
- i : integer;
- begin
- location_reset(location,LOC_CREFERENCE,OS_NO);
- { label for GUID }
- objectlibrary.getdatalabel(tmplabel);
- consts.concat(tai_align.create(const_align(16)));
- consts.concat(Tai_label.Create(tmplabel));
- consts.concat(Tai_const.Create_32bit(value.D1));
- consts.concat(Tai_const.Create_16bit(value.D2));
- consts.concat(Tai_const.Create_16bit(value.D3));
- for i:=Low(value.D4) to High(value.D4) do
- consts.concat(Tai_const.Create_8bit(value.D4[i]));
- location.reference.symbol:=tmplabel;
- end;
- begin
- crealconstnode:=tcgrealconstnode;
- cordconstnode:=tcgordconstnode;
- cpointerconstnode:=tcgpointerconstnode;
- cstringconstnode:=tcgstringconstnode;
- csetconstnode:=tcgsetconstnode;
- cnilnode:=tcgnilnode;
- cguidconstnode:=tcgguidconstnode;
- end.
- {
- $Log$
- Revision 1.33 2003-10-26 13:37:22 florian
- * fixed web bug 2128
- Revision 1.32 2003/10/10 17:48:13 peter
- * old trgobj moved to x86/rgcpu and renamed to trgx86fpu
- * tregisteralloctor renamed to trgobj
- * removed rgobj from a lot of units
- * moved location_* and reference_* to cgobj
- * first things for mmx register allocation
- Revision 1.31 2003/10/01 20:34:48 peter
- * procinfo unit contains tprocinfo
- * cginfo renamed to cgbase
- * moved cgmessage to verbose
- * fixed ppc and sparc compiles
- Revision 1.30 2003/09/06 16:47:24 florian
- + support of NaN and Inf in the compiler as values of real constants
- Revision 1.29 2003/09/03 15:55:00 peter
- * NEWRA branch merged
- Revision 1.28 2003/05/01 12:24:22 jonas
- * fixed endian issues when writing out set constants
- Revision 1.27 2003/04/24 22:29:57 florian
- * fixed a lot of PowerPC related stuff
- Revision 1.26 2003/01/05 13:36:53 florian
- * x86-64 compiles
- + very basic support for float128 type (x86-64 only)
- Revision 1.25 2002/12/29 16:58:11 peter
- * write terminating 0 for widestring constants
- Revision 1.24 2002/12/07 14:10:21 carl
- * fix warnings by adding explicit typecasts
- Revision 1.23 2002/11/25 17:43:17 peter
- * splitted defbase in defutil,symutil,defcmp
- * merged isconvertable and is_equal into compare_defs(_ext)
- * made operator search faster by walking the list only once
- Revision 1.22 2002/11/09 15:36:50 carl
- * align all constants correctly (default of 4 size for real type constants)
- Revision 1.21 2002/10/06 21:01:50 peter
- * use tconstexpruint instead of qword
- Revision 1.20 2002/10/05 12:43:25 carl
- * fixes for Delphi 6 compilation
- (warning : Some features do not work under Delphi)
- Revision 1.19 2002/08/18 20:06:23 peter
- * inlining is now also allowed in interface
- * renamed write/load to ppuwrite/ppuload
- * tnode storing in ppu
- * nld,ncon,nbas are already updated for storing in ppu
- Revision 1.18 2002/08/11 14:32:26 peter
- * renamed current_library to objectlibrary
- Revision 1.17 2002/08/11 13:24:11 peter
- * saving of asmsymbols in ppu supported
- * asmsymbollist global is removed and moved into a new class
- tasmlibrarydata that will hold the info of a .a file which
- corresponds with a single module. Added librarydata to tmodule
- to keep the library info stored for the module. In the future the
- objectfiles will also be stored to the tasmlibrarydata class
- * all getlabel/newasmsymbol and friends are moved to the new class
- Revision 1.16 2002/08/10 17:15:06 jonas
- * endianess fix
- Revision 1.15 2002/07/23 12:34:30 daniel
- * Readded old set code. To use it define 'oldset'. Activated by default
- for ppc.
- Revision 1.14 2002/07/22 11:48:04 daniel
- * Sets are now internally sets.
- Revision 1.13 2002/07/20 11:57:53 florian
- * types.pas renamed to defbase.pas because D6 contains a types
- unit so this would conflicts if D6 programms are compiled
- + Willamette/SSE2 instructions to assembler added
- Revision 1.12 2002/07/01 18:46:22 peter
- * internal linker
- * reorganized aasm layer
- Revision 1.11 2002/07/01 16:23:53 peter
- * cg64 patch
- * basics for currency
- * asnode updates for class and interface (not finished)
- Revision 1.10 2002/05/18 13:34:09 peter
- * readded missing revisions
- Revision 1.9 2002/05/16 19:46:37 carl
- + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
- + try to fix temp allocation (still in ifdef)
- + generic constructor calls
- + start of tassembler / tmodulebase class cleanup
- Revision 1.7 2002/04/04 19:05:57 peter
- * removed unused units
- * use tlocation.size in cg.a_*loc*() routines
- Revision 1.6 2002/04/02 17:11:28 peter
- * tlocation,treference update
- * LOC_CONSTANT added for better constant handling
- * secondadd splitted in multiple routines
- * location_force_reg added for loading a location to a register
- of a specified size
- * secondassignment parses now first the right and then the left node
- (this is compatible with Kylix). This saves a lot of push/pop especially
- with string operations
- * adapted some routines to use the new cg methods
- Revision 1.5 2002/03/31 20:26:34 jonas
- + a_loadfpu_* and a_loadmm_* methods in tcg
- * register allocation is now handled by a class and is mostly processor
- independent (+rgobj.pas and i386/rgcpu.pas)
- * temp allocation is now handled by a class (+tgobj.pas, -i386\tgcpu.pas)
- * some small improvements and fixes to the optimizer
- * some register allocation fixes
- * some fpuvaroffset fixes in the unary minus node
- * push/popusedregisters is now called rg.save/restoreusedregisters and
- (for i386) uses temps instead of push/pop's when using -Op3 (that code is
- also better optimizable)
- * fixed and optimized register saving/restoring for new/dispose nodes
- * LOC_FPU locations now also require their "register" field to be set to
- R_ST, not R_ST0 (the latter is used for LOC_CFPUREGISTER locations only)
- - list field removed of the tnode class because it's not used currently
- and can cause hard-to-find bugs
- Revision 1.4 2002/02/26 09:12:39 jonas
- * fixed problem when compiling the compiler with Delphi (reported by
- "Luc Langlois" <[email protected]>) (lo/hi don't work as in FPC
- when used with int64's under Delphi)
- }
|