development/compilers/freepascal/compiler/tcmat.pas

   1 {
   2     $Id$
   3     Copyright (c) 1998-2000 by Florian Klaempfl
   4
   5     Type checking and register allocation for math nodes
   6
   7     This program is free software; you can redistribute it and/or modify
   8     it under the terms of the GNU General Public License as published by
   9     the Free Software Foundation; either version 2 of the License, or
  10     (at your option) any later version.
  11
  12     This program is distributed in the hope that it will be useful,
  13     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15     GNU General Public License for more details.
  16
  17     You should have received a copy of the GNU General Public License
  18     along with this program; if not, write to the Free Software
  19     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20
  21  ****************************************************************************
  22 }
  23 unit tcmat;
  24 interface
  25
  26     uses
  27       tree;
  28
  29     procedure firstmoddiv(var p : ptree);
  30     procedure firstshlshr(var p : ptree);
  31     procedure firstunaryminus(var p : ptree);
  32     procedure firstnot(var p : ptree);
  33
  34
  35 implementation
  36
  37     uses
  38       globtype,systems,tokens,
  39       cobjects,verbose,globals,
  40       symconst,symtable,aasm,types,
  41       htypechk,pass_1,cpubase,
  42 {$ifdef newcg}
  43       cgbase,
  44 {$else newcg}
  45       hcodegen,
  46 {$endif newcg}
  47       { for isbinaryoverloaded function }
  48       tcadd;
  49
  50 {*****************************************************************************
  51                              FirstModDiv
  52 *****************************************************************************}
  53
  54     procedure firstmoddiv(var p : ptree);
  55       var
  56          t : ptree;
  57          rv,lv : longint;
  58          rd,ld : pdef;
  59
  60       begin
  61          firstpass(p^.left);
  62          set_varstate(p^.left,true);
  63          firstpass(p^.right);
  64          set_varstate(p^.right,true);
  65          if codegenerror then
  66            exit;
  67
  68          if isbinaryoverloaded(p) then
  69            exit;
  70
  71          { check for division by zero }
  72          rv:=p^.right^.value;
  73          lv:=p^.left^.value;
  74          if is_constintnode(p^.right) and (rv=0) then
  75           begin
  76             Message(parser_e_division_by_zero);
  77             { recover }
  78             rv:=1;
  79           end;
  80
  81          if is_constintnode(p^.left) and is_constintnode(p^.right) then
  82            begin
  83               case p^.treetype of
  84                 modn : t:=genordinalconstnode(lv mod rv,s32bitdef);
  85                 divn : t:=genordinalconstnode(lv div rv,s32bitdef);
  86               end;
  87               disposetree(p);
  88               firstpass(t);
  89               p:=t;
  90               exit;
  91            end;
  92          { if one operand is a cardinal and the other is a positive constant, convert the }
  93          { constant to a cardinal as well so we don't have to do a 64bit division (JM)    }
  94          if (p^.left^.resulttype^.deftype=orddef) and (p^.right^.resulttype^.deftype=orddef) then
  95            if (porddef(p^.right^.resulttype)^.typ = u32bit) and
  96               is_constintnode(p^.left) and
  97               (p^.left^.value >= 0) then
  98              begin
  99                p^.left := gentypeconvnode(p^.left,u32bitdef);
 100                firstpass(p^.left);
 101              end
 102            else if (porddef(p^.left^.resulttype)^.typ = u32bit) and
 103               is_constintnode(p^.right) and
 104               (p^.right^.value >= 0) then
 105              begin
 106                p^.right := gentypeconvnode(p^.right,u32bitdef);
 107                firstpass(p^.right);
 108              end;
 109
 110          if (p^.left^.resulttype^.deftype=orddef) and (p^.right^.resulttype^.deftype=orddef) and
 111             (is_64bitint(p^.left^.resulttype) or is_64bitint(p^.right^.resulttype) or
 112              { when mixing cardinals and signed numbers, convert everythign to 64bit (JM) }
 113              ((porddef(p^.right^.resulttype)^.typ = u32bit) and
 114               is_signed(p^.left^.resulttype)) or
 115              ((porddef(p^.left^.resulttype)^.typ = u32bit) and
 116               is_signed(p^.right^.resulttype))) then
 117            begin
 118               rd:=p^.right^.resulttype;
 119               ld:=p^.left^.resulttype;
 120               { issue warning if necessary }
 121               if not (is_64bitint(p^.left^.resulttype) or is_64bitint(p^.right^.resulttype)) then
 122                 CGMessage(type_w_mixed_signed_unsigned);
 123               if is_signed(rd) or is_signed(ld) then
 124                 begin
 125                    if (porddef(ld)^.typ<>s64bit) then
 126                      begin
 127                        p^.left:=gentypeconvnode(p^.left,cs64bitdef);
 128                        firstpass(p^.left);
 129                      end;
 130                    if (porddef(rd)^.typ<>s64bit) then
 131                      begin
 132                         p^.right:=gentypeconvnode(p^.right,cs64bitdef);
 133                         firstpass(p^.right);
 134                      end;
 135                    calcregisters(p,2,0,0);
 136                 end
 137               else
 138                 begin
 139                    if (porddef(ld)^.typ<>u64bit) then
 140                      begin
 141                        p^.left:=gentypeconvnode(p^.left,cu64bitdef);
 142                        firstpass(p^.left);
 143                      end;
 144                    if (porddef(rd)^.typ<>u64bit) then
 145                      begin
 146                         p^.right:=gentypeconvnode(p^.right,cu64bitdef);
 147                         firstpass(p^.right);
 148                      end;
 149                    calcregisters(p,2,0,0);
 150                 end;
 151               p^.resulttype:=p^.left^.resulttype;
 152            end
 153          else
 154            begin
 155               if not(p^.right^.resulttype^.deftype=orddef) or
 156                 not(porddef(p^.right^.resulttype)^.typ in [s32bit,u32bit]) then
 157                 p^.right:=gentypeconvnode(p^.right,s32bitdef);
 158
 159               if not(p^.left^.resulttype^.deftype=orddef) or
 160                 not(porddef(p^.left^.resulttype)^.typ in [s32bit,u32bit]) then
 161                 p^.left:=gentypeconvnode(p^.left,s32bitdef);
 162
 163               firstpass(p^.left);
 164               firstpass(p^.right);
 165
 166               { the resulttype depends on the right side, because the left becomes }
 167               { always 64 bit                                                      }
 168               p^.resulttype:=p^.right^.resulttype;
 169
 170               if codegenerror then
 171                 exit;
 172
 173               left_right_max(p);
 174               if p^.left^.registers32<=p^.right^.registers32 then
 175                 inc(p^.registers32);
 176            end;
 177          p^.location.loc:=LOC_REGISTER;
 178       end;
 179
 180
 181 {*****************************************************************************
 182                              FirstShlShr
 183 *****************************************************************************}
 184
 185     procedure firstshlshr(var p : ptree);
 186       var
 187          t : ptree;
 188          regs : longint;
 189       begin
 190          firstpass(p^.left);
 191          set_varstate(p^.left,true);
 192          firstpass(p^.right);
 193          set_varstate(p^.right,true);
 194          if codegenerror then
 195            exit;
 196
 197          if isbinaryoverloaded(p) then
 198            exit;
 199
 200          if is_constintnode(p^.left) and is_constintnode(p^.right) then
 201            begin
 202               case p^.treetype of
 203                  shrn : t:=genordinalconstnode(p^.left^.value shr p^.right^.value,s32bitdef);
 204                  shln : t:=genordinalconstnode(p^.left^.value shl p^.right^.value,s32bitdef);
 205               end;
 206               disposetree(p);
 207               firstpass(t);
 208               p:=t;
 209               exit;
 210            end;
 211          { 64 bit ints have their own shift handling }
 212          if not(is_64bitint(p^.left^.resulttype)) then
 213            begin
 214               if porddef(p^.left^.resulttype)^.typ <> u32bit then
 215                 p^.left:=gentypeconvnode(p^.left,s32bitdef);
 216               firstpass(p^.left);
 217               regs:=1;
 218               p^.resulttype:=p^.left^.resulttype;
 219            end
 220          else
 221            begin
 222               p^.resulttype:=p^.left^.resulttype;
 223               regs:=2;
 224            end;
 225
 226          p^.right:=gentypeconvnode(p^.right,s32bitdef);
 227          firstpass(p^.right);
 228
 229          if codegenerror then
 230            exit;
 231
 232          if (p^.right^.treetype<>ordconstn) then
 233           inc(regs);
 234          calcregisters(p,regs,0,0);
 235
 236          p^.location.loc:=LOC_REGISTER;
 237       end;
 238
 239
 240 {*****************************************************************************
 241                              FirstUnaryMinus
 242 *****************************************************************************}
 243
 244     procedure firstunaryminus(var p : ptree);
 245       var
 246          t : ptree;
 247          minusdef : pprocdef;
 248       begin
 249          firstpass(p^.left);
 250          set_varstate(p^.left,true);
 251          p^.registers32:=p^.left^.registers32;
 252          p^.registersfpu:=p^.left^.registersfpu;
 253 {$ifdef SUPPORT_MMX}
 254          p^.registersmmx:=p^.left^.registersmmx;
 255 {$endif SUPPORT_MMX}
 256          p^.resulttype:=p^.left^.resulttype;
 257          if codegenerror then
 258            exit;
 259          if is_constintnode(p^.left) then
 260            begin
 261               t:=genordinalconstnode(-p^.left^.value,s32bitdef);
 262               disposetree(p);
 263               firstpass(t);
 264               p:=t;
 265               exit;
 266            end;
 267            { nasm can not cope with negativ reals !! }
 268          if is_constrealnode(p^.left)
 269 {$ifdef i386}
 270            and not(aktoutputformat in [as_i386_nasmcoff,as_i386_nasmelf,as_i386_nasmobj])
 271 {$endif i386}
 272              then
 273            begin
 274               t:=genrealconstnode(-p^.left^.value_real,bestrealdef^);
 275               disposetree(p);
 276               firstpass(t);
 277               p:=t;
 278               exit;
 279            end;
 280          if (p^.left^.resulttype^.deftype=floatdef) then
 281            begin
 282               if pfloatdef(p^.left^.resulttype)^.typ=f32bit then
 283                 begin
 284                    if (p^.left^.location.loc<>LOC_REGISTER) and
 285                      (p^.registers32<1) then
 286                      p^.registers32:=1;
 287                    p^.location.loc:=LOC_REGISTER;
 288                 end
 289               else
 290                 p^.location.loc:=LOC_FPU;
 291            end
 292 {$ifdef SUPPORT_MMX}
 293          else if (cs_mmx in aktlocalswitches) and
 294            is_mmx_able_array(p^.left^.resulttype) then
 295              begin
 296                if (p^.left^.location.loc<>LOC_MMXREGISTER) and
 297                  (p^.registersmmx<1) then
 298                  p^.registersmmx:=1;
 299                { if saturation is on, p^.left^.resulttype isn't
 300                  "mmx able" (FK)
 301                if (cs_mmx_saturation in aktlocalswitches^) and
 302                  (porddef(parraydef(p^.resulttype)^.definition)^.typ in
 303                  [s32bit,u32bit]) then
 304                  CGMessage(type_e_mismatch);
 305                }
 306              end
 307 {$endif SUPPORT_MMX}
 308          else if is_64bitint(p^.left^.resulttype) then
 309            begin
 310               firstpass(p^.left);
 311               p^.registersfpu:=p^.left^.registersfpu;
 312 {$ifdef SUPPORT_MMX}
 313               p^.registersmmx:=p^.left^.registersmmx;
 314 {$endif SUPPORT_MMX}
 315               p^.registers32:=p^.left^.registers32;
 316               if codegenerror then
 317                 exit;
 318               if (p^.left^.location.loc<>LOC_REGISTER) and
 319                 (p^.registers32<2) then
 320               p^.registers32:=2;
 321               p^.location.loc:=LOC_REGISTER;
 322               p^.resulttype:=p^.left^.resulttype;
 323            end
 324          else if (p^.left^.resulttype^.deftype=orddef) then
 325            begin
 326               p^.left:=gentypeconvnode(p^.left,s32bitdef);
 327               firstpass(p^.left);
 328               p^.registersfpu:=p^.left^.registersfpu;
 329 {$ifdef SUPPORT_MMX}
 330               p^.registersmmx:=p^.left^.registersmmx;
 331 {$endif SUPPORT_MMX}
 332               p^.registers32:=p^.left^.registers32;
 333               if codegenerror then
 334                 exit;
 335               if (p^.left^.location.loc<>LOC_REGISTER) and
 336                 (p^.registers32<1) then
 337               p^.registers32:=1;
 338               p^.location.loc:=LOC_REGISTER;
 339               p^.resulttype:=p^.left^.resulttype;
 340            end
 341          else
 342            begin
 343               if assigned(overloaded_operators[_minus]) then
 344                 minusdef:=overloaded_operators[_minus]^.definition
 345               else
 346                 minusdef:=nil;
 347               while assigned(minusdef) do
 348                 begin
 349                    if is_equal(pparaitem(minusdef^.para^.first)^.paratype.def,p^.left^.resulttype) and
 350                       (pparaitem(minusdef^.para^.first)^.next=nil) then
 351                      begin
 352                         t:=gencallnode(overloaded_operators[_minus],nil);
 353                         t^.left:=gencallparanode(p^.left,nil);
 354                         putnode(p);
 355                         p:=t;
 356                         firstpass(p);
 357                         exit;
 358                      end;
 359                    minusdef:=minusdef^.nextoverloaded;
 360                 end;
 361               CGMessage(type_e_mismatch);
 362            end;
 363       end;
 364
 365
 366 {*****************************************************************************
 367                                FirstNot
 368 *****************************************************************************}
 369
 370     procedure firstnot(var p : ptree);
 371       var
 372          t : ptree;
 373          notdef : pprocdef;
 374       begin
 375          firstpass(p^.left);
 376          set_varstate(p^.left,true);
 377          if codegenerror then
 378            exit;
 379
 380          if (p^.left^.treetype=ordconstn) then
 381            begin
 382               if is_boolean(p^.left^.resulttype) then
 383                t:=genordinalconstnode(byte(not(boolean(p^.left^.value))),p^.left^.resulttype)
 384               else
 385                t:=genordinalconstnode(not(p^.left^.value),p^.left^.resulttype);
 386               disposetree(p);
 387               firstpass(t);
 388               p:=t;
 389               exit;
 390            end;
 391          p^.resulttype:=p^.left^.resulttype;
 392          p^.location.loc:=p^.left^.location.loc;
 393 {$ifdef SUPPORT_MMX}
 394          p^.registersmmx:=p^.left^.registersmmx;
 395 {$endif SUPPORT_MMX}
 396          if is_boolean(p^.resulttype) then
 397            begin
 398              p^.registers32:=p^.left^.registers32;
 399              if (p^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
 400               begin
 401                 p^.location.loc:=LOC_REGISTER;
 402                 if (p^.registers32<1) then
 403                  p^.registers32:=1;
 404               end;
 405             { before loading it into flags we need to load it into
 406               a register thus 1 register is need PM }
 407 {$ifdef i386}
 408              if p^.left^.location.loc<>LOC_JUMP then
 409                p^.location.loc:=LOC_FLAGS;
 410 {$endif def i386}
 411            end
 412          else
 413 {$ifdef SUPPORT_MMX}
 414            if (cs_mmx in aktlocalswitches) and
 415              is_mmx_able_array(p^.left^.resulttype) then
 416              begin
 417                if (p^.left^.location.loc<>LOC_MMXREGISTER) and
 418                  (p^.registersmmx<1) then
 419                  p^.registersmmx:=1;
 420              end
 421          else
 422 {$endif SUPPORT_MMX}
 423            if is_64bitint(p^.left^.resulttype) then
 424              begin
 425                 p^.registers32:=p^.left^.registers32;
 426                 if (p^.location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then
 427                  begin
 428                    p^.location.loc:=LOC_REGISTER;
 429                    if (p^.registers32<2) then
 430                     p^.registers32:=2;
 431                  end;
 432              end
 433          else if is_integer(p^.left^.resulttype) then
 434            begin
 435               p^.left:=gentypeconvnode(p^.left,s32bitdef);
 436               firstpass(p^.left);
 437               if codegenerror then
 438                 exit;
 439
 440               p^.resulttype:=p^.left^.resulttype;
 441               p^.registers32:=p^.left^.registers32;
 442 {$ifdef SUPPORT_MMX}
 443               p^.registersmmx:=p^.left^.registersmmx;
 444 {$endif SUPPORT_MMX}
 445
 446               if (p^.left^.location.loc<>LOC_REGISTER) and
 447                  (p^.registers32<1) then
 448                 p^.registers32:=1;
 449               p^.location.loc:=LOC_REGISTER;
 450            end
 451          else
 452            begin
 453               if assigned(overloaded_operators[_op_not]) then
 454                 notdef:=overloaded_operators[_op_not]^.definition
 455               else
 456                 notdef:=nil;
 457               while assigned(notdef) do
 458                 begin
 459                    if is_equal(pparaitem(notdef^.para^.first)^.paratype.def,p^.left^.resulttype) and
 460                       (pparaitem(notdef^.para^.first)^.next=nil) then
 461                      begin
 462                         t:=gencallnode(overloaded_operators[_op_not],nil);
 463                         t^.left:=gencallparanode(p^.left,nil);
 464                         putnode(p);
 465                         p:=t;
 466                         firstpass(p);
 467                         exit;
 468                      end;
 469                    notdef:=notdef^.nextoverloaded;
 470                 end;
 471               CGMessage(type_e_mismatch);
 472            end;
 473
 474          p^.registersfpu:=p^.left^.registersfpu;
 475       end;
 476
 477
 478
 479 end.
 480 {
 481   $Log$
 482   Revision 1.1  2002/02/19 08:24:04  sasu
 483   Initial revision
 484
 485   Revision 1.1.2.3  2000/12/16 15:54:00  jonas
 486     * 'resulttype of cardinal shl/shr x' is cardinal instead of longint
 487
 488   Revision 1.1.2.2  2000/12/15 13:55:46  jonas
 489     * fixed bug in division of qwords (introduced by previous patch)
 490
 491   Revision 1.1.2.1  2000/12/13 12:25:40  jonas
 492     + also added 64bit conversion when using cardinals and signed
 493       expressions for div (in tcmat this time :)
 494     * removed automatic type conversion back to dword of 64bit results
 495
 496   Revision 1.1  2000/07/13 06:29:59  michael
 497   + Initial import
 498
 499   Revision 1.31  2000/06/05 20:41:18  pierre
 500     + support for NOT overloading
 501     + unsupported overloaded operators generate errors
 502
 503   Revision 1.30  2000/06/02 21:13:56  pierre
 504    * use is_equal instead of direct def equality in unary minus overload
 505
 506   Revision 1.29  2000/02/17 14:53:43  florian
 507     * some updates for the newcg
 508
 509   Revision 1.28  2000/02/09 13:23:08  peter
 510     * log truncated
 511
 512   Revision 1.27  2000/01/07 01:14:46  peter
 513     * updated copyright to 2000
 514
 515   Revision 1.26  1999/12/11 18:53:31  jonas
 516     * fixed type conversions of results of operations with cardinals
 517       (between -dcardinalmulfix)
 518
 519   Revision 1.25  1999/11/30 10:40:58  peter
 520     + ttype, tsymlist
 521
 522   Revision 1.24  1999/11/26 13:51:29  pierre
 523    * fix for overloading of shr shl mod and div
 524
 525   Revision 1.23  1999/11/18 15:34:50  pierre
 526     * Notes/Hints for local syms changed to
 527       Set_varstate function
 528
 529   Revision 1.22  1999/11/06 14:34:30  peter
 530     * truncated log to 20 revs
 531
 532   Revision 1.21  1999/10/26 12:30:46  peter
 533     * const parameter is now checked
 534     * better and generic check if a node can be used for assigning
 535     * export fixes
 536     * procvar equal works now (it never had worked at least from 0.99.8)
 537     * defcoll changed to linkedlist with pparaitem so it can easily be
 538       walked both directions
 539
 540   Revision 1.20  1999/08/23 23:37:01  pierre
 541    * firstnot register counting error corrected
 542
 543   Revision 1.19  1999/08/04 13:03:15  jonas
 544     * all tokens now start with an underscore
 545     * PowerPC compiles!!
 546
 547   Revision 1.18  1999/08/04 00:23:43  florian
 548     * renamed i386asm and i386base to cpuasm and cpubase
 549
 550   Revision 1.17  1999/08/03 22:03:34  peter
 551     * moved bitmask constants to sets
 552     * some other type/const renamings
 553
 554 }