freepascal.compiler/compiler/nmem.pas

{
    $Id$
    Copyright (c) 2000 by Florian Klaempfl

    Type checking and register allocation for memory related 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 nmem;

{$i defines.inc}

interface

    uses
       node,symtable,cpubase;

    type
       tloadvmtnode = class(tnode)
          constructor create;virtual;
          function pass_1 : tnode;override;
       end;

       thnewnode = class(tnode) // fixme
          function pass_1 : tnode;override;
       end;

       tnewnode = class(tunarynode)
          constructor create(l : tnode);virtual;
          function pass_1 : tnode;override;
       end;

       thdisposenode = class(tnode)  // fixme
       end;

       tsimplenewdisposenode = class(tnode) // fixme
          function pass_1 : tnode;override;
       end;

       taddrnode = class(tunarynode)
          constructor create(l : tnode);virtual;
          function pass_1 : tnode;override;
       end;

       tdoubleaddrnode = class(tunarynode)
          constructor create(l : tnode);virtual;
          function pass_1 : tnode;override;
       end;

       tderefnode = class(tunarynode)
          constructor create(l : tnode);virtual;
          function pass_1 : tnode;override;
       end;

       tsubscriptnode = class(tunarynode)
          vs : pvarsym;
          constructor create(varsym : psym;l : tnode);virtual;
          function getcopy : tnode;
          function pass_1 : tnode;override;
       end;

       tvecnode = class(tbinarynode)
          constructor create(l,r : tnode);virtual;
          function pass_1 : tnode;override;
       end;

       tselfnode = class(tnode)
          constructor create(_class : pdef);virtual;
          function pass_1 : tnode;override;
       end;

       twithnode = class(tbinarynode)
{$IFDEF NEWST}
          withsymtables : Pcollection;
          withreference : preference;

{$ELSE}
          withsymtable : pwithsymtable;
          tablecount : longint;
          withreference:preference;
{$ENDIF NEWST}
          constructor create(symtable : pwithsymtable;l,r : tnode;count : longint);virtual;
          function getcopy : tnode;
          function pass_1 : tnode;override;
       end;

    function gensubscriptnode(varsym : pvarsym;l : tnode) : tsubscriptnode;
    function genselfnode(_class : pdef) : tselfnode;
{$IFDEF NEWST}
    function genwithnode(symtables:Pcollection;l,r : tnode) : twithnode;
{$ELSE}
    function genwithnode(symtable:pwithsymtable;l,r : tnode;count : longint) : twithnode;
{$ENDIF NEWST}

    var
       cloadvmtnode : class of tloadvmtnode;
       chnewnode : class of thnewnode;
       cnewnode : class of tnewnode;
       chdisposenode : class of thdisposenode;
       csimplenewdisposenode : class of tsimplenewdisposenode;
       caddrnode : class of taddrnode;
       cdoubleaddrnode : class of tdoubleaddrnode;
       cderefnode : class of tderefnode;
       csubscriptnode : class of tsubscriptnode;
       cvecnode : class of tvecnode;
       cselfnode : class of tselfnode;
       cwithnode : class of twithnode;

implementation

    uses
      globtype,systems,
      cutils,cobjects,verbose,globals,
      symconst,aasm,types,
      htypechk,pass_1
{$ifdef newcg}
      ,cgbase
{$else newcg}
      ,hcodegen
{$endif newcg}
      ;

    function genselfnode(_class : pdef) : tselfnode;

      var
         p : tnode;

      begin
         genselfnode:=cselfnode.create(_class);
      end;

{$IFDEF NEWST}
   function genwithnode(symtables:Pcollection;l,r : tnode) : tnode;

      var
         p : tnode;

      begin
         !!!!!!!!! fixme
         p:=getnode;
         disposetyp:=dt_with;
         treetype:=withn;
         left:=l;
         right:=r;
         registers32:=0;
{$ifdef SUPPORT_MMX}
         registersmmx:=0;
{$endif SUPPORT_MMX}
         resulttype:=nil;
         withsymtables:=symtables;
         withreference:=nil;
         set_file_line(l,p);
         genwithnode:=p;
      end;
{$ELSE}
   function genwithnode(symtable : pwithsymtable;l,r : tnode;count : longint) : twithnode;

      begin
         genwithnode:=cwithnode.create(symtable,l,r,count);
      end;
{$ENDIF NEWST}

    function gensubscriptnode(varsym : pvarsym;l : tnode) : tsubscriptnode;

      begin
         gensubscriptnode:=csubscriptnode.create(varsym,l);
      end;

{*****************************************************************************
                            TLOADVMTNODE
*****************************************************************************}

    constructor tloadvmtnode.create;

      begin
         inherited create(loadvmtn);
      end;

    function tloadvmtnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         registers32:=1;
         location.loc:=LOC_REGISTER;
      end;

{*****************************************************************************
                             THNEWNODE
*****************************************************************************}

    function thnewnode.pass_1 : tnode;
      begin
         pass_1:=nil;
      end;


{*****************************************************************************
                              TNEWNODE
*****************************************************************************}

    constructor tnewnode.create(l : tnode);

      begin
         inherited create(newn,l);
      end;

    function tnewnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         if assigned(left) then
           firstpass(left);

         if codegenerror then
           exit;
         if assigned(left) then
           begin
              registers32:=left.registers32;
              registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
              registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
           end;
         { result type is already set }
         procinfo^.flags:=procinfo^.flags or pi_do_call;
         if assigned(left) then
           location.loc:=LOC_REGISTER
         else
           location.loc:=LOC_REFERENCE;
      end;


{*****************************************************************************
                            THDISPOSENODE
*****************************************************************************}

    function thdisposenode.pass_1 : tnode;
      begin
         pass_1:=nil;
         firstpass(left);

         if codegenerror then
           exit;

         registers32:=left.registers32;
         registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
         registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
         if registers32<1 then
           registers32:=1;
         {
         if left.location.loc<>LOC_REFERENCE then
           CGMessage(cg_e_illegal_expression);
         }
         if left.location.loc=LOC_CREGISTER then
           inc(registers32);
         location.loc:=LOC_REFERENCE;
         resulttype:=ppointerdef(left.resulttype)^.pointertype.def;
      end;


{*****************************************************************************
                        TSIMPLENEWDISPOSENODE
*****************************************************************************}

    function tsimplenewdisposenode.pass_1 : tnode;
      begin
         pass_1:=nil;
         { this cannot be in a register !! }
         make_not_regable(left);

         firstpass(left);
         if codegenerror then
          exit;

         { check the type }
         if left.resulttype=nil then
          left.resulttype:=generrordef;
         if (left.resulttype^.deftype<>pointerdef) then
           CGMessage1(type_e_pointer_type_expected,left.resulttype^.typename);

         if (left.location.loc<>LOC_REFERENCE) {and
            (left.location.loc<>LOC_CREGISTER)} then
           CGMessage(cg_e_illegal_expression);

         registers32:=left.registers32;
         registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
         registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
         resulttype:=voiddef;
         procinfo^.flags:=procinfo^.flags or pi_do_call;
      end;


{*****************************************************************************
                             TADDRNODE
*****************************************************************************}

    constructor taddrnode.create(l : tnode);

      begin
         inherited create(addrn,l);
      end;

    function taddrnode.pass_1 : tnode;
      var
         hp  : tnode;
         hp2 : pparaitem;
         hp3 : pabstractprocdef;
      begin
         pass_1:=nil;
         make_not_regable(left);
         if not(assigned(resulttype)) then
           begin
              { tp @procvar support (type of @procvar is a void pointer)
                Note: we need to leave the addrn in the tree,
                else we can't see the difference between @procvar and procvar.
                we set the procvarload flag so a secondpass does nothing for
                this node (PFV) }
              if (m_tp_procvar in aktmodeswitches) then
               begin
                 hp:=left;
                 case hp.treetype of
                   calln :
                     begin
                       { is it a procvar? }
                       hp:=hp.right;
                       if assigned(hp) then
                         begin
                           { remove calln node }
                           putnode(left);
                           left:=hp;
                           firstpass(hp);
                           procvarload:=true;
                         end;
                     end;
                   loadn,
                   subscriptn,
                   typeconvn,
                   vecn,
                   derefn :
                     begin
                       firstpass(hp);
                       if codegenerror then
                        exit;
                       if hp.resulttype^.deftype=procvardef then
                        begin
                          procvarload:=true;
                        end;
                     end;
                 end;
               end;
              if procvarload then
               begin
                 registers32:=left.registers32;
                 registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
                 registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
                 if registers32<1 then
                   registers32:=1;
                 location.loc:=left.location.loc;
                 resulttype:=voidpointerdef;
                 exit;
               end;

              { proc 2 procvar ? }
              if left.treetype=calln then
                begin
                  { generate a methodcallnode or proccallnode }
                  { we shouldn't convert things like @tcollection.load }
                  if (left.symtableprocentry^.owner^.symtabletype=objectsymtable) and
                    not(assigned(left.methodpointer) and (left.methodpointer^.treetype=typen)) then
                   begin
                     hp:=genloadmethodcallnode(pprocsym(left.symtableprocentry),left.symtableproc,
                       getcopy(left.methodpointer));
                     disposetree(p);
                     firstpass(hp);
                     p:=hp;
                     exit;
                   end
                  else
                   hp:=genloadcallnode(pprocsym(left.symtableprocentry),left.symtableproc);

                  { result is a procedure variable }
                  { No, to be TP compatible, you must return a pointer to
                    the procedure that is stored in the procvar.}
                  if not(m_tp_procvar in aktmodeswitches) then
                    begin
                       resulttype:=new(pprocvardef,init);

                    { it could also be a procvar, not only pprocsym ! }
                       if left.symtableprocentry^.typ=varsym then
                        hp3:=pabstractprocdef(pvarsym(left.symtableentry)^.vartype.def)
                       else
                        hp3:=pabstractprocdef(pprocsym(left.symtableprocentry)^.definition);

                       pprocvardef(resulttype)^.proctypeoption:=hp3^.proctypeoption;
                       pprocvardef(resulttype)^.proccalloptions:=hp3^.proccalloptions;
                       pprocvardef(resulttype)^.procoptions:=hp3^.procoptions;
                       pprocvardef(resulttype)^.rettype:=hp3^.rettype;
                       pprocvardef(resulttype)^.symtablelevel:=hp3^.symtablelevel;

                     { method ? then set the methodpointer flag }
                       if (hp3^.owner^.symtabletype=objectsymtable) and
                          (pobjectdef(hp3^.owner^.defowner)^.is_class) then
                         include(pprocvardef(resulttype)^.procoptions,po_methodpointer);
                       { we need to process the parameters reverse so they are inserted
                         in the correct right2left order (PFV) }
                       hp2^.:=pparaitem(hp3^.para^.last);
                       while assigned(hp2^.) do
                         begin
                            pprocvardef(resulttype)^.concatpara(hp2^.paratype,hp2^.paratyp,hp2^.defaultvalue);
                            hp2^.:=pparaitem(hp2^.previous);
                         end;
                    end
                  else
                    resulttype:=voidpointerdef;

                  disposetree(left);
                  left:=hp;
                end
              else
                begin
                  firstpass(left);
                  { what are we getting the address from an absolute sym? }
                  hp:=left;
                  while assigned(hp) and (hp.treetype in [vecn,derefn,subscriptn]) do
                   hp:=hp.left;
                  if assigned(hp) and (hp.treetype=loadn) and
                     ((hp.symtableentry^.typ=absolutesym) and
                      pabsolutesym(hp.symtableentry)^.absseg) then
                   begin
                     if not(cs_typed_addresses in aktlocalswitches) then
                       resulttype:=voidfarpointerdef
                     else
                       resulttype:=new(ppointerdef,initfardef(left.resulttype));
                   end
                  else
                   begin
                     if not(cs_typed_addresses in aktlocalswitches) then
                       resulttype:=voidpointerdef
                     else
                       resulttype:=new(ppointerdef,initdef(left.resulttype));
                   end;
                end;
           end;
         firstpass(left);
         { this is like the function addr }
         inc(parsing_para_level);
         set_varstate(left,false);
         dec(parsing_para_level);
         if codegenerror then
           exit;

         { don't allow constants }
         if is_constnode(left) then
          begin
            aktfilepos:=left.fileinfo;
            CGMessage(type_e_no_addr_of_constant);
          end
         else
           begin
             { we should allow loc_mem for @string }
             if not(left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
               begin
                 aktfilepos:=left.fileinfo;
                 CGMessage(cg_e_illegal_expression);
               end;
           end;

         registers32:=left.registers32;
         registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
         registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
         if registers32<1 then
           registers32:=1;
         { is this right for object of methods ?? }
         location.loc:=LOC_REGISTER;
      end;


{*****************************************************************************
                           TDOUBLEADDRNODE
*****************************************************************************}

    constructor tdoubleaddrnode.create(l : tnode);

      begin
         inherited create(doubleaddrn,l);
      end;

    function tdoubleaddrnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         make_not_regable(left);
         firstpass(left);
         inc(parsing_para_level);
         set_varstate(left,false);
         dec(parsing_para_level);
         if resulttype=nil then
           resulttype:=voidpointerdef;
         if codegenerror then
           exit;

         if (left.resulttype^.deftype)<>procvardef then
           CGMessage(cg_e_illegal_expression);

         if (left.location.loc<>LOC_REFERENCE) then
           CGMessage(cg_e_illegal_expression);

         registers32:=left.registers32;
         registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
         registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
         if registers32<1 then
           registers32:=1;
         location.loc:=LOC_REGISTER;
      end;


{*****************************************************************************
                             TDEREFNODE
*****************************************************************************}

    constructor tderefnode.create(l : tnode);

      begin
         inherited create(derefn,l);
      end;

    function tderefnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         firstpass(left);
         set_varstate(left,true);
         if codegenerror then
           begin
             resulttype:=generrordef;
             exit;
           end;

         registers32:=max(left.registers32,1);
         registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
         registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}

         if left.resulttype^.deftype<>pointerdef then
          CGMessage(cg_e_invalid_qualifier);

         resulttype:=ppointerdef(left.resulttype)^.pointertype.def;
         location.loc:=LOC_REFERENCE;
      end;


{*****************************************************************************
                            TSUBSCRIPTNODE
*****************************************************************************}

    constructor tsubscriptnode.create(varsym : pvarsym;l : tnode);

      begin
         inherited create(subscriptn,l);
         vs:=varsym;
      end;

    function tsubscriptnode.getcopy : tnode;

      var
         p : tsubscriptnode;

      begin
         p:=tsubscriptnode(inherited getcopy);
         p.vs:=vs;
         getcopy:=p;
      end;

    function tsubscriptnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         firstpass(left);
         if codegenerror then
           begin
             resulttype:=generrordef;
             exit;
           end;
         resulttype:=vs^.vartype.def;

         registers32:=left.registers32;
         registersfpu:=left.registersfpu;
{$ifdef SUPPORT_MMX}
         registersmmx:=left.registersmmx;
{$endif SUPPORT_MMX}
         { classes must be dereferenced implicit }
         if (left.resulttype^.deftype=objectdef) and
           pobjectdef(left.resulttype)^.is_class then
           begin
              if registers32=0 then
                registers32:=1;
              location.loc:=LOC_REFERENCE;
           end
         else
           begin
              if (left.location.loc<>LOC_MEM) and
                (left.location.loc<>LOC_REFERENCE) then
                CGMessage(cg_e_illegal_expression);
              set_location(location,left.location);
           end;
      end;


{*****************************************************************************
                               TVECNODE
*****************************************************************************}

    constructor tvecnode.create(l,r : tnode);

      begin
         inherited create(vecn,l,r);
      end;

    function tvecnode.pass_1 : tnode;
      var
         harr : pdef;
         ct : tconverttype;
{$ifdef consteval}
         tcsym : ptypedconstsym;
{$endif}
      begin
         pass_1:=nil;
         firstpass(left);
         firstpass(right);
         if codegenerror then
           exit;

         { range check only for arrays }
         if (left.resulttype^.deftype=arraydef) then
           begin
              if (isconvertable(right.resulttype,parraydef(left.resulttype)^.rangetype.def,
                    ct,ordconstn,false)=0) and
                 not(is_equal(right.resulttype,parraydef(left.resulttype)^.rangetype.def)) then
                CGMessage(type_e_mismatch);
           end;
         { Never convert a boolean or a char !}
         { maybe type conversion }
         if (right.resulttype^.deftype<>enumdef) and
            not(is_char(right.resulttype)) and
            not(is_boolean(right.resulttype)) then
           begin
             right:=gentypeconvnode(right,s32bitdef);
             firstpass(right);
             if codegenerror then
              exit;
           end;

         { are we accessing a pointer[], then convert the pointer to
           an array first, in FPC this is allowed for all pointers in
           delphi/tp7 it's only allowed for pchars }
         if (left.resulttype^.deftype=pointerdef) and
            ((m_fpc in aktmodeswitches) or
             is_pchar(left.resulttype)) then
          begin
            { convert pointer to array }
            harr:=new(parraydef,init(0,$7fffffff,s32bitdef));
            parraydef(harr)^.elementtype.def:=ppointerdef(left.resulttype)^.pointertype.def;
            left:=gentypeconvnode(left,harr);
            firstpass(left);
            if codegenerror then
             exit;
            resulttype:=parraydef(harr)^.elementtype.def
          end;

         { determine return type }
         if not assigned(resulttype) then
           if left.resulttype^.deftype=arraydef then
             resulttype:=parraydef(left.resulttype)^.elementtype.def
           else if left.resulttype^.deftype=stringdef then
             begin
                { indexed access to strings }
                case pstringdef(left.resulttype)^.string_typ of
                   {
                   st_widestring : resulttype:=cwchardef;
                   }
                   st_ansistring : resulttype:=cchardef;
                   st_longstring : resulttype:=cchardef;
                   st_shortstring : resulttype:=cchardef;
                end;
             end
           else
             CGMessage(type_e_array_required);

         { the register calculation is easy if a const index is used }
         if right.treetype=ordconstn then
           begin
{$ifdef consteval}
              { constant evaluation }
              if (left.treetype=loadn) and
                 (left.symtableentry^.typ=typedconstsym) then
               begin
                 tcsym:=ptypedconstsym(left.symtableentry);
                 if tcsym^.defintion^.typ=stringdef then
                  begin

                  end;
               end;
{$endif}
              registers32:=left.registers32;

              { for ansi/wide strings, we need at least one register }
              if is_ansistring(left.resulttype) or
                is_widestring(left.resulttype) then
                registers32:=max(registers32,1);
           end
         else
           begin
              { this rules are suboptimal, but they should give }
              { good results                                }
              registers32:=max(left.registers32,right.registers32);

              { for ansi/wide strings, we need at least one register }
              if is_ansistring(left.resulttype) or
                is_widestring(left.resulttype) then
                registers32:=max(registers32,1);

              { need we an extra register when doing the restore ? }
              if (left.registers32<=right.registers32) and
              { only if the node needs less than 3 registers }
              { two for the right node and one for the       }
              { left address                             }
                (registers32<3) then
                inc(registers32);

              { need we an extra register for the index ? }
              if (right.location.loc<>LOC_REGISTER)
              { only if the right node doesn't need a register }
                and (right.registers32<1) then
                inc(registers32);

              { not correct, but what works better ?
              if left.registers32>0 then
                registers32:=max(registers32,2)
              else
                 min. one register
                registers32:=max(registers32,1);
              }
           end;
         registersfpu:=max(left.registersfpu,right.registersfpu);
{$ifdef SUPPORT_MMX}
         registersmmx:=max(left.registersmmx,right.registersmmx);
{$endif SUPPORT_MMX}
         if left.location.loc in [LOC_CREGISTER,LOC_REFERENCE] then
           location.loc:=LOC_REFERENCE
         else
           location.loc:=LOC_MEM;
      end;


{*****************************************************************************
                               TSELFNODE
*****************************************************************************}

    constructor tselfnode.create(_class : pdef);

      begin
         inherited create(selfn);
         resulttype:=_class;
      end;

    function tselfnode.pass_1 : tnode;
      begin
         pass_1:=nil;
         if (resulttype^.deftype=classrefdef) or
           ((resulttype^.deftype=objectdef)
             and pobjectdef(resulttype)^.is_class
           ) then
           location.loc:=LOC_CREGISTER
         else
           location.loc:=LOC_REFERENCE;
      end;


{*****************************************************************************
                               TWITHNODE
*****************************************************************************}

    constructor twithnode.create(symtable : pwithsymtable;l,r : tnode;count : longint);

      begin
         inherited create(withn,l,r);
         withsymtable:=symtable;
         tablecount:=count;
         withreference:=nil;
         set_file_line(l);
      end;

    function twithnode.getcopy : tnode;

      var
         p : twithnode;

      begin
         p:=twithnode(inherited getcopy);
         p.withsymtable:=withsymtable;
         p.tablecount:=count;
         p.withreference:=withreference;
      end;

    function twithnode.pass_1 : tnode;
      var
         symtable : pwithsymtable;
         i : longint;
      begin
         pass_1:=nil;
         if assigned(left) and assigned(right) then
            begin
               firstpass(left);
               left.unset_varstate;
               left.set_varstate(true);
               if codegenerror then
                 exit;
               symtable:=withsymtable;
               for i:=1 to tablecount do
                 begin
                    if (left.treetype=loadn) and
                       (left.symtable=aktprocsym^.definition^.localst) then
                      symtable^.direct_with:=true;
                    symtable^.withnode:=p;
                    symtable:=pwithsymtable(symtable^.next);
                  end;
               firstpass(right);
               if codegenerror then
                 exit;

               left_right_max(p);
               resulttype:=voiddef;
            end
         else
           begin
              { optimization }
              disposetree(p);
              p:=nil;
           end;
      end;


end.
{
  $Log$
  Revision 1.1  2000-09-25 09:58:22  florian
    * first revision for testing purpose

}