1 { 2 Copyright (c) 2000-2005 by Florian Klaempfl 3 4 Type checking and register allocation for math nodes 5 6 This program is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 2 of the License, or 9 (at your option) any later version. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with this program; if not, write to the Free Software 18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 19 20 **************************************************************************** 21 } 22 unit nmat; 23 24 {$i fpcdefs.inc} 25 26 interface 27 28 uses 29 node; 30 31 type 32 tmoddivnode = class(tbinopnode) pass_1null33 function pass_1 : tnode;override; pass_typechecknull34 function pass_typecheck:tnode;override; simplifynull35 function simplify(forinline : boolean) : tnode;override; 36 protected 37 { override the following if you want to implement } 38 { parts explicitely in the code generator (JM) } use_moddiv64bitint_helpernull39 function use_moddiv64bitint_helper: boolean; virtual; first_moddiv64bitintnull40 function first_moddiv64bitint: tnode; virtual; firstoptimizenull41 function firstoptimize: tnode; virtual; first_moddivintnull42 function first_moddivint: tnode; virtual; 43 end; 44 tmoddivnodeclass = class of tmoddivnode; 45 46 tshlshrnode = class(tbinopnode) pass_1null47 function pass_1 : tnode;override; pass_typechecknull48 function pass_typecheck:tnode;override; simplifynull49 function simplify(forinline : boolean) : tnode;override; 50 {$ifndef cpu64bitalu} 51 { override the following if you want to implement } 52 { parts explicitely in the code generator (CEC) 53 Should return nil, if everything will be handled 54 in the code generator 55 } first_shlshr64bitintnull56 function first_shlshr64bitint: tnode; virtual; 57 {$endif not cpu64bitalu} 58 end; 59 tshlshrnodeclass = class of tshlshrnode; 60 61 tunaryminusnode = class(tunarynode) 62 constructor create(expr : tnode);virtual; pass_1null63 function pass_1 : tnode;override; pass_typechecknull64 function pass_typecheck:tnode;override; simplifynull65 function simplify(forinline : boolean) : tnode;override; 66 end; 67 tunaryminusnodeclass = class of tunaryminusnode; 68 69 tunaryplusnode = class(tunarynode) 70 constructor create(expr : tnode);virtual; pass_1null71 function pass_1 : tnode;override; pass_typechecknull72 function pass_typecheck:tnode;override; 73 end; 74 tunaryplusnodeclass = class of tunaryplusnode; 75 76 tnotnode = class(tunarynode) 77 constructor create(expr : tnode);virtual; pass_1null78 function pass_1 : tnode;override; pass_typechecknull79 function pass_typecheck:tnode;override; simplifynull80 function simplify(forinline : boolean) : tnode;override; 81 {$ifdef state_tracking} track_state_passnull82 function track_state_pass(exec_known:boolean):boolean;override; 83 {$endif} 84 end; 85 tnotnodeclass = class of tnotnode; 86 87 var 88 cmoddivnode : tmoddivnodeclass = tmoddivnode; 89 cshlshrnode : tshlshrnodeclass = tshlshrnode; 90 cunaryminusnode : tunaryminusnodeclass = tunaryminusnode; 91 cunaryplusnode : tunaryplusnodeclass = tunaryplusnode; 92 cnotnode : tnotnodeclass = tnotnode; 93 94 implementation 95 96 uses 97 systems, 98 verbose,globals,cutils,compinnr, 99 globtype,constexp, 100 symconst,symtype,symdef, 101 defcmp,defutil, 102 htypechk,pass_1, 103 cgbase, 104 ncon,ncnv,ncal,nadd,nld,nbas,nflw,ninl, 105 nutils; 106 107 {**************************************************************************** 108 TMODDIVNODE 109 ****************************************************************************} 110 tmoddivnode.simplifynull111 function tmoddivnode.simplify(forinline : boolean):tnode; 112 var 113 rv,lv : tconstexprint; 114 begin 115 result:=nil; 116 117 if is_constintnode(right) then 118 begin 119 rv:=tordconstnode(right).value; 120 if rv = 1 then 121 begin 122 case nodetype of 123 modn: 124 result := cordconstnode.create(0,left.resultdef,true); 125 divn: 126 result := left.getcopy; 127 end; 128 exit; 129 end; 130 if rv = 0 then 131 begin 132 Message(parser_e_division_by_zero); 133 { recover } 134 tordconstnode(right).value := 1; 135 end; 136 { the following simplification is also required for correctness 137 on x86, as its transformation of divisions by constants to 138 multiplications and shifts does not handle -1 correctly } 139 if (rv=-1) and 140 (nodetype=divn) then 141 begin 142 result:=cunaryminusnode.create(left); 143 left:=nil; 144 exit; 145 end; 146 if (nf_isomod in flags) and 147 (rv<=0) then 148 begin 149 Message(cg_e_mod_only_defined_for_pos_quotient); 150 { recover } 151 tordconstnode(right).value := 1; 152 end; 153 end; 154 155 if is_constintnode(right) and is_constintnode(left) then 156 begin 157 rv:=tordconstnode(right).value; 158 lv:=tordconstnode(left).value; 159 160 case nodetype of 161 modn: 162 if nf_isomod in flags then 163 begin 164 if lv>=0 then 165 result:=create_simplified_ord_const(lv mod rv,resultdef,forinline,false) 166 else 167 if ((-lv) mod rv)=0 then 168 result:=create_simplified_ord_const((-lv) mod rv,resultdef,forinline,false) 169 else 170 result:=create_simplified_ord_const(rv-((-lv) mod rv),resultdef,forinline,false); 171 end 172 else 173 result:=create_simplified_ord_const(lv mod rv,resultdef,forinline,false); 174 divn: 175 result:=create_simplified_ord_const(lv div rv,resultdef,forinline,cs_check_overflow in localswitches); 176 end; 177 end; 178 end; 179 180 tmoddivnode.use_moddiv64bitint_helpernull181 function tmoddivnode.use_moddiv64bitint_helper: boolean; 182 begin 183 { not with an ifdef around the call to this routine, because e.g. the 184 Java VM has a signed 64 bit division opcode, but not an unsigned 185 one } 186 {$ifdef cpu64bitalu} 187 result:=false; 188 {$else cpu64bitalu} 189 result:= 190 (left.resultdef.typ=orddef) and 191 (right.resultdef.typ=orddef) and 192 { include currency as well } 193 (is_64bit(left.resultdef) or is_64bit(right.resultdef)); 194 {$endif cpu64bitaly} 195 end; 196 197 tmoddivnode.pass_typechecknull198 function tmoddivnode.pass_typecheck:tnode; 199 var 200 else_block, 201 hp,t : tnode; 202 rd,ld : torddef; 203 else_statements, 204 statements : tstatementnode; 205 result_data : ttempcreatenode; 206 nd : torddef; 207 begin 208 result:=nil; 209 typecheckpass(left); 210 typecheckpass(right); 211 212 { avoid any problems with type parameters later on } 213 if is_typeparam(left.resultdef) or is_typeparam(right.resultdef) then 214 begin 215 resultdef:=cundefinedtype; 216 exit; 217 end; 218 219 set_varstate(left,vs_read,[vsf_must_be_valid]); 220 set_varstate(right,vs_read,[vsf_must_be_valid]); 221 if codegenerror then 222 exit; 223 224 { tp procvar support } 225 maybe_call_procvar(left,true); 226 maybe_call_procvar(right,true); 227 228 { allow operator overloading } 229 t:=self; 230 if isbinaryoverloaded(t,[]) then 231 begin 232 result:=t; 233 exit; 234 end; 235 236 { we need 2 orddefs always } 237 if (left.resultdef.typ<>orddef) then 238 inserttypeconv(left,sinttype); 239 if (right.resultdef.typ<>orddef) then 240 inserttypeconv(right,sinttype); 241 if codegenerror then 242 exit; 243 244 { Try only now to simply constant 245 as otherwise you might create 246 tconstnode with return type that are 247 not compatible with tconst node 248 as in bug report 21566 PM } 249 250 result:=simplify(false); 251 if assigned(result) then 252 exit; 253 254 rd:=torddef(right.resultdef); 255 ld:=torddef(left.resultdef); 256 257 { if one operand is a cardinal and the other is a positive constant, convert the } 258 { constant to a cardinal as well so we don't have to do a 64bit division (JM) } 259 { Do the same for qwords and positive constants as well, otherwise things like } 260 { "qword mod 10" are evaluated with int64 as result, which is wrong if the } 261 { "qword" was > high(int64) (JM) } 262 { Additionally, do the same for cardinal/qwords and other positive types, but } 263 { always in a way that a smaller type is converted to a bigger type } 264 { (webtbs/tw8870) } 265 if (rd.ordtype in [u8bit,u16bit,u32bit,u64bit]) and 266 ((is_constintnode(left) and 267 (tordconstnode(left).value >= 0) and 268 (tordconstnode(left).value <= get_max_value(rd))) or 269 (not is_signed(ld) and 270 (rd.size >= ld.size))) then 271 begin 272 inserttypeconv(left,right.resultdef); 273 ld:=torddef(left.resultdef); 274 end; 275 if (ld.ordtype in [u8bit,u16bit,u32bit,u64bit]) and 276 ((is_constintnode(right) and 277 (tordconstnode(right).value >= 0) and 278 (tordconstnode(right).value <= get_max_value(ld))) or 279 (not is_signed(rd) and 280 (ld.size >= rd.size))) then 281 begin 282 inserttypeconv(right,left.resultdef); 283 rd:=torddef(right.resultdef); 284 end; 285 286 { when there is one currency value, everything is done 287 using currency } 288 if (ld.ordtype=scurrency) or 289 (rd.ordtype=scurrency) then 290 begin 291 if (ld.ordtype<>scurrency) then 292 inserttypeconv(left,s64currencytype); 293 if (rd.ordtype<>scurrency) then 294 inserttypeconv(right,s64currencytype); 295 resultdef:=left.resultdef; 296 end 297 else 298 { when there is one 64bit value, everything is done 299 in 64bit } 300 if (is_64bitint(left.resultdef) or 301 is_64bitint(right.resultdef)) then 302 begin 303 if is_signed(rd) or is_signed(ld) then 304 begin 305 if (ld.ordtype<>s64bit) then 306 inserttypeconv(left,s64inttype); 307 if (rd.ordtype<>s64bit) then 308 inserttypeconv(right,s64inttype); 309 end 310 else 311 begin 312 if (ld.ordtype<>u64bit) then 313 inserttypeconv(left,u64inttype); 314 if (rd.ordtype<>u64bit) then 315 inserttypeconv(right,u64inttype); 316 end; 317 resultdef:=left.resultdef; 318 end 319 else 320 { is there a larger than the native int? } 321 if is_oversizedint(ld) or is_oversizedint(rd) then 322 begin 323 nd:=get_common_intdef(ld,rd,false); 324 if (ld.ordtype<>nd.ordtype) then 325 inserttypeconv(left,nd); 326 if (rd.ordtype<>nd.ordtype) then 327 inserttypeconv(right,nd); 328 resultdef:=left.resultdef; 329 end 330 else 331 { when mixing unsigned and signed native ints, convert everything to a larger signed type (JM) } 332 if (is_nativeuint(rd) and 333 is_signed(ld)) or 334 (is_nativeuint(ld) and 335 is_signed(rd)) then 336 begin 337 CGMessage(type_h_mixed_signed_unsigned); 338 { get a signed int, larger than the native int } 339 nd:=get_common_intdef(torddef(sinttype),torddef(uinttype),false); 340 if (ld.ordtype<>nd.ordtype) then 341 inserttypeconv(left,nd); 342 if (rd.ordtype<>nd.ordtype) then 343 inserttypeconv(right,nd); 344 resultdef:=left.resultdef; 345 end 346 else 347 begin 348 { Make everything always default singed int } 349 if not(rd.ordtype in [torddef(sinttype).ordtype,torddef(uinttype).ordtype]) then 350 inserttypeconv(right,sinttype); 351 if not(ld.ordtype in [torddef(sinttype).ordtype,torddef(uinttype).ordtype]) then 352 inserttypeconv(left,sinttype); 353 resultdef:=right.resultdef; 354 end; 355 356 { when the result is currency we need some extra code for 357 division. this should not be done when the divn node is 358 created internally } 359 if (nodetype=divn) and 360 not(nf_is_currency in flags) and 361 is_currency(resultdef) then 362 begin 363 hp:=caddnode.create(muln,getcopy,cordconstnode.create(10000,s64currencytype,false)); 364 include(hp.flags,nf_is_currency); 365 result:=hp; 366 end; 367 368 if (nodetype=modn) and (nf_isomod in flags) then 369 begin 370 result:=internalstatements(statements); 371 else_block:=internalstatements(else_statements); 372 result_data:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true); 373 374 { right <=0? } 375 addstatement(statements,cifnode.create_internal(caddnode.create_internal(lten,right.getcopy,cordconstnode.create(0,resultdef,false)), 376 { then: result:=left mod right } 377 ccallnode.createintern('fpc_divbyzero',nil), 378 nil 379 )); 380 381 { prepare else block } 382 { result:=(-left) mod right } 383 addstatement(else_statements,cassignmentnode.create(ctemprefnode.create(result_data),cmoddivnode.create(modn,cunaryminusnode.create(left.getcopy),right.getcopy))); 384 { result<>0? } 385 addstatement(else_statements,cifnode.create_internal(caddnode.create_internal(unequaln,ctemprefnode.create(result_data),cordconstnode.create(0,resultdef,false)), 386 { then: result:=right-result } 387 cassignmentnode.create_internal(ctemprefnode.create(result_data),caddnode.create_internal(subn,right.getcopy,ctemprefnode.create(result_data))), 388 nil 389 )); 390 391 addstatement(statements,result_data); 392 { if left>=0 } 393 addstatement(statements,cifnode.create_internal(caddnode.create_internal(gten,left.getcopy,cordconstnode.create(0,resultdef,false)), 394 { then: result:=left mod right } 395 cassignmentnode.create_internal(ctemprefnode.create(result_data),cmoddivnode.create(modn,left.getcopy,right.getcopy)), 396 { else block } 397 else_block 398 )); 399 400 addstatement(statements,ctempdeletenode.create_normal_temp(result_data)); 401 addstatement(statements,ctemprefnode.create(result_data)); 402 end; 403 end; 404 405 tmoddivnode.first_moddivintnull406 function tmoddivnode.first_moddivint: tnode; 407 {$ifdef cpuneedsdivhelper} 408 var 409 procname: string[31]; 410 begin 411 result := nil; 412 413 { otherwise create a call to a helper } 414 if nodetype = divn then 415 procname := 'fpc_div_' 416 else 417 procname := 'fpc_mod_'; 418 419 { only qword needs the unsigned code, the 420 signed code is also used for currency } 421 case torddef(resultdef).ordtype of 422 u8bit: 423 procname := procname + 'byte'; 424 s8bit: 425 procname := procname + 'shortint'; 426 u16bit: 427 procname := procname + 'word'; 428 s16bit: 429 procname := procname + 'smallint'; 430 u32bit: 431 procname := procname + 'dword'; 432 s32bit: 433 procname := procname + 'longint'; 434 scurrency: 435 procname := procname + 'currency'; 436 else 437 internalerror(2015070501); 438 end; 439 440 result := ccallnode.createintern(procname,ccallparanode.create(left, 441 ccallparanode.create(right,nil))); 442 left := nil; 443 right := nil; 444 firstpass(result); 445 446 if result.resultdef.typ<>orddef then 447 internalerror(2013031701); 448 if resultdef.typ<>orddef then 449 internalerror(2013031701); 450 if torddef(result.resultdef).ordtype <> torddef(resultdef).ordtype then 451 inserttypeconv(result,resultdef); 452 end; 453 {$else cpuneedsdivhelper} 454 begin 455 result:=nil; 456 end; 457 {$endif cpuneedsdiv32helper} 458 459 tmoddivnode.first_moddiv64bitintnull460 function tmoddivnode.first_moddiv64bitint: tnode; 461 var 462 procname: string[31]; 463 begin 464 result := nil; 465 466 { when currency is used set the result of the 467 parameters to s64bit, so they are not converted } 468 if is_currency(resultdef) then 469 begin 470 left.resultdef:=s64inttype; 471 right.resultdef:=s64inttype; 472 end; 473 474 { otherwise create a call to a helper } 475 if nodetype = divn then 476 procname := 'fpc_div_' 477 else 478 procname := 'fpc_mod_'; 479 { only qword needs the unsigned code, the 480 signed code is also used for currency } 481 if is_signed(resultdef) then 482 procname := procname + 'int64' 483 else 484 procname := procname + 'qword'; 485 486 result := ccallnode.createintern(procname,ccallparanode.create(left, 487 ccallparanode.create(right,nil))); 488 left := nil; 489 right := nil; 490 firstpass(result); 491 end; 492 493 tmoddivnode.firstoptimizenull494 function tmoddivnode.firstoptimize: tnode; 495 var 496 power,shiftval : longint; 497 statements : tstatementnode; 498 temp,resulttemp : ttempcreatenode; 499 masknode : tnode; 500 invertsign: Boolean; 501 begin 502 result := nil; 503 { divide/mod a number by a constant which is a power of 2? } 504 if (right.nodetype = ordconstn) and 505 isabspowerof2(tordconstnode(right).value,power) and 506 {$ifdef cpu64bitalu} 507 { for 64 bit, we leave the optimization to the cg } 508 (not is_signed(resultdef)) then 509 {$else cpu64bitalu} 510 (((nodetype=divn) and is_oversizedord(resultdef)) or 511 (nodetype=modn) or 512 not is_signed(resultdef)) then 513 {$endif cpu64bitalu} 514 begin 515 if nodetype=divn then 516 begin 517 if is_signed(resultdef) then 518 begin 519 invertsign:=tordconstnode(right).value<0; 520 if is_64bitint(left.resultdef) then 521 if not (cs_opt_size in current_settings.optimizerswitches) then 522 shiftval:=63 523 else 524 { the shift code is a lot bigger than the call to } 525 { the divide helper } 526 exit 527 else 528 shiftval:=left.resultdef.size*8-1; 529 530 result:=internalstatements(statements); 531 temp:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true); 532 resulttemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true); 533 addstatement(statements,resulttemp); 534 addstatement(statements,temp); 535 addstatement(statements,cassignmentnode.create(ctemprefnode.create(temp), 536 left)); 537 left:=nil; 538 539 { masknode is (sar(temp,shiftval) and ((1 shl power)-1)) 540 for power=1 (i.e. division by 2), masknode is simply (temp shr shiftval)} 541 if power=1 then 542 masknode:= 543 cshlshrnode.create(shrn, 544 ctemprefnode.create(temp), 545 cordconstnode.create(shiftval,u8inttype,false) 546 ) 547 else 548 masknode:= 549 caddnode.create(andn, 550 cinlinenode.create(in_sar_x_y,false, 551 ccallparanode.create(cordconstnode.create(shiftval,u8inttype,false), 552 ccallparanode.create(ctemprefnode.create(temp),nil)) 553 ), 554 cordconstnode.create(tcgint((qword(1) shl power)-1), 555 right.resultdef,false) 556 ); 557 558 if invertsign then 559 addstatement(statements,cassignmentnode.create(ctemprefnode.create(resulttemp), 560 cunaryminusnode.create( 561 cinlinenode.create(in_sar_x_y,false, 562 ccallparanode.create(cordconstnode.create(power,u8inttype,false), 563 ccallparanode.create(caddnode.create(addn,ctemprefnode.create(temp), 564 masknode),nil 565 ))))) 566 ) 567 else 568 addstatement(statements,cassignmentnode.create(ctemprefnode.create(resulttemp), 569 cinlinenode.create(in_sar_x_y,false, 570 ccallparanode.create(cordconstnode.create(power,u8inttype,false), 571 ccallparanode.create(caddnode.create(addn,ctemprefnode.create(temp), 572 masknode),nil 573 )))) 574 ); 575 addstatement(statements,ctempdeletenode.create(temp)); 576 addstatement(statements,ctempdeletenode.create_normal_temp(resulttemp)); 577 addstatement(statements,ctemprefnode.create(resulttemp)); 578 right.Free; 579 end 580 else 581 begin 582 tordconstnode(right).value:=power; 583 result:=cshlshrnode.create(shrn,left,right) 584 end; 585 end 586 else if is_signed(resultdef) then { signed modulus } 587 begin 588 if (cs_opt_size in current_settings.optimizerswitches) then 589 exit; 590 591 shiftval:=left.resultdef.size*8-1; 592 tordconstnode(right).value.uvalue:=qword((qword(1) shl power)-1); 593 594 result:=internalstatements(statements); 595 temp:=ctempcreatenode.create(left.resultdef,left.resultdef.size,tt_persistent,true); 596 resulttemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true); 597 addstatement(statements,resulttemp); 598 addstatement(statements,temp); 599 addstatement(statements,cassignmentnode.create(ctemprefnode.create(temp),left)); 600 { mask:=sar(left,sizeof(left)*8-1) and ((1 shl power)-1); } 601 if power=1 then 602 masknode:= 603 cshlshrnode.create(shrn, 604 ctemprefnode.create(temp), 605 cordconstnode.create(shiftval,u8inttype,false) 606 ) 607 else 608 masknode:= 609 caddnode.create(andn, 610 cinlinenode.create(in_sar_x_y,false, 611 ccallparanode.create(cordconstnode.create(shiftval,u8inttype,false), 612 ccallparanode.create(ctemprefnode.create(temp),nil)) 613 ), 614 cordconstnode.create(tcgint((qword(1) shl power)-1), 615 right.resultdef,false) 616 ); 617 addstatement(statements,cassignmentnode.create(ctemprefnode.create(resulttemp),masknode)); 618 619 { result:=((left+mask) and right)-mask; } 620 addstatement(statements,cassignmentnode.create(ctemprefnode.create(resulttemp), 621 caddnode.create(subn, 622 caddnode.create(andn, 623 right, 624 caddnode.create(addn, 625 ctemprefnode.create(temp), 626 ctemprefnode.create(resulttemp))), 627 ctemprefnode.create(resulttemp)) 628 )); 629 630 addstatement(statements,ctempdeletenode.create(temp)); 631 addstatement(statements,ctempdeletenode.create_normal_temp(resulttemp)); 632 addstatement(statements,ctemprefnode.create(resulttemp)); 633 end 634 else 635 begin 636 tordconstnode(right).value.uvalue:=qword((qword(1) shl power)-1); 637 result := caddnode.create(andn,left,right); 638 end; 639 { left and right are reused } 640 left := nil; 641 right := nil; 642 firstpass(result); 643 exit; 644 end; 645 end; 646 647 tmoddivnode.pass_1null648 function tmoddivnode.pass_1 : tnode; 649 begin 650 result:=nil; 651 firstpass(left); 652 firstpass(right); 653 if codegenerror then 654 exit; 655 656 { Try to optimize mod/div } 657 result := firstoptimize; 658 if assigned(result) then 659 exit; 660 661 { 64bit } 662 if use_moddiv64bitint_helper then 663 begin 664 result := first_moddiv64bitint; 665 if assigned(result) then 666 exit; 667 expectloc:=LOC_REGISTER; 668 end 669 else 670 begin 671 result := first_moddivint; 672 if assigned(result) then 673 exit; 674 end; 675 expectloc:=LOC_REGISTER; 676 end; 677 678 679 680 {**************************************************************************** 681 TSHLSHRNODE 682 ****************************************************************************} 683 tshlshrnode.simplifynull684 function tshlshrnode.simplify(forinline : boolean):tnode; 685 var 686 lvalue, rvalue, mask : Tconstexprint; 687 rangedef: tdef; 688 size: longint; 689 begin 690 result:=nil; 691 { constant folding } 692 if is_constintnode(right) then 693 begin 694 if forinline then 695 begin 696 case resultdef.size of 697 1,2,4: 698 rvalue:=tordconstnode(right).value and byte($1f); 699 8: 700 rvalue:=tordconstnode(right).value and byte($3f); 701 else 702 internalerror(2013122302); 703 end; 704 end 705 else 706 rvalue:=tordconstnode(right).value; 707 if is_constintnode(left) then 708 begin 709 lvalue:=tordconstnode(left).value; 710 getrangedefmasksize(resultdef, rangedef, mask, size); 711 { shr is an unsigned operation, so cut off upper bits } 712 if forinline then 713 lvalue:=lvalue and mask; 714 case nodetype of 715 shrn: 716 lvalue:=lvalue shr rvalue; 717 shln: 718 lvalue:=lvalue shl rvalue; 719 else 720 internalerror(2019050517); 721 end; 722 { discard shifted-out bits (shl never triggers overflow/range errors) } 723 if forinline and 724 (nodetype=shln) then 725 lvalue:=lvalue and mask; 726 result:=create_simplified_ord_const(lvalue,resultdef,forinline,false); 727 end 728 else if rvalue=0 then 729 begin 730 result:=left; 731 left:=nil; 732 end; 733 end 734 else if is_constintnode(left) then 735 begin 736 lvalue:=tordconstnode(left).value; 737 if forinline then 738 begin 739 getrangedefmasksize(resultdef, rangedef, mask, size); 740 lvalue:=lvalue and mask; 741 end; 742 { '0 shl x' and '0 shr x' are 0 } 743 if (lvalue=0) and 744 ((cs_opt_level4 in current_settings.optimizerswitches) or 745 not might_have_sideeffects(right)) then 746 result:=cordconstnode.create(0,resultdef,true); 747 end; 748 end; 749 750 tshlshrnode.pass_typechecknull751 function tshlshrnode.pass_typecheck:tnode; 752 var 753 t : tnode; 754 begin 755 result:=nil; 756 typecheckpass(left); 757 typecheckpass(right); 758 759 { avoid any problems with type parameters later on } 760 if is_typeparam(left.resultdef) or is_typeparam(right.resultdef) then 761 begin 762 resultdef:=cundefinedtype; 763 exit; 764 end; 765 766 set_varstate(right,vs_read,[vsf_must_be_valid]); 767 set_varstate(left,vs_read,[vsf_must_be_valid]); 768 if codegenerror then 769 exit; 770 771 { tp procvar support } 772 maybe_call_procvar(left,true); 773 maybe_call_procvar(right,true); 774 775 { allow operator overloading } 776 t:=self; 777 if isbinaryoverloaded(t,[]) then 778 begin 779 result:=t; 780 exit; 781 end; 782 783 {$ifdef SUPPORT_MMX} 784 if (cs_mmx in current_settings.localswitches) and 785 is_mmx_able_array(left.resultdef) and 786 ((is_mmx_able_array(right.resultdef) and 787 equal_defs(left.resultdef,right.resultdef) 788 ) or is_constintnode(right)) then 789 begin 790 if not(mmx_type(left.resultdef) in [mmxu16bit,mmxs16bit,mmxfixed16,mmxu32bit,mmxs32bit,mmxu64bit,mmxs64bit]) then 791 CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),left.resultdef.typename,right.resultdef.typename); 792 if not(is_mmx_able_array(right.resultdef)) then 793 inserttypeconv(right,sinttype); 794 end 795 else 796 {$endif SUPPORT_MMX} 797 begin 798 { calculations for ordinals < 32 bit have to be done in 799 32 bit for backwards compatibility. That way 'shl 33' is 800 the same as 'shl 1'. It's ugly but compatible with delphi/tp/gcc } 801 if (not is_64bit(left.resultdef)) and 802 (torddef(left.resultdef).ordtype<>u32bit) then 803 begin 804 { keep singness of orignal type } 805 if is_signed(left.resultdef) then 806 begin 807 {$if defined(cpu64bitalu) or defined(cpu32bitalu)} 808 inserttypeconv(left,s32inttype) 809 {$elseif defined(cpu16bitalu) or defined(cpu8bitalu)} 810 inserttypeconv(left,get_common_intdef(torddef(left.resultdef),torddef(sinttype),true)); 811 {$else} 812 internalerror(2013031301); 813 {$endif} 814 end 815 else 816 begin 817 {$if defined(cpu64bitalu) or defined(cpu32bitalu)} 818 inserttypeconv(left,u32inttype); 819 {$elseif defined(cpu16bitalu) or defined(cpu8bitalu)} 820 inserttypeconv(left,get_common_intdef(torddef(left.resultdef),torddef(uinttype),true)); 821 {$else} 822 internalerror(2013031301); 823 {$endif} 824 end 825 end; 826 827 inserttypeconv(right,sinttype); 828 end; 829 830 resultdef:=left.resultdef; 831 832 result:=simplify(false); 833 if assigned(result) then 834 exit; 835 end; 836 837 838 {$ifndef cpu64bitalu} tshlshrnode.first_shlshr64bitintnull839 function tshlshrnode.first_shlshr64bitint: tnode; 840 var 841 procname: string[31]; 842 begin 843 result := nil; 844 { Normally already done below, but called again, 845 just in case it is called directly } 846 firstpass(left); 847 { otherwise create a call to a helper } 848 if is_signed(left.resultdef) then 849 procname:='int64' 850 else 851 procname:='qword'; 852 if nodetype = shln then 853 procname := 'fpc_shl_'+procname 854 else 855 procname := 'fpc_shr_'+procname; 856 { this order of parameters works at least for the arm, 857 however it should work for any calling conventions (FK) } 858 result := ccallnode.createintern(procname,ccallparanode.create(right, 859 ccallparanode.create(left,nil))); 860 left := nil; 861 right := nil; 862 firstpass(result); 863 end; 864 {$endif not cpu64bitalu} 865 866 tshlshrnode.pass_1null867 function tshlshrnode.pass_1 : tnode; 868 begin 869 result:=nil; 870 firstpass(left); 871 firstpass(right); 872 if codegenerror then 873 exit; 874 875 {$ifndef cpu64bitalu} 876 expectloc:=LOC_REGISTER; 877 { 64 bit ints have their own shift handling } 878 if is_64bit(left.resultdef) then 879 result := first_shlshr64bitint; 880 {$endif not cpu64bitalu} 881 end; 882 883 884 {**************************************************************************** 885 TUNARYMINUSNODE 886 ****************************************************************************} 887 888 constructor tunaryminusnode.create(expr : tnode); 889 begin 890 inherited create(unaryminusn,expr); 891 end; 892 893 tunaryminusnode.simplifynull894 function tunaryminusnode.simplify(forinline : boolean):tnode; 895 begin 896 result:=nil; 897 { constant folding } 898 if is_constintnode(left) then 899 begin 900 result:=create_simplified_ord_const(-tordconstnode(left).value,resultdef,forinline,cs_check_overflow in localswitches); 901 exit; 902 end; 903 if is_constrealnode(left) then 904 begin 905 trealconstnode(left).value_real:=-trealconstnode(left).value_real; 906 { Avoid integer overflow on x86_64 CPU for currency value } 907 { i386 uses fildll/fchs/fistll instructions which never seem 908 to raise any coprocessor flags .. } 909 {$push}{$Q-} 910 trealconstnode(left).value_currency:=-trealconstnode(left).value_currency; 911 result:=left; 912 {$pop} 913 left:=nil; 914 exit; 915 end; 916 end; 917 918 tunaryminusnode.pass_typechecknull919 function tunaryminusnode.pass_typecheck : tnode; 920 var 921 t : tnode; 922 begin 923 result:=nil; 924 typecheckpass(left); 925 926 { avoid any problems with type parameters later on } 927 if is_typeparam(left.resultdef) then 928 begin 929 resultdef:=cundefinedtype; 930 exit; 931 end; 932 933 set_varstate(left,vs_read,[vsf_must_be_valid]); 934 if codegenerror then 935 exit; 936 937 result:=simplify(false); 938 if assigned(result) then 939 exit; 940 941 resultdef:=left.resultdef; 942 if (left.resultdef.typ=floatdef) or 943 is_currency(left.resultdef) then 944 begin 945 end 946 {$ifdef SUPPORT_MMX} 947 else if (cs_mmx in current_settings.localswitches) and 948 is_mmx_able_array(left.resultdef) then 949 begin 950 { if saturation is on, left.resultdef isn't 951 "mmx able" (FK) 952 if (cs_mmx_saturation in current_settings.localswitches^) and 953 (torddef(tarraydef(resultdef).definition).typ in 954 [s32bit,u32bit]) then 955 CGMessage(type_e_mismatch); 956 } 957 end 958 {$endif SUPPORT_MMX} 959 else if is_oversizedord(left.resultdef) then 960 begin 961 if is_64bit(left.resultdef) then 962 inserttypeconv(left,s64inttype) 963 else if is_32bit(left.resultdef) then 964 inserttypeconv(left,s32inttype) 965 else if is_16bit(left.resultdef) then 966 inserttypeconv(left,s16inttype) 967 else 968 internalerror(2013040701); 969 resultdef:=left.resultdef; 970 end 971 else if (left.resultdef.typ=orddef) then 972 begin 973 inserttypeconv(left,sinttype); 974 resultdef:=left.resultdef 975 end 976 else 977 begin 978 { allow operator overloading } 979 t:=self; 980 if isunaryoverloaded(t,[]) then 981 begin 982 result:=t; 983 exit; 984 end; 985 986 CGMessage(type_e_mismatch); 987 end; 988 end; 989 990 { generic code } 991 { overridden by: } 992 { i386 } tunaryminusnode.pass_1null993 function tunaryminusnode.pass_1 : tnode; 994 var 995 procname: string[31]; 996 begin 997 result:=nil; 998 firstpass(left); 999 if codegenerror then 1000 exit; 1001 1002 if (cs_fp_emulation in current_settings.moduleswitches) and (left.resultdef.typ=floatdef) then 1003 begin 1004 if not(target_info.system in systems_wince) then 1005 begin 1006 expectloc:=LOC_REGISTER; 1007 exit; 1008 end 1009 else 1010 begin 1011 case tfloatdef(resultdef).floattype of 1012 s32real: 1013 procname:='negs'; 1014 s64real: 1015 procname:='negd'; 1016 {!!! not yet implemented 1017 s128real: 1018 } 1019 else 1020 internalerror(2005082802); 1021 end; 1022 result:=ccallnode.createintern(procname,ccallparanode.create(left,nil)); 1023 end; 1024 1025 left:=nil; 1026 end 1027 else 1028 begin 1029 if (left.resultdef.typ=floatdef) then 1030 expectloc:=LOC_FPUREGISTER 1031 {$ifdef SUPPORT_MMX} 1032 else if (cs_mmx in current_settings.localswitches) and 1033 is_mmx_able_array(left.resultdef) then 1034 expectloc:=LOC_MMXREGISTER 1035 {$endif SUPPORT_MMX} 1036 else if (left.resultdef.typ=orddef) then 1037 expectloc:=LOC_REGISTER; 1038 end; 1039 end; 1040 1041 {**************************************************************************** 1042 TUNARYPLUSNODE 1043 ****************************************************************************} 1044 1045 constructor tunaryplusnode.create(expr: tnode); 1046 begin 1047 inherited create(unaryplusn,expr); 1048 end; 1049 tunaryplusnode.pass_1null1050 function tunaryplusnode.pass_1: tnode; 1051 begin 1052 result:=nil; 1053 { can never happen because all the conversions happen 1054 in pass_typecheck } 1055 internalerror(201012250); 1056 end; 1057 tunaryplusnode.pass_typechecknull1058 function tunaryplusnode.pass_typecheck: tnode; 1059 var 1060 t:tnode; 1061 begin 1062 result:=nil; 1063 typecheckpass(left); 1064 1065 { avoid any problems with type parameters later on } 1066 if is_typeparam(left.resultdef) then 1067 begin 1068 resultdef:=cundefinedtype; 1069 exit; 1070 end; 1071 1072 set_varstate(left,vs_read,[vsf_must_be_valid]); 1073 if codegenerror then 1074 exit; 1075 1076 if is_constintnode(left) or 1077 is_constrealnode(left) or 1078 (left.resultdef.typ=floatdef) or 1079 is_currency(left.resultdef) 1080 {$ifdef SUPPORT_MMX} 1081 or ((cs_mmx in current_settings.localswitches) and 1082 is_mmx_able_array(left.resultdef)) 1083 {$endif SUPPORT_MMX} 1084 then 1085 begin 1086 result:=left; 1087 left:=nil; 1088 end 1089 else if is_oversizedord(left.resultdef) then 1090 begin 1091 if is_64bit(left.resultdef) then 1092 inserttypeconv(left,s64inttype) 1093 else if is_32bit(left.resultdef) then 1094 inserttypeconv(left,s32inttype) 1095 else if is_16bit(left.resultdef) then 1096 inserttypeconv(left,s16inttype) 1097 else 1098 internalerror(2013040702); 1099 result:=left; 1100 left:=nil; 1101 end 1102 else if (left.resultdef.typ=orddef) then 1103 begin 1104 inserttypeconv(left,sinttype); 1105 result:=left; 1106 left:=nil; 1107 end 1108 else 1109 begin 1110 { allow operator overloading } 1111 t:=self; 1112 if isunaryoverloaded(t,[]) then 1113 begin 1114 result:=t; 1115 exit; 1116 end; 1117 1118 CGMessage(type_e_mismatch); 1119 end; 1120 end; 1121 1122 1123 {**************************************************************************** 1124 TNOTNODE 1125 ****************************************************************************} 1126 1127 const 1128 boolean_reverse:array[ltn..unequaln] of Tnodetype=( 1129 gten,gtn,lten,ltn,unequaln,equaln 1130 ); 1131 1132 constructor tnotnode.create(expr : tnode); 1133 begin 1134 inherited create(notn,expr); 1135 end; 1136 1137 tnotnode.simplifynull1138 function tnotnode.simplify(forinline : boolean):tnode; 1139 var 1140 v : tconstexprint; 1141 t : tnode; 1142 def : tdef; 1143 begin 1144 result:=nil; 1145 { Try optmimizing ourself away } 1146 if left.nodetype=notn then 1147 begin 1148 { Double not. Remove both } 1149 result:=Tnotnode(left).left; 1150 tnotnode(left).left:=nil; 1151 exit; 1152 end; 1153 1154 if (left.nodetype in [ltn,lten,equaln,unequaln,gtn,gten]) then 1155 begin 1156 { Not of boolean expression. Turn around the operator and remove 1157 the not. This is not allowed for sets with the gten/lten, 1158 because there is no ltn/gtn support } 1159 if (taddnode(left).left.resultdef.typ<>setdef) or 1160 (left.nodetype in [equaln,unequaln]) then 1161 begin 1162 result:=left; 1163 left.nodetype:=boolean_reverse[left.nodetype]; 1164 left:=nil; 1165 exit; 1166 end; 1167 end; 1168 1169 { constant folding } 1170 if (left.nodetype=ordconstn) and 1171 (left.resultdef.typ=orddef) then 1172 begin 1173 v:=tordconstnode(left).value; 1174 def:=left.resultdef; 1175 if not calc_not_ordvalue(v,def) then 1176 CGMessage(type_e_mismatch); 1177 { not-nodes are not range checked by the code generator -> also 1178 don't range check while inlining; the resultdef is a bit tricky 1179 though: the node's resultdef gets changed in most cases compared 1180 to left, but the not-operation itself is caried out in the code 1181 generator using the size of left 1182 } 1183 if not(forinline) then 1184 t:=cordconstnode.create(v,def,false) 1185 else 1186 begin 1187 { cut off the value if necessary } 1188 t:=cordconstnode.create(v,left.resultdef,false); 1189 { now convert to node's resultdef } 1190 inserttypeconv_explicit(t,def); 1191 end; 1192 result:=t; 1193 exit; 1194 end; 1195 end; 1196 1197 tnotnode.pass_typechecknull1198 function tnotnode.pass_typecheck : tnode; 1199 var 1200 t : tnode; 1201 begin 1202 result:=nil; 1203 typecheckpass(left); 1204 1205 { avoid any problems with type parameters later on } 1206 if is_typeparam(left.resultdef) then 1207 begin 1208 resultdef:=cundefinedtype; 1209 exit; 1210 end; 1211 1212 set_varstate(left,vs_read,[vsf_must_be_valid]); 1213 if codegenerror then 1214 exit; 1215 1216 { tp procvar support } 1217 maybe_call_procvar(left,true); 1218 1219 resultdef:=left.resultdef; 1220 1221 result:=simplify(false); 1222 if assigned(result) then 1223 exit; 1224 1225 if is_boolean(resultdef) then 1226 begin 1227 end 1228 else 1229 {$ifdef SUPPORT_MMX} 1230 if (cs_mmx in current_settings.localswitches) and 1231 is_mmx_able_array(left.resultdef) then 1232 begin 1233 end 1234 else 1235 {$endif SUPPORT_MMX} 1236 {$ifndef cpu64bitaddr} 1237 if is_64bitint(left.resultdef) then 1238 begin 1239 end 1240 else 1241 {$endif not cpu64bitaddr} 1242 if is_integer(left.resultdef) then 1243 begin 1244 end 1245 else 1246 begin 1247 { allow operator overloading } 1248 t:=self; 1249 if isunaryoverloaded(t,[]) then 1250 begin 1251 result:=t; 1252 exit; 1253 end; 1254 1255 CGMessage(type_e_mismatch); 1256 end; 1257 end; 1258 1259 tnotnode.pass_1null1260 function tnotnode.pass_1 : tnode; 1261 begin 1262 result:=nil; 1263 firstpass(left); 1264 if codegenerror then 1265 exit; 1266 1267 expectloc:=left.expectloc; 1268 if is_boolean(resultdef) then 1269 begin 1270 if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then 1271 expectloc:=LOC_REGISTER; 1272 { before loading it into flags we need to load it into 1273 a register thus 1 register is need PM } 1274 {$ifdef cpuflags} 1275 if left.expectloc<>LOC_JUMP then 1276 expectloc:=LOC_FLAGS; 1277 {$endif def cpuflags} 1278 end 1279 else 1280 {$ifdef SUPPORT_MMX} 1281 if (cs_mmx in current_settings.localswitches) and 1282 is_mmx_able_array(left.resultdef) then 1283 expectloc:=LOC_MMXREGISTER 1284 else 1285 {$endif SUPPORT_MMX} 1286 {$ifndef cpu64bitalu} 1287 if is_64bit(left.resultdef) then 1288 begin 1289 if (expectloc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then 1290 expectloc:=LOC_REGISTER; 1291 end 1292 else 1293 {$endif not cpu64bitalu} 1294 if is_integer(left.resultdef) then 1295 expectloc:=LOC_REGISTER; 1296 end; 1297 1298 {$ifdef state_tracking} Tnotnode.track_state_passnull1299 function Tnotnode.track_state_pass(exec_known:boolean):boolean; 1300 begin 1301 track_state_pass:=true; 1302 if left.track_state_pass(exec_known) then 1303 begin 1304 left.resultdef:=nil; 1305 do_typecheckpass(left); 1306 end; 1307 end; 1308 {$endif} 1309 1310 end. 1311