123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290 |
- {
- Copyright (c) 2000-2005 by Florian Klaempfl
- Type checking and register allocation for math 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 nmat;
- {$i fpcdefs.inc}
- interface
- uses
- node;
- type
- tmoddivnode = class(tbinopnode)
- function pass_1 : tnode;override;
- function pass_typecheck:tnode;override;
- function simplify(forinline : boolean) : tnode;override;
- protected
- { override the following if you want to implement }
- { parts explicitely in the code generator (JM) }
- function use_moddiv64bitint_helper: boolean; virtual;
- function first_moddiv64bitint: tnode; virtual;
- function firstoptimize: tnode; virtual;
- function first_moddivint: tnode; virtual;
- end;
- tmoddivnodeclass = class of tmoddivnode;
- tshlshrnode = class(tbinopnode)
- function pass_1 : tnode;override;
- function pass_typecheck:tnode;override;
- function simplify(forinline : boolean) : tnode;override;
- {$ifndef cpu64bitalu}
- { override the following if you want to implement }
- { parts explicitely in the code generator (CEC)
- Should return nil, if everything will be handled
- in the code generator
- }
- function first_shlshr64bitint: tnode; virtual;
- {$endif not cpu64bitalu}
- end;
- tshlshrnodeclass = class of tshlshrnode;
- tunaryminusnode = class(tunarynode)
- constructor create(expr : tnode);virtual;
- function pass_1 : tnode;override;
- function pass_typecheck:tnode;override;
- function simplify(forinline : boolean) : tnode;override;
- end;
- tunaryminusnodeclass = class of tunaryminusnode;
- tunaryplusnode = class(tunarynode)
- constructor create(expr : tnode);virtual;
- function pass_1 : tnode;override;
- function pass_typecheck:tnode;override;
- end;
- tunaryplusnodeclass = class of tunaryplusnode;
- tnotnode = class(tunarynode)
- constructor create(expr : tnode);virtual;
- function pass_1 : tnode;override;
- function pass_typecheck:tnode;override;
- function simplify(forinline : boolean) : tnode;override;
- {$ifdef state_tracking}
- function track_state_pass(exec_known:boolean):boolean;override;
- {$endif}
- end;
- tnotnodeclass = class of tnotnode;
- var
- cmoddivnode : tmoddivnodeclass = tmoddivnode;
- cshlshrnode : tshlshrnodeclass = tshlshrnode;
- cunaryminusnode : tunaryminusnodeclass = tunaryminusnode;
- cunaryplusnode : tunaryplusnodeclass = tunaryplusnode;
- cnotnode : tnotnodeclass = tnotnode;
- implementation
- uses
- systems,
- verbose,globals,cutils,
- globtype,constexp,
- symconst,symtype,symdef,symtable,
- defutil,
- htypechk,pass_1,
- cgbase,
- ncon,ncnv,ncal,nadd,nld,nbas,nflw,ninl,
- nutils;
- {****************************************************************************
- TMODDIVNODE
- ****************************************************************************}
- function tmoddivnode.simplify(forinline : boolean):tnode;
- var
- rv,lv : tconstexprint;
- begin
- result:=nil;
- if is_constintnode(right) then
- begin
- rv:=tordconstnode(right).value;
- if rv = 1 then
- begin
- case nodetype of
- modn:
- result := cordconstnode.create(0,left.resultdef,true);
- divn:
- result := left.getcopy;
- end;
- exit;
- end;
- if rv = 0 then
- begin
- Message(parser_e_division_by_zero);
- { recover }
- tordconstnode(right).value := 1;
- end;
- { the following simplification is also required for correctness
- on x86, as its transformation of divisions by constants to
- multiplications and shifts does not handle -1 correctly }
- if (rv=-1) and
- (nodetype=divn) then
- begin
- result:=cunaryminusnode.create(left);
- left:=nil;
- exit;
- end;
- if (nf_isomod in flags) and
- (rv<=0) then
- begin
- Message(cg_e_mod_only_defined_for_pos_quotient);
- { recover }
- tordconstnode(right).value := 1;
- end;
- end;
- if is_constintnode(right) and is_constintnode(left) then
- begin
- rv:=tordconstnode(right).value;
- lv:=tordconstnode(left).value;
- case nodetype of
- modn:
- if nf_isomod in flags then
- begin
- if lv>=0 then
- result:=create_simplified_ord_const(lv mod rv,resultdef,forinline)
- else
- if ((-lv) mod rv)=0 then
- result:=create_simplified_ord_const((-lv) mod rv,resultdef,forinline)
- else
- result:=create_simplified_ord_const(rv-((-lv) mod rv),resultdef,forinline);
- end
- else
- result:=create_simplified_ord_const(lv mod rv,resultdef,forinline);
- divn:
- result:=create_simplified_ord_const(lv div rv,resultdef,forinline);
- end;
- end;
- end;
- function tmoddivnode.use_moddiv64bitint_helper: boolean;
- begin
- { not with an ifdef around the call to this routine, because e.g. the
- Java VM has a signed 64 bit division opcode, but not an unsigned
- one }
- {$ifdef cpu64bitalu}
- result:=false;
- {$else cpu64bitalu}
- result:=
- (left.resultdef.typ=orddef) and
- (right.resultdef.typ=orddef) and
- (is_64bitint(left.resultdef) or is_64bitint(right.resultdef));
- {$endif cpu64bitaly}
- end;
- function tmoddivnode.pass_typecheck:tnode;
- var
- else_block,
- hp,t : tnode;
- rd,ld : torddef;
- else_statements,
- statements : tstatementnode;
- result_data : ttempcreatenode;
- nd : torddef;
- begin
- result:=nil;
- typecheckpass(left);
- typecheckpass(right);
- { avoid any problems with type parameters later on }
- if is_typeparam(left.resultdef) or is_typeparam(right.resultdef) then
- begin
- resultdef:=cundefinedtype;
- exit;
- end;
- set_varstate(left,vs_read,[vsf_must_be_valid]);
- set_varstate(right,vs_read,[vsf_must_be_valid]);
- if codegenerror then
- exit;
- { tp procvar support }
- maybe_call_procvar(left,true);
- maybe_call_procvar(right,true);
- { allow operator overloading }
- t:=self;
- if isbinaryoverloaded(t) then
- begin
- result:=t;
- exit;
- end;
- { we need 2 orddefs always }
- if (left.resultdef.typ<>orddef) then
- inserttypeconv(left,sinttype);
- if (right.resultdef.typ<>orddef) then
- inserttypeconv(right,sinttype);
- if codegenerror then
- exit;
- { Try only now to simply constant
- as otherwise you might create
- tconstnode with return type that are
- not compatible with tconst node
- as in bug report 21566 PM }
- result:=simplify(false);
- if assigned(result) then
- exit;
- rd:=torddef(right.resultdef);
- ld:=torddef(left.resultdef);
- { if one operand is a cardinal and the other is a positive constant, convert the }
- { constant to a cardinal as well so we don't have to do a 64bit division (JM) }
- { Do the same for qwords and positive constants as well, otherwise things like }
- { "qword mod 10" are evaluated with int64 as result, which is wrong if the }
- { "qword" was > high(int64) (JM) }
- { Additionally, do the same for cardinal/qwords and other positive types, but }
- { always in a way that a smaller type is converted to a bigger type }
- { (webtbs/tw8870) }
- if (rd.ordtype in [u8bit,u16bit,u32bit,u64bit]) and
- ((is_constintnode(left) and
- (tordconstnode(left).value >= 0) and
- (tordconstnode(left).value <= get_max_value(rd))) or
- (not is_signed(ld) and
- (rd.size >= ld.size))) then
- begin
- inserttypeconv(left,right.resultdef);
- ld:=torddef(left.resultdef);
- end;
- if (ld.ordtype in [u8bit,u16bit,u32bit,u64bit]) and
- ((is_constintnode(right) and
- (tordconstnode(right).value >= 0) and
- (tordconstnode(right).value <= get_max_value(ld))) or
- (not is_signed(rd) and
- (ld.size >= rd.size))) then
- begin
- inserttypeconv(right,left.resultdef);
- rd:=torddef(right.resultdef);
- end;
- { when there is one currency value, everything is done
- using currency }
- if (ld.ordtype=scurrency) or
- (rd.ordtype=scurrency) then
- begin
- if (ld.ordtype<>scurrency) then
- inserttypeconv(left,s64currencytype);
- if (rd.ordtype<>scurrency) then
- inserttypeconv(right,s64currencytype);
- resultdef:=left.resultdef;
- end
- else
- { when there is one 64bit value, everything is done
- in 64bit }
- if (is_64bitint(left.resultdef) or
- is_64bitint(right.resultdef)) then
- begin
- if is_signed(rd) or is_signed(ld) then
- begin
- if (ld.ordtype<>s64bit) then
- inserttypeconv(left,s64inttype);
- if (rd.ordtype<>s64bit) then
- inserttypeconv(right,s64inttype);
- end
- else
- begin
- if (ld.ordtype<>u64bit) then
- inserttypeconv(left,u64inttype);
- if (rd.ordtype<>u64bit) then
- inserttypeconv(right,u64inttype);
- end;
- resultdef:=left.resultdef;
- end
- else
- { is there a larger than the native int? }
- if is_oversizedint(ld) or is_oversizedint(rd) then
- begin
- nd:=get_common_intdef(ld,rd,false);
- if (ld.ordtype<>nd.ordtype) then
- inserttypeconv(left,nd);
- if (rd.ordtype<>nd.ordtype) then
- inserttypeconv(right,nd);
- resultdef:=left.resultdef;
- end
- else
- { when mixing unsigned and signed native ints, convert everything to a larger signed type (JM) }
- if (is_nativeuint(rd) and
- is_signed(ld)) or
- (is_nativeuint(ld) and
- is_signed(rd)) then
- begin
- CGMessage(type_h_mixed_signed_unsigned);
- { get a signed int, larger than the native int }
- nd:=get_common_intdef(torddef(sinttype),torddef(uinttype),false);
- if (ld.ordtype<>nd.ordtype) then
- inserttypeconv(left,nd);
- if (rd.ordtype<>nd.ordtype) then
- inserttypeconv(right,nd);
- resultdef:=left.resultdef;
- end
- else
- begin
- { Make everything always default singed int }
- if not(rd.ordtype in [torddef(sinttype).ordtype,torddef(uinttype).ordtype]) then
- inserttypeconv(right,sinttype);
- if not(ld.ordtype in [torddef(sinttype).ordtype,torddef(uinttype).ordtype]) then
- inserttypeconv(left,sinttype);
- resultdef:=right.resultdef;
- end;
- { when the result is currency we need some extra code for
- division. this should not be done when the divn node is
- created internally }
- if (nodetype=divn) and
- not(nf_is_currency in flags) and
- is_currency(resultdef) then
- begin
- hp:=caddnode.create(muln,getcopy,cordconstnode.create(10000,s64currencytype,false));
- include(hp.flags,nf_is_currency);
- result:=hp;
- end;
- if (nodetype=modn) and (nf_isomod in flags) then
- begin
- result:=internalstatements(statements);
- else_block:=internalstatements(else_statements);
- result_data:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
- { right <=0? }
- addstatement(statements,cifnode.create(caddnode.create(lten,right.getcopy,cordconstnode.create(0,resultdef,false)),
- { then: result:=left mod right }
- ccallnode.createintern('fpc_divbyzero',nil),
- nil
- ));
- { prepare else block }
- { result:=(-left) mod right }
- addstatement(else_statements,cassignmentnode.create(ctemprefnode.create(result_data),cmoddivnode.create(modn,cunaryminusnode.create(left.getcopy),right.getcopy)));
- { result<>0? }
- addstatement(else_statements,cifnode.create(caddnode.create(unequaln,ctemprefnode.create(result_data),cordconstnode.create(0,resultdef,false)),
- { then: result:=right-result }
- cassignmentnode.create(ctemprefnode.create(result_data),caddnode.create(subn,right.getcopy,ctemprefnode.create(result_data))),
- nil
- ));
- addstatement(statements,result_data);
- { if left>=0 }
- addstatement(statements,cifnode.create(caddnode.create(gten,left.getcopy,cordconstnode.create(0,resultdef,false)),
- { then: result:=left mod right }
- cassignmentnode.create(ctemprefnode.create(result_data),cmoddivnode.create(modn,left.getcopy,right.getcopy)),
- { else block }
- else_block
- ));
- addstatement(statements,ctempdeletenode.create_normal_temp(result_data));
- addstatement(statements,ctemprefnode.create(result_data));
- end;
- end;
- function tmoddivnode.first_moddivint: tnode;
- {$ifdef cpuneedsdiv32helper}
- var
- procname: string[31];
- begin
- result := nil;
- { otherwise create a call to a helper }
- if nodetype = divn then
- procname := 'fpc_div_'
- else
- procname := 'fpc_mod_';
- { only qword needs the unsigned code, the
- signed code is also used for currency }
- if is_signed(resultdef) then
- procname := procname + 'longint'
- else
- procname := procname + 'dword';
- result := ccallnode.createintern(procname,ccallparanode.create(left,
- ccallparanode.create(right,nil)));
- left := nil;
- right := nil;
- firstpass(result);
- if result.resultdef.typ<>orddef then
- internalerror(2013031701);
- if resultdef.typ<>orddef then
- internalerror(2013031701);
- if torddef(result.resultdef).ordtype <> torddef(resultdef).ordtype then
- inserttypeconv(result,resultdef);
- end;
- {$else cpuneedsdiv32helper}
- begin
- result:=nil;
- end;
- {$endif cpuneedsdiv32helper}
- function tmoddivnode.first_moddiv64bitint: tnode;
- var
- procname: string[31];
- begin
- result := nil;
- { when currency is used set the result of the
- parameters to s64bit, so they are not converted }
- if is_currency(resultdef) then
- begin
- left.resultdef:=s64inttype;
- right.resultdef:=s64inttype;
- end;
- { otherwise create a call to a helper }
- if nodetype = divn then
- procname := 'fpc_div_'
- else
- procname := 'fpc_mod_';
- { only qword needs the unsigned code, the
- signed code is also used for currency }
- if is_signed(resultdef) then
- procname := procname + 'int64'
- else
- procname := procname + 'qword';
- result := ccallnode.createintern(procname,ccallparanode.create(left,
- ccallparanode.create(right,nil)));
- left := nil;
- right := nil;
- firstpass(result);
- end;
- function tmoddivnode.firstoptimize: tnode;
- var
- power,shiftval : longint;
- statements : tstatementnode;
- temp,resulttemp : ttempcreatenode;
- begin
- result := nil;
- { divide/mod a number by a constant which is a power of 2? }
- if (right.nodetype = ordconstn) and
- ispowerof2(tordconstnode(right).value,power) and
- {$ifdef cpu64bitalu}
- { for 64 bit, we leave the optimization to the cg }
- (not is_signed(resultdef)) then
- {$else cpu64bitalu}
- (((nodetype=divn) and is_64bit(resultdef)) or
- (nodetype=modn) or
- not is_signed(resultdef)) then
- {$endif cpu64bitalu}
- begin
- if nodetype=divn then
- begin
- if is_signed(resultdef) then
- begin
- if is_64bitint(left.resultdef) then
- if not (cs_opt_size in current_settings.optimizerswitches) then
- shiftval:=63
- else
- { the shift code is a lot bigger than the call to }
- { the divide helper }
- exit
- else
- shiftval:=31;
- result:=internalstatements(statements);
- temp:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true);
- resulttemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
- addstatement(statements,resulttemp);
- addstatement(statements,temp);
- addstatement(statements,cassignmentnode.create(ctemprefnode.create(temp),
- left));
- left:=nil;
- addstatement(statements,cassignmentnode.create(ctemprefnode.create(resulttemp),
- cinlinenode.create(in_sar_x_y,false,
- ccallparanode.create(cordconstnode.create(power,u8inttype,false),
- ccallparanode.create(caddnode.create(addn,ctemprefnode.create(temp),
- caddnode.create(andn,
- cinlinenode.create(in_sar_x_y,false,
- ccallparanode.create(cordconstnode.create(shiftval,u8inttype,false),
- ccallparanode.create(ctemprefnode.create(temp),nil))
- ),
- cordconstnode.create(tordconstnode(right).value-1,
- right.resultdef,false)
- )),nil
- ))))
- );
- addstatement(statements,ctempdeletenode.create(temp));
- addstatement(statements,ctempdeletenode.create_normal_temp(resulttemp));
- addstatement(statements,ctemprefnode.create(resulttemp));
- end
- else
- begin
- tordconstnode(right).value:=power;
- result:=cshlshrnode.create(shrn,left,right)
- end;
- end
- else if is_signed(resultdef) then { signed modulus }
- begin
- if (cs_opt_size in current_settings.optimizerswitches) then
- exit;
- shiftval:=left.resultdef.size*8-1;
- dec(tordconstnode(right).value.uvalue);
- result:=internalstatements(statements);
- temp:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true);
- resulttemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
- addstatement(statements,resulttemp);
- addstatement(statements,temp);
- addstatement(statements,cassignmentnode.create(ctemprefnode.create(temp),left));
- { sign:=sar(left,sizeof(left)*8-1); }
- addstatement(statements,cassignmentnode.create(ctemprefnode.create(resulttemp),
- cinlinenode.create(in_sar_x_y,false,
- ccallparanode.create(cordconstnode.create(shiftval,u8inttype,false),
- ccallparanode.create(ctemprefnode.create(temp),nil)
- )
- )));
- { result:=((((left xor sign)-sign) and right) xor sign)-sign; }
- addstatement(statements,cassignmentnode.create(ctemprefnode.create(resulttemp),
- caddnode.create(subn,
- caddnode.create(xorn,
- caddnode.create(andn,
- right,
- caddnode.create(subn,
- caddnode.create(xorn,
- ctemprefnode.create(resulttemp),
- ctemprefnode.create(temp)),
- ctemprefnode.create(resulttemp))
- ),
- ctemprefnode.create(resulttemp)
- ),
- ctemprefnode.create(resulttemp))
- ));
- addstatement(statements,ctempdeletenode.create(temp));
- addstatement(statements,ctempdeletenode.create_normal_temp(resulttemp));
- addstatement(statements,ctemprefnode.create(resulttemp));
- end
- else
- begin
- dec(tordconstnode(right).value.uvalue);
- result := caddnode.create(andn,left,right);
- end;
- { left and right are reused }
- left := nil;
- right := nil;
- firstpass(result);
- exit;
- end;
- end;
- function tmoddivnode.pass_1 : tnode;
- begin
- result:=nil;
- firstpass(left);
- firstpass(right);
- if codegenerror then
- exit;
- { Try to optimize mod/div }
- result := firstoptimize;
- if assigned(result) then
- exit;
- { 64bit }
- if use_moddiv64bitint_helper then
- begin
- result := first_moddiv64bitint;
- if assigned(result) then
- exit;
- expectloc:=LOC_REGISTER;
- end
- else
- begin
- result := first_moddivint;
- if assigned(result) then
- exit;
- end;
- expectloc:=LOC_REGISTER;
- end;
- {****************************************************************************
- TSHLSHRNODE
- ****************************************************************************}
- function tshlshrnode.simplify(forinline : boolean):tnode;
- var
- lvalue,rvalue : Tconstexprint;
- begin
- result:=nil;
- { constant folding }
- if is_constintnode(right) then
- begin
- if forinline then
- begin
- { shl/shr are unsigned operations, so cut off upper bits }
- case resultdef.size of
- 1,2,4:
- rvalue:=tordconstnode(right).value and byte($1f);
- 8:
- rvalue:=tordconstnode(right).value and byte($3f);
- else
- internalerror(2013122302);
- end;
- end
- else
- rvalue:=tordconstnode(right).value;
- if is_constintnode(left) then
- begin
- if forinline then
- begin
- { shl/shr are unsigned operations, so cut off upper bits }
- case resultdef.size of
- 1:
- lvalue:=tordconstnode(left).value and byte($ff);
- 2:
- lvalue:=tordconstnode(left).value and word($ffff);
- 4:
- lvalue:=tordconstnode(left).value and dword($ffffffff);
- 8:
- lvalue:=tordconstnode(left).value and qword($ffffffffffffffff);
- else
- internalerror(2013122301);
- end;
- end
- else
- lvalue:=tordconstnode(left).value;
- case nodetype of
- shrn:
- result:=create_simplified_ord_const(lvalue shr rvalue,resultdef,forinline);
- shln:
- result:=create_simplified_ord_const(lvalue shl rvalue,resultdef,forinline);
- end;
- end
- else if rvalue=0 then
- begin
- result:=left;
- left:=nil;
- end;
- end;
- end;
- function tshlshrnode.pass_typecheck:tnode;
- var
- t : tnode;
- begin
- result:=nil;
- typecheckpass(left);
- typecheckpass(right);
- { avoid any problems with type parameters later on }
- if is_typeparam(left.resultdef) or is_typeparam(right.resultdef) then
- begin
- resultdef:=cundefinedtype;
- exit;
- end;
- set_varstate(right,vs_read,[vsf_must_be_valid]);
- set_varstate(left,vs_read,[vsf_must_be_valid]);
- if codegenerror then
- exit;
- { tp procvar support }
- maybe_call_procvar(left,true);
- maybe_call_procvar(right,true);
- { allow operator overloading }
- t:=self;
- if isbinaryoverloaded(t) then
- begin
- result:=t;
- exit;
- end;
- { calculations for ordinals < 32 bit have to be done in
- 32 bit for backwards compatibility. That way 'shl 33' is
- the same as 'shl 1'. It's ugly but compatible with delphi/tp/gcc }
- if (not is_64bit(left.resultdef)) and
- (torddef(left.resultdef).ordtype<>u32bit) then
- begin
- { keep singness of orignal type }
- if is_signed(left.resultdef) then
- begin
- {$if defined(cpu64bitalu) or defined(cpu32bitalu)}
- inserttypeconv(left,s32inttype)
- {$elseif defined(cpu16bitalu) or defined(cpu8bitalu)}
- inserttypeconv(left,get_common_intdef(torddef(left.resultdef),torddef(sinttype),true));
- {$else}
- internalerror(2013031301);
- {$endif}
- end
- else
- begin
- {$if defined(cpu64bitalu) or defined(cpu32bitalu)}
- inserttypeconv(left,u32inttype);
- {$elseif defined(cpu16bitalu) or defined(cpu8bitalu)}
- inserttypeconv(left,get_common_intdef(torddef(left.resultdef),torddef(uinttype),true));
- {$else}
- internalerror(2013031301);
- {$endif}
- end
- end;
- inserttypeconv(right,sinttype);
- resultdef:=left.resultdef;
- result:=simplify(false);
- if assigned(result) then
- exit;
- end;
- {$ifndef cpu64bitalu}
- function tshlshrnode.first_shlshr64bitint: tnode;
- var
- procname: string[31];
- begin
- result := nil;
- { Normally already done below, but called again,
- just in case it is called directly }
- firstpass(left);
- { otherwise create a call to a helper }
- if is_signed(left.resultdef) then
- procname:='int64'
- else
- procname:='qword';
- if nodetype = shln then
- procname := 'fpc_shl_'+procname
- else
- procname := 'fpc_shr_'+procname;
- { this order of parameters works at least for the arm,
- however it should work for any calling conventions (FK) }
- result := ccallnode.createintern(procname,ccallparanode.create(right,
- ccallparanode.create(left,nil)));
- left := nil;
- right := nil;
- firstpass(result);
- end;
- {$endif not cpu64bitalu}
- function tshlshrnode.pass_1 : tnode;
- var
- regs : longint;
- begin
- result:=nil;
- firstpass(left);
- firstpass(right);
- if codegenerror then
- exit;
- {$ifndef cpu64bitalu}
- { 64 bit ints have their own shift handling }
- if is_64bit(left.resultdef) then
- begin
- result := first_shlshr64bitint;
- if assigned(result) then
- exit;
- regs:=2;
- end
- else
- {$endif not cpu64bitalu}
- begin
- regs:=1
- end;
- if (right.nodetype<>ordconstn) then
- inc(regs);
- expectloc:=LOC_REGISTER;
- end;
- {****************************************************************************
- TUNARYMINUSNODE
- ****************************************************************************}
- constructor tunaryminusnode.create(expr : tnode);
- begin
- inherited create(unaryminusn,expr);
- end;
- function tunaryminusnode.simplify(forinline : boolean):tnode;
- begin
- result:=nil;
- { constant folding }
- if is_constintnode(left) then
- begin
- result:=create_simplified_ord_const(-tordconstnode(left).value,resultdef,forinline);
- exit;
- end;
- if is_constrealnode(left) then
- begin
- trealconstnode(left).value_real:=-trealconstnode(left).value_real;
- trealconstnode(left).value_currency:=-trealconstnode(left).value_currency;
- result:=left;
- left:=nil;
- exit;
- end;
- end;
- function tunaryminusnode.pass_typecheck : tnode;
- var
- t : tnode;
- begin
- result:=nil;
- typecheckpass(left);
- { avoid any problems with type parameters later on }
- if is_typeparam(left.resultdef) then
- begin
- resultdef:=cundefinedtype;
- exit;
- end;
- set_varstate(left,vs_read,[vsf_must_be_valid]);
- if codegenerror then
- exit;
- result:=simplify(false);
- if assigned(result) then
- exit;
- resultdef:=left.resultdef;
- if (left.resultdef.typ=floatdef) or
- is_currency(left.resultdef) then
- begin
- end
- {$ifdef SUPPORT_MMX}
- else if (cs_mmx in current_settings.localswitches) and
- is_mmx_able_array(left.resultdef) then
- begin
- { if saturation is on, left.resultdef isn't
- "mmx able" (FK)
- if (cs_mmx_saturation in current_settings.localswitches^) and
- (torddef(tarraydef(resultdef).definition).typ in
- [s32bit,u32bit]) then
- CGMessage(type_e_mismatch);
- }
- end
- {$endif SUPPORT_MMX}
- else if is_oversizedord(left.resultdef) then
- begin
- if is_64bit(left.resultdef) then
- inserttypeconv(left,s64inttype)
- else if is_32bit(left.resultdef) then
- inserttypeconv(left,s32inttype)
- else if is_16bit(left.resultdef) then
- inserttypeconv(left,s16inttype)
- else
- internalerror(2013040701);
- resultdef:=left.resultdef;
- end
- else if (left.resultdef.typ=orddef) then
- begin
- inserttypeconv(left,sinttype);
- resultdef:=left.resultdef
- end
- else
- begin
- { allow operator overloading }
- t:=self;
- if isunaryoverloaded(t) then
- begin
- result:=t;
- exit;
- end;
- CGMessage(type_e_mismatch);
- end;
- end;
- { generic code }
- { overridden by: }
- { i386 }
- function tunaryminusnode.pass_1 : tnode;
- var
- procname: string[31];
- fdef : tdef;
- begin
- result:=nil;
- firstpass(left);
- if codegenerror then
- exit;
- if (cs_fp_emulation in current_settings.moduleswitches) and (left.resultdef.typ=floatdef) then
- begin
- if not(target_info.system in systems_wince) then
- begin
- expectloc:=LOC_REGISTER;
- exit;
- end
- else
- begin
- case tfloatdef(resultdef).floattype of
- s32real:
- procname:='NEGS';
- s64real:
- procname:='NEGD';
- {!!! not yet implemented
- s128real:
- }
- else
- internalerror(2005082802);
- end;
- result:=ccallnode.createintern(procname,ccallparanode.create(left,nil));
- end;
- left:=nil;
- end
- else
- begin
- if (left.resultdef.typ=floatdef) then
- expectloc:=LOC_FPUREGISTER
- {$ifdef SUPPORT_MMX}
- else if (cs_mmx in current_settings.localswitches) and
- is_mmx_able_array(left.resultdef) then
- expectloc:=LOC_MMXREGISTER
- {$endif SUPPORT_MMX}
- else if (left.resultdef.typ=orddef) then
- expectloc:=LOC_REGISTER;
- end;
- end;
- {****************************************************************************
- TUNARYPLUSNODE
- ****************************************************************************}
- constructor tunaryplusnode.create(expr: tnode);
- begin
- inherited create(unaryplusn,expr);
- end;
- function tunaryplusnode.pass_1: tnode;
- begin
- result:=nil;
- { can never happen because all the conversions happen
- in pass_typecheck }
- internalerror(201012250);
- end;
- function tunaryplusnode.pass_typecheck: tnode;
- var
- t:tnode;
- begin
- result:=nil;
- typecheckpass(left);
- { avoid any problems with type parameters later on }
- if is_typeparam(left.resultdef) then
- begin
- resultdef:=cundefinedtype;
- exit;
- end;
- set_varstate(left,vs_read,[vsf_must_be_valid]);
- if codegenerror then
- exit;
- if is_constintnode(left) or
- is_constrealnode(left) or
- (left.resultdef.typ=floatdef) or
- is_currency(left.resultdef)
- {$ifdef SUPPORT_MMX}
- or ((cs_mmx in current_settings.localswitches) and
- is_mmx_able_array(left.resultdef))
- {$endif SUPPORT_MMX}
- then
- begin
- result:=left;
- left:=nil;
- end
- else if is_oversizedord(left.resultdef) then
- begin
- if is_64bit(left.resultdef) then
- inserttypeconv(left,s64inttype)
- else if is_32bit(left.resultdef) then
- inserttypeconv(left,s32inttype)
- else if is_16bit(left.resultdef) then
- inserttypeconv(left,s16inttype)
- else
- internalerror(2013040702);
- result:=left;
- left:=nil;
- end
- else if (left.resultdef.typ=orddef) then
- begin
- inserttypeconv(left,sinttype);
- result:=left;
- left:=nil;
- end
- else
- begin
- { allow operator overloading }
- t:=self;
- if isunaryoverloaded(t) then
- begin
- result:=t;
- exit;
- end;
- CGMessage(type_e_mismatch);
- end;
- end;
- {****************************************************************************
- TNOTNODE
- ****************************************************************************}
- const
- boolean_reverse:array[ltn..unequaln] of Tnodetype=(
- gten,gtn,lten,ltn,unequaln,equaln
- );
- constructor tnotnode.create(expr : tnode);
- begin
- inherited create(notn,expr);
- end;
- function tnotnode.simplify(forinline : boolean):tnode;
- var
- v : tconstexprint;
- t : tnode;
- def : tdef;
- begin
- result:=nil;
- { Try optmimizing ourself away }
- if left.nodetype=notn then
- begin
- { Double not. Remove both }
- result:=Tnotnode(left).left;
- tnotnode(left).left:=nil;
- exit;
- end;
- if (left.nodetype in [ltn,lten,equaln,unequaln,gtn,gten]) then
- begin
- { Not of boolean expression. Turn around the operator and remove
- the not. This is not allowed for sets with the gten/lten,
- because there is no ltn/gtn support }
- if (taddnode(left).left.resultdef.typ<>setdef) or
- (left.nodetype in [equaln,unequaln]) then
- begin
- result:=left;
- left.nodetype:=boolean_reverse[left.nodetype];
- left:=nil;
- exit;
- end;
- end;
- { constant folding }
- if (left.nodetype=ordconstn) then
- begin
- v:=tordconstnode(left).value;
- def:=left.resultdef;
- case torddef(left.resultdef).ordtype of
- pasbool8,
- pasbool16,
- pasbool32,
- pasbool64:
- v:=byte(not(boolean(int64(v))));
- bool8bit,
- bool16bit,
- bool32bit,
- bool64bit:
- begin
- if v=0 then
- v:=-1
- else
- v:=0;
- end;
- uchar,
- uwidechar,
- u8bit,
- s8bit,
- u16bit,
- s16bit,
- s32bit,
- u32bit,
- s64bit,
- u64bit:
- begin
- { unsigned, equal or bigger than the native int size? }
- if (torddef(left.resultdef).ordtype in [u64bit,u32bit,u16bit,u8bit,uchar,uwidechar]) and
- (is_nativeord(left.resultdef) or is_oversizedord(left.resultdef)) then
- begin
- { Delphi-compatible: not dword = dword (not word = longint) }
- { Extension: not qword = qword }
- v:=qword(not qword(v));
- { will be truncated by the ordconstnode for u32bit }
- end
- else
- begin
- v:=int64(not int64(v));
- def:=get_common_intdef(torddef(left.resultdef),torddef(sinttype),false);
- end;
- end;
- else
- CGMessage(type_e_mismatch);
- end;
- { not-nodes are not range checked by the code generator -> also
- don't range check while inlining; the resultdef is a bit tricky
- though: the node's resultdef gets changed in most cases compared
- to left, but the not-operation itself is caried out in the code
- generator using the size of left
- }
- if not(forinline) then
- t:=cordconstnode.create(v,def,false)
- else
- begin
- { cut off the value if necessary }
- t:=cordconstnode.create(v,left.resultdef,false);
- { now convert to node's resultdef }
- inserttypeconv_explicit(t,def);
- end;
- result:=t;
- exit;
- end;
- end;
- function tnotnode.pass_typecheck : tnode;
- var
- t : tnode;
- begin
- result:=nil;
- typecheckpass(left);
- { avoid any problems with type parameters later on }
- if is_typeparam(left.resultdef) then
- begin
- resultdef:=cundefinedtype;
- exit;
- end;
- set_varstate(left,vs_read,[vsf_must_be_valid]);
- if codegenerror then
- exit;
- { tp procvar support }
- maybe_call_procvar(left,true);
- resultdef:=left.resultdef;
- result:=simplify(false);
- if assigned(result) then
- exit;
- if is_boolean(resultdef) then
- begin
- end
- else
- {$ifdef SUPPORT_MMX}
- if (cs_mmx in current_settings.localswitches) and
- is_mmx_able_array(left.resultdef) then
- begin
- end
- else
- {$endif SUPPORT_MMX}
- {$ifndef cpu64bitaddr}
- if is_64bitint(left.resultdef) then
- begin
- end
- else
- {$endif not cpu64bitaddr}
- if is_integer(left.resultdef) then
- begin
- end
- else
- begin
- { allow operator overloading }
- t:=self;
- if isunaryoverloaded(t) then
- begin
- result:=t;
- exit;
- end;
- CGMessage(type_e_mismatch);
- end;
- end;
- function tnotnode.pass_1 : tnode;
- begin
- result:=nil;
- firstpass(left);
- if codegenerror then
- exit;
- expectloc:=left.expectloc;
- if is_boolean(resultdef) then
- begin
- if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
- expectloc:=LOC_REGISTER;
- { before loading it into flags we need to load it into
- a register thus 1 register is need PM }
- {$ifdef cpuflags}
- if left.expectloc<>LOC_JUMP then
- expectloc:=LOC_FLAGS;
- {$endif def cpuflags}
- end
- else
- {$ifdef SUPPORT_MMX}
- if (cs_mmx in current_settings.localswitches) and
- is_mmx_able_array(left.resultdef) then
- expectloc:=LOC_MMXREGISTER
- else
- {$endif SUPPORT_MMX}
- {$ifndef cpu64bitalu}
- if is_64bit(left.resultdef) then
- begin
- if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
- expectloc:=LOC_REGISTER;
- end
- else
- {$endif not cpu64bitalu}
- if is_integer(left.resultdef) then
- expectloc:=LOC_REGISTER;
- end;
- {$ifdef state_tracking}
- function Tnotnode.track_state_pass(exec_known:boolean):boolean;
- begin
- track_state_pass:=true;
- if left.track_state_pass(exec_known) then
- begin
- left.resultdef:=nil;
- do_typecheckpass(left);
- end;
- end;
- {$endif}
- end.
|