freepascal.compiler/compiler/nutils.pas

{
    Copyright (c) 1998-2002 by Florian Klaempfl

    Type checking and register allocation for inline 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 nutils;

{$i fpcdefs.inc}

interface

  uses
    globals,
    symsym,node;

  const
    NODE_COMPLEXITY_INF = 255;

  type
    { resulttype of functions that process on all nodes in a (sub)tree }
    foreachnoderesult = (
      { false, continue recursion }
      fen_false,
      { false, stop recursion }
      fen_norecurse_false,
      { true, continue recursion }
      fen_true,
      { true, stop recursion }
      fen_norecurse_true
    );


    foreachnodefunction = function(var n: tnode; arg: pointer): foreachnoderesult of object;
    staticforeachnodefunction = function(var n: tnode; arg: pointer): foreachnoderesult;

    function foreachnode(var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
    function foreachnodestatic(var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;

    procedure load_procvar_from_calln(var p1:tnode);
    function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
    function load_high_value_node(vs:tparavarsym):tnode;
    function load_self_node:tnode;
    function load_result_node:tnode;
    function load_self_pointer_node:tnode;
    function load_vmt_pointer_node:tnode;
    function is_self_node(p:tnode):boolean;

    function call_fail_node:tnode;
    function initialize_data_node(p:tnode):tnode;
    function finalize_data_node(p:tnode):tnode;

    function node_complexity(p: tnode): cardinal;
    procedure node_tree_set_filepos(var n:tnode;const filepos:tfileposinfo);


implementation

    uses
      globtype,verbose,
      symconst,symbase,symtype,symdef,symtable,
      defutil,defcmp,
      nbas,ncon,ncnv,nld,nflw,nset,ncal,nadd,nmem,
      cgbase,procinfo,
      pass_1;

  function foreachnode(var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
    var
      i: longint;
    begin
      result := false;
      if not assigned(n) then
        exit;
      case f(n,arg) of
        fen_norecurse_false:
          exit;
        fen_norecurse_true:
          begin
            result := true;
            exit;
          end;
        fen_true:
          result := true;
       { result is already false
        fen_false:
          result := false; }
      end;
      case n.nodetype of
        calln:
          begin
            { not in one statement, won't work because of b- }
            result := foreachnode(tcallnode(n).methodpointer,f,arg) or result;
{$ifdef PASS2INLINE}
            result := foreachnode(tcallnode(n).inlinecode,f,arg) or result;
{$endif PASS2INLINE}
          end;
        ifn, whilerepeatn, forn:
          begin
            { not in one statement, won't work because of b- }
            result := foreachnode(tloopnode(n).t1,f,arg) or result;
            result := foreachnode(tloopnode(n).t2,f,arg) or result;
          end;
        raisen:
          result := foreachnode(traisenode(n).frametree,f,arg) or result;
        casen:
          begin
            for i := 0 to tcasenode(n).blocks.count-1 do
              if assigned(tcasenode(n).blocks[i]) then
                result := foreachnode(pcaseblock(tcasenode(n).blocks[i])^.statement,f,arg) or result;
            result := foreachnode(tcasenode(n).elseblock,f,arg) or result;
          end;
      end;
      if n.inheritsfrom(tbinarynode) then
        begin
          result := foreachnode(tbinarynode(n).right,f,arg) or result;
          result := foreachnode(tbinarynode(n).left,f,arg) or result;
        end
      else if n.inheritsfrom(tunarynode) then
        result := foreachnode(tunarynode(n).left,f,arg) or result;
    end;


  function foreachnodestatic(var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;
    var
      i: longint;
    begin
      result := false;
      if not assigned(n) then
        exit;
      case f(n,arg) of
        fen_norecurse_false:
          exit;
        fen_norecurse_true:
          begin
            result := true;
            exit;
          end;
        fen_true:
          result := true;
       { result is already false
        fen_false:
          result := false; }
      end;
      case n.nodetype of
        calln:
          begin
            result := foreachnodestatic(tcallnode(n).methodpointer,f,arg) or result;
{$ifdef PASS2INLINE}
            result := foreachnodestatic(tcallnode(n).inlinecode,f,arg) or result;
{$endif PASS2INLINE}
          end;
        ifn, whilerepeatn, forn:
          begin
            { not in one statement, won't work because of b- }
            result := foreachnodestatic(tloopnode(n).t1,f,arg) or result;
            result := foreachnodestatic(tloopnode(n).t2,f,arg) or result;
          end;
        raisen:
          result := foreachnodestatic(traisenode(n).frametree,f,arg) or result;
        casen:
          begin
            for i := 0 to tcasenode(n).blocks.count-1 do
              if assigned(tcasenode(n).blocks[i]) then
                result := foreachnodestatic(pcaseblock(tcasenode(n).blocks[i])^.statement,f,arg) or result;
            result := foreachnodestatic(tcasenode(n).elseblock,f,arg) or result;
          end;
      end;
      if n.inheritsfrom(tbinarynode) then
        begin
          result := foreachnodestatic(tbinarynode(n).right,f,arg) or result;
          result := foreachnodestatic(tbinarynode(n).left,f,arg) or result;
        end
      else if n.inheritsfrom(tunarynode) then
        result := foreachnodestatic(tunarynode(n).left,f,arg) or result;
    end;


    procedure load_procvar_from_calln(var p1:tnode);
      var
        p2 : tnode;
      begin
        if p1.nodetype<>calln then
          internalerror(200212251);
        { was it a procvar, then we simply remove the calln and
          reuse the right }
        if assigned(tcallnode(p1).right) then
          begin
            p2:=tcallnode(p1).right;
            tcallnode(p1).right:=nil;
          end
        else
          begin
            p2:=cloadnode.create_procvar(tcallnode(p1).symtableprocentry,
               tprocdef(tcallnode(p1).procdefinition),tcallnode(p1).symtableproc);
            { when the methodpointer is typen we've something like:
              tobject.create. Then only the address is needed of the
              method without a self pointer }
            if assigned(tcallnode(p1).methodpointer) and
               (tcallnode(p1).methodpointer.nodetype<>typen) then
              tloadnode(p2).set_mp(tcallnode(p1).get_load_methodpointer);
          end;
        resulttypepass(p2);
        p1.free;
        p1:=p2;
      end;


    function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
      var
        hp : tnode;
      begin
        result:=false;
        if (p1.resulttype.def.deftype<>procvardef) or
           (tponly and
            not(m_tp_procvar in aktmodeswitches)) then
          exit;
        { ignore vecn,subscriptn }
        hp:=p1;
        repeat
          case hp.nodetype of
            vecn,
            derefn,
            typeconvn,
            subscriptn :
              hp:=tunarynode(hp).left;
            else
              break;
          end;
        until false;
        { a tempref is used when it is loaded from a withsymtable }
        if (hp.nodetype in [loadn,temprefn]) then
          begin
            hp:=ccallnode.create_procvar(nil,p1);
            resulttypepass(hp);
            p1:=hp;
            result:=true;
          end;
      end;


    function load_high_value_node(vs:tparavarsym):tnode;
      var
        srsym : tsym;
        srsymtable : tsymtable;
      begin
        result:=nil;
        srsymtable:=vs.owner;
        srsym:=searchsymonlyin(srsymtable,'high'+vs.name);
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,srsymtable);
            resulttypepass(result);
          end
        else
          CGMessage(parser_e_illegal_expression);
      end;


    function load_self_node:tnode;
      var
        srsym : tsym;
        srsymtable : tsymtable;
      begin
        result:=nil;
        searchsym('self',srsym,srsymtable);
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,srsymtable);
            include(result.flags,nf_is_self);
            resulttypepass(result);
          end
        else
          CGMessage(parser_e_illegal_expression);
      end;


    function load_result_node:tnode;
      var
        srsym : tsym;
        srsymtable : tsymtable;
      begin
        result:=nil;
        searchsym('result',srsym,srsymtable);
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,srsymtable);
            resulttypepass(result);
          end
        else
          CGMessage(parser_e_illegal_expression);
      end;


    function load_self_pointer_node:tnode;
      var
        srsym : tsym;
        srsymtable : tsymtable;
      begin
        result:=nil;
        searchsym('self',srsym,srsymtable);
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,srsymtable);
            include(result.flags,nf_load_self_pointer);
            resulttypepass(result);
          end
        else
          CGMessage(parser_e_illegal_expression);
      end;


    function load_vmt_pointer_node:tnode;
      var
        srsym : tsym;
        srsymtable : tsymtable;
      begin
        result:=nil;
        searchsym('vmt',srsym,srsymtable);
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,srsymtable);
            resulttypepass(result);
          end
        else
          CGMessage(parser_e_illegal_expression);
      end;


    function is_self_node(p:tnode):boolean;
      begin
        is_self_node:=(p.nodetype=loadn) and
                      (tloadnode(p).symtableentry.typ=paravarsym) and
                      (vo_is_self in tparavarsym(tloadnode(p).symtableentry).varoptions);
      end;



    function call_fail_node:tnode;
      var
        para : tcallparanode;
        newstatement : tstatementnode;
        srsym : tsym;
      begin
        result:=internalstatements(newstatement);

        { call fail helper and exit normal }
        if is_class(current_procinfo.procdef._class) then
          begin
            srsym:=search_class_member(current_procinfo.procdef._class,'FREEINSTANCE');
            if assigned(srsym) and
               (srsym.typ=procsym) then
              begin
                { if self<>0 and vmt=1 then freeinstance }
                addstatement(newstatement,cifnode.create(
                    caddnode.create(andn,
                        caddnode.create(unequaln,
                            load_self_pointer_node,
                            cnilnode.create),
                        caddnode.create(equaln,
                            ctypeconvnode.create(
                                load_vmt_pointer_node,
                                voidpointertype),
                            cpointerconstnode.create(1,voidpointertype))),
                    ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
                    nil));
              end
            else
              internalerror(200305108);
          end
        else
          if is_object(current_procinfo.procdef._class) then
            begin
              { parameter 3 : vmt_offset }
              { parameter 2 : pointer to vmt }
              { parameter 1 : self pointer }
              para:=ccallparanode.create(
                        cordconstnode.create(current_procinfo.procdef._class.vmt_offset,s32inttype,false),
                    ccallparanode.create(
                        ctypeconvnode.create_internal(
                            load_vmt_pointer_node,
                            voidpointertype),
                    ccallparanode.create(
                        ctypeconvnode.create_internal(
                            load_self_pointer_node,
                            voidpointertype),
                    nil)));
              addstatement(newstatement,
                  ccallnode.createintern('fpc_help_fail',para));
            end
        else
          internalerror(200305132);
        { self:=nil }
        addstatement(newstatement,cassignmentnode.create(
            load_self_pointer_node,
            cnilnode.create));
        { exit }
        addstatement(newstatement,cexitnode.create(nil));
      end;


    function initialize_data_node(p:tnode):tnode;
      begin
        if not assigned(p.resulttype.def) then
          resulttypepass(p);
        if is_ansistring(p.resulttype.def) or
           is_widestring(p.resulttype.def) or
           is_interfacecom(p.resulttype.def) or
           is_dynamic_array(p.resulttype.def) then
          begin
            result:=cassignmentnode.create(
               ctypeconvnode.create_internal(p,voidpointertype),
               cnilnode.create
               );
          end
        else
          begin
            result:=ccallnode.createintern('fpc_initialize',
                  ccallparanode.create(
                      caddrnode.create_internal(
                          crttinode.create(
                              tstoreddef(p.resulttype.def),initrtti)),
                  ccallparanode.create(
                      caddrnode.create_internal(p),
                  nil)));
          end;
      end;


    function finalize_data_node(p:tnode):tnode;
      begin
        if not assigned(p.resulttype.def) then
          resulttypepass(p);
        result:=ccallnode.createintern('fpc_finalize',
              ccallparanode.create(
                  caddrnode.create_internal(
                      crttinode.create(
                          tstoreddef(p.resulttype.def),initrtti)),
              ccallparanode.create(
                  caddrnode.create_internal(p),
              nil)));
      end;


    { this function must return a very high value ("infinity") for   }
    { trees containing a call, the rest can be balanced more or less }
    { at will, probably best mainly in terms of required memory      }
    { accesses                                                       }
    function node_complexity(p: tnode): cardinal;
      begin
        result := 0;
        while true do
          begin
            case p.nodetype of
              temprefn,
              loadvmtaddrn,
              { main reason for the next one: we can't take the address of }
              { loadparentfpnode, so replacing it by a temp which is the   }
              { address of this node's location and then dereferencing     }
              { doesn't work. If changed, check whether webtbs/tw0935      }
              { still works with nodeinlining (JM)                         }
              loadparentfpn:
                begin
                  result := 1;
                  exit;
                end;
              loadn:
                begin
                  { threadvars need a helper call }
                  if (tloadnode(p).symtableentry.typ=globalvarsym) and
                     (vo_is_thread_var in tglobalvarsym(tloadnode(p).symtableentry).varoptions) then
                    inc(result,5)
                  else
                    inc(result);
                  if (result >= NODE_COMPLEXITY_INF) then
                    result := NODE_COMPLEXITY_INF;
                  exit;
                end;
              subscriptn,
              blockn:
                p := tunarynode(p).left;
              derefn :
                begin
                  inc(result);
                  if (result = NODE_COMPLEXITY_INF) then
                    exit;
                  p := tunarynode(p).left;
                end;
              typeconvn:
                begin
                  { may be more complex in some cases }
                  if not(ttypeconvnode(p).convtype in [tc_equal,tc_int_2_int,tc_bool_2_bool,tc_real_2_real,tc_cord_2_pointer]) then
                    inc(result);
                  if (result = NODE_COMPLEXITY_INF) then
                    exit;
                  p := tunarynode(p).left;
                end;
              vecn,
              statementn:
                begin
                  inc(result,node_complexity(tbinarynode(p).left));
                  if (result >= NODE_COMPLEXITY_INF) then
                    begin
                      result := NODE_COMPLEXITY_INF;
                      exit;
                    end;
                  p := tbinarynode(p).right;
                end;
              { better: make muln/divn/modn more expensive }
              addn,subn,orn,andn,xorn,muln,divn,modn,symdifn,
              assignn:
                begin
                  inc(result,node_complexity(tbinarynode(p).left)+1);
                  if (result >= NODE_COMPLEXITY_INF) then
                    begin
                      result := NODE_COMPLEXITY_INF;
                      exit;
                    end;
                  p := tbinarynode(p).right;
                end;
              tempcreaten,
              tempdeleten,
              ordconstn,
              pointerconstn:
                exit;
              else
                begin
                  result := NODE_COMPLEXITY_INF;
                  exit;
                end;
            end;
        end;
      end;


    function setnodefilepos(var n: tnode; arg: pointer): foreachnoderesult;
      begin
        result:=fen_true;
        n.fileinfo:=pfileposinfo(arg)^;
      end;


    procedure node_tree_set_filepos(var n:tnode;const filepos:tfileposinfo);
      begin
        foreachnodestatic(n,@setnodefilepos,@filepos);
      end;

end.