{ $Id$ Copyright (c) 2000 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 defines.inc} interface uses node; type tmoddivnode = class(tbinopnode) function pass_1 : tnode;override; end; tshlshrnode = class(tbinopnode) function pass_1 : tnode;override; end; tunaryminusnode = class(tunarynode) constructor create(expr : tnode);virtual; function pass_1 : tnode;override; end; tnotnode = class(tunarynode) constructor create(expr : tnode);virtual; function pass_1 : tnode;override; end; var cmoddivnode : class of tmoddivnode; cshlshrnode : class of tshlshrnode; cunaryminusnode : class of tunaryminusnode; cnotnode : class of tnotnode; implementation uses globtype,systems,tokens, verbose,globals, symconst,symtype,symtable,symdef,types, htypechk,pass_1,cpubase,cpuinfo, {$ifdef newcg} cgbase, {$endif newcg} hcodegen, ncon,ncnv,ncal; {**************************************************************************** TMODDIVNODE ****************************************************************************} function tmoddivnode.pass_1 : tnode; var t : tnode; rv,lv : tconstexprint; rd,ld : pdef; begin pass_1:=nil; firstpass(left); set_varstate(left,true); firstpass(right); set_varstate(right,true); if codegenerror then exit; t:=self; if isbinaryoverloaded(t) then begin pass_1:=t; exit; end; { check for division by zero } rv:=tordconstnode(right).value; lv:=tordconstnode(left).value; if is_constintnode(right) and (rv=0) then begin Message(parser_e_division_by_zero); { recover } rv:=1; end; if is_constintnode(left) and is_constintnode(right) then begin case nodetype of modn: t:=genintconstnode(lv mod rv); divn: t:=genintconstnode(lv div rv); end; firstpass(t); pass_1:=t; exit; end; { 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) } if (left.resulttype^.deftype=orddef) and (right.resulttype^.deftype=orddef) then if (porddef(right.resulttype)^.typ = u32bit) and is_constintnode(left) and (tordconstnode(left).value >= 0) then begin left := gentypeconvnode(left,u32bitdef); firstpass(left); end else if (porddef(left.resulttype)^.typ = u32bit) and is_constintnode(right) and (tordconstnode(right).value >= 0) then begin right := gentypeconvnode(right,u32bitdef); firstpass(right); end; if (left.resulttype^.deftype=orddef) and (right.resulttype^.deftype=orddef) and (is_64bitint(left.resulttype) or is_64bitint(right.resulttype) or { when mixing cardinals and signed numbers, convert everythign to 64bit (JM) } ((porddef(right.resulttype)^.typ = u32bit) and is_signed(left.resulttype)) or ((porddef(left.resulttype)^.typ = u32bit) and is_signed(right.resulttype))) then begin rd:=right.resulttype; ld:=left.resulttype; { issue warning if necessary } if not (is_64bitint(left.resulttype) or is_64bitint(right.resulttype)) then CGMessage(type_w_mixed_signed_unsigned); if is_signed(rd) or is_signed(ld) then begin if (porddef(ld)^.typ<>s64bit) then begin left:=gentypeconvnode(left,cs64bitdef); firstpass(left); end; if (porddef(rd)^.typ<>s64bit) then begin right:=gentypeconvnode(right,cs64bitdef); firstpass(right); end; calcregisters(self,2,0,0); end else begin if (porddef(ld)^.typ<>u64bit) then begin left:=gentypeconvnode(left,cu64bitdef); firstpass(left); end; if (porddef(rd)^.typ<>u64bit) then begin right:=gentypeconvnode(right,cu64bitdef); firstpass(right); end; calcregisters(self,2,0,0); end; resulttype:=left.resulttype; end else begin if not(right.resulttype^.deftype=orddef) or not(porddef(right.resulttype)^.typ in [s32bit,u32bit]) then right:=gentypeconvnode(right,s32bitdef); if not(left.resulttype^.deftype=orddef) or not(porddef(left.resulttype)^.typ in [s32bit,u32bit]) then left:=gentypeconvnode(left,s32bitdef); firstpass(left); firstpass(right); { the resulttype depends on the right side, because the left becomes } { always 64 bit } resulttype:=right.resulttype; if codegenerror then exit; left_right_max; if left.registers32<=right.registers32 then inc(registers32); end; location.loc:=LOC_REGISTER; end; {**************************************************************************** TSHLSHRNODE ****************************************************************************} function tshlshrnode.pass_1 : tnode; var t : tnode; regs : longint; begin pass_1:=nil; firstpass(left); set_varstate(left,true); firstpass(right); set_varstate(right,true); if codegenerror then exit; t:=self; if isbinaryoverloaded(t) then begin pass_1:=t; exit; end; if is_constintnode(left) and is_constintnode(right) then begin case nodetype of shrn: t:=genintconstnode(tordconstnode(left).value shr tordconstnode(right).value); shln: t:=genintconstnode(tordconstnode(left).value shl tordconstnode(right).value); end; firstpass(t); pass_1:=t; exit; end; { 64 bit ints have their own shift handling } if not(is_64bitint(left.resulttype)) then begin if porddef(left.resulttype)^.typ <> u32bit then left:=gentypeconvnode(left,s32bitdef); firstpass(left); regs:=1; resulttype:=left.resulttype; end else begin resulttype:=left.resulttype; regs:=2; end; right:=gentypeconvnode(right,s32bitdef); firstpass(right); if codegenerror then exit; if (right.nodetype<>ordconstn) then inc(regs); calcregisters(self,regs,0,0); location.loc:=LOC_REGISTER; end; {**************************************************************************** TUNARYMINUSNODE ****************************************************************************} constructor tunaryminusnode.create(expr : tnode); begin inherited create(unaryminusn,expr); end; function tunaryminusnode.pass_1 : tnode; var t : tnode; minusdef : pprocdef; begin pass_1:=nil; firstpass(left); set_varstate(left,true); registers32:=left.registers32; registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} resulttype:=left.resulttype; if codegenerror then exit; if is_constintnode(left) then begin t:=genintconstnode(-tordconstnode(left).value); firstpass(t); pass_1:=t; exit; end; { nasm can not cope with negativ reals !! } if is_constrealnode(left) {$ifdef i386} and not(aktoutputformat in [as_i386_nasmcoff,as_i386_nasmelf,as_i386_nasmobj]) {$endif i386} then begin t:=genrealconstnode(-trealconstnode(left).value_real,bestrealdef^); firstpass(t); pass_1:=t; exit; end; if (left.resulttype^.deftype=floatdef) then begin if pfloatdef(left.resulttype)^.typ=f32bit then begin if (left.location.loc<>LOC_REGISTER) and (registers32<1) then registers32:=1; location.loc:=LOC_REGISTER; end else location.loc:=LOC_FPU; end {$ifdef SUPPORT_MMX} else if (cs_mmx in aktlocalswitches) and is_mmx_able_array(left.resulttype) then begin if (left.location.loc<>LOC_MMXREGISTER) and (registersmmx<1) then registersmmx:=1; { if saturation is on, left.resulttype isn't "mmx able" (FK) if (cs_mmx_saturation in aktlocalswitches^) and (porddef(parraydef(resulttype)^.definition)^.typ in [s32bit,u32bit]) then CGMessage(type_e_mismatch); } end {$endif SUPPORT_MMX} else if is_64bitint(left.resulttype) then begin firstpass(left); registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} registers32:=left.registers32; if codegenerror then exit; if (left.location.loc<>LOC_REGISTER) and (registers32<2) then registers32:=2; location.loc:=LOC_REGISTER; resulttype:=left.resulttype; end else if (left.resulttype^.deftype=orddef) then begin left:=gentypeconvnode(left,s32bitdef); firstpass(left); registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} registers32:=left.registers32; if codegenerror then exit; if (left.location.loc<>LOC_REGISTER) and (registers32<1) then registers32:=1; location.loc:=LOC_REGISTER; resulttype:=left.resulttype; end else begin if assigned(overloaded_operators[_minus]) then minusdef:=overloaded_operators[_minus]^.definition else minusdef:=nil; while assigned(minusdef) do begin if is_equal(tparaitem(minusdef^.para.first).paratype.def,left.resulttype) and (tparaitem(minusdef^.para.first).next=nil) then begin t:=gencallnode(overloaded_operators[_minus],nil); tcallnode(t).left:=gencallparanode(left,nil); left:=nil; firstpass(t); pass_1:=t; exit; end; minusdef:=minusdef^.nextoverloaded; end; CGMessage(type_e_mismatch); end; end; {**************************************************************************** TNOTNODE ****************************************************************************} constructor tnotnode.create(expr : tnode); begin inherited create(notn,expr); end; function tnotnode.pass_1 : tnode; var t : tnode; notdef : pprocdef; begin pass_1:=nil; firstpass(left); set_varstate(left,true); if codegenerror then exit; if (left.nodetype=ordconstn) then begin if is_boolean(left.resulttype) then { here we do a boolena(byte(..)) type cast because } { boolean() is buggy in 1.00 } t:=genordinalconstnode(byte(not(boolean(byte(tordconstnode(left).value)))),left.resulttype) else t:=genordinalconstnode(not(tordconstnode(left).value),left.resulttype); firstpass(t); pass_1:=t; exit; end; resulttype:=left.resulttype; location.loc:=left.location.loc; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} if is_boolean(resulttype) then begin registers32:=left.registers32; if (location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then begin location.loc:=LOC_REGISTER; if (registers32<1) then registers32:=1; end; { before loading it into flags we need to load it into a register thus 1 register is need PM } {$ifdef i386} if left.location.loc<>LOC_JUMP then location.loc:=LOC_FLAGS; {$endif def i386} end else {$ifdef SUPPORT_MMX} if (cs_mmx in aktlocalswitches) and is_mmx_able_array(left.resulttype) then begin if (left.location.loc<>LOC_MMXREGISTER) and (registersmmx<1) then registersmmx:=1; end else {$endif SUPPORT_MMX} if is_64bitint(left.resulttype) then begin registers32:=left.registers32; if (location.loc in [LOC_REFERENCE,LOC_MEM,LOC_CREGISTER]) then begin location.loc:=LOC_REGISTER; if (registers32<2) then registers32:=2; end; end else if is_integer(left.resulttype) then begin left:=gentypeconvnode(left,s32bitdef); firstpass(left); if codegenerror then exit; resulttype:=left.resulttype; registers32:=left.registers32; {$ifdef SUPPORT_MMX} registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} if (left.location.loc<>LOC_REGISTER) and (registers32<1) then registers32:=1; location.loc:=LOC_REGISTER; end else begin if assigned(overloaded_operators[_op_not]) then notdef:=overloaded_operators[_op_not]^.definition else notdef:=nil; while assigned(notdef) do begin if is_equal(tparaitem(notdef^.para.first).paratype.def,left.resulttype) and (tparaitem(notdef^.para.first).next=nil) then begin t:=gencallnode(overloaded_operators[_op_not],nil); tcallnode(t).left:=gencallparanode(left,nil); left:=nil; firstpass(t); pass_1:=t; exit; end; notdef:=notdef^.nextoverloaded; end; CGMessage(type_e_mismatch); end; registersfpu:=left.registersfpu; end; begin cmoddivnode:=tmoddivnode; cshlshrnode:=tshlshrnode; cunaryminusnode:=tunaryminusnode; cnotnode:=tnotnode; end. { $Log$ Revision 1.13 2001-01-06 18:28:39 peter * fixed wrong notes about locals Revision 1.12 2001/01/05 17:36:57 florian * the info about exception frames is stored now on the stack instead on the heap Revision 1.11 2000/12/25 00:07:26 peter + new tlinkedlist class (merge of old tstringqueue,tcontainer and tlinkedlist objects) Revision 1.10 2000/12/16 15:54:01 jonas * 'resulttype of cardinal shl/shr x' is cardinal instead of longint Revision 1.9 2000/11/29 00:30:34 florian * unused units removed from uses clause * some changes for widestrings Revision 1.8 2000/10/31 22:02:49 peter * symtable splitted, no real code changes Revision 1.7 2000/10/01 19:48:24 peter * lot of compile updates for cg11 Revision 1.6 2000/09/27 21:33:22 florian * finally nadd.pas compiles Revision 1.5 2000/09/27 20:25:44 florian * more stuff fixed Revision 1.4 2000/09/24 15:06:19 peter * use defines.inc Revision 1.3 2000/09/22 22:48:54 florian * some fixes Revision 1.2 2000/09/22 22:09:54 florian * more stuff converted Revision 1.1 2000/09/20 21:35:12 florian * initial revision }