fpc/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
    globtype,
    symtype,symsym,symbase,symtable,
    node;

  const
    NODE_COMPLEXITY_INF = 255;

  type
    { resultdef 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
    );

    tforeachprocmethod = (pm_preprocess,pm_postprocess,
                          pm_postandagain);

    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 foreachnode(procmethod : tforeachprocmethod; var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
    function foreachnodestatic(var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;
    function foreachnodestatic(procmethod : tforeachprocmethod; var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;

    { checks if the given node tree contains only nodes of the given type,
      if this isn't the case, an ie is thrown
    }
    procedure checktreenodetypes(n : tnode;typeset : tnodetypeset);

    procedure load_procvar_from_calln(var p1:tnode);
    function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
    function get_high_value_sym(vs: tparavarsym):tsym; { marking it as inline causes IE 200311075 during loading from ppu file }
    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;
    function node_resources_fpu(p: tnode): cardinal;
    procedure node_tree_set_filepos(var n:tnode;const filepos:tfileposinfo);

    { tries to simplify the given node }
    procedure dosimplify(var n : tnode);

    { returns true if n is only a tree of administrative nodes
      containing no code }
    function has_no_code(n : tnode) : boolean;

    function getpropaccesslist(propsym:tpropertysym; pap:tpropaccesslisttypes;out propaccesslist:tpropaccesslist):boolean;
    procedure propaccesslist_to_node(var p1:tnode;st:TSymtable;pl:tpropaccesslist);
    function node_to_propaccesslist(p1:tnode):tpropaccesslist;

    { returns true if n is an array element access of a bitpacked array with
      elements of the which the vitsize mod 8 <> 0, or if is a field access
      with bitsize mod 8 <> 0 or bitoffset mod 8 <> 0 of an element in a
      bitpacked structure }
    function is_bitpacked_access(n: tnode): boolean;

    { creates a load of field 'fieldname' in the record/class/...
      represented by n }
    function genloadfield(n: tnode; const fieldname: string): tnode;


implementation

    uses
      cutils,verbose,constexp,globals,
      symconst,symdef,
      defutil,defcmp,
      nbas,ncon,ncnv,nld,nflw,nset,ncal,nadd,nmem,ninl,
      cpubase,cgbase,procinfo,
      pass_1;

  function foreachnode(procmethod : tforeachprocmethod;var n: tnode; f: foreachnodefunction; arg: pointer): boolean;

    function process_children(res : boolean) : boolean;
      var
        i: longint;
      begin
        result:=res;
        case n.nodetype of
        asn:
          if assigned(tasnode(n).call) then
            begin
              result := foreachnode(procmethod,tasnode(n).call,f,arg);
              exit
            end;
          calln:
            begin
              result := foreachnode(procmethod,tnode(tcallnode(n).callinitblock),f,arg) or result;
              result := foreachnode(procmethod,tcallnode(n).methodpointer,f,arg) or result;
              result := foreachnode(procmethod,tcallnode(n).funcretnode,f,arg) or result;
              result := foreachnode(procmethod,tnode(tcallnode(n).callcleanupblock),f,arg) or result;
            end;
          ifn, whilerepeatn, forn, tryexceptn, tryfinallyn:
            begin
              { not in one statement, won't work because of b- }
              result := foreachnode(procmethod,tloopnode(n).t1,f,arg) or result;
              result := foreachnode(procmethod,tloopnode(n).t2,f,arg) or result;
            end;
          raisen:
            { frame tree }
            result := foreachnode(traisenode(n).third,f,arg) or result;
          tempcreaten:
            { temp. initialization code }
            if assigned(ttempcreatenode(n).tempinfo^.tempinitcode) then
              result := foreachnode(ttempcreatenode(n).tempinfo^.tempinitcode,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(procmethod,pcaseblock(tcasenode(n).blocks[i])^.statement,f,arg) or result;
              result := foreachnode(procmethod,tcasenode(n).elseblock,f,arg) or result;
            end;
        end;
        if n.inheritsfrom(tbinarynode) then
          begin
            { first process the "payload" of statementnodes }
            result := foreachnode(procmethod,tbinarynode(n).left,f,arg) or result;
            result := foreachnode(procmethod,tbinarynode(n).right,f,arg) or result;
          end
        else if n.inheritsfrom(tunarynode) then
          result := foreachnode(procmethod,tunarynode(n).left,f,arg) or result;
      end;

    begin
      result := false;
      if not assigned(n) then
        exit;
      if procmethod=pm_preprocess then
        result:=process_children(result);
      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;
      if (procmethod=pm_postprocess) or (procmethod=pm_postandagain) then
        result:=process_children(result);
      if procmethod=pm_postandagain then
        begin
          case f(n,arg) of
            fen_norecurse_false:
              exit;
            fen_norecurse_true:
              begin
                result := true;
                exit;
              end;
            fen_true:
              result := true;
          end;
        end;
    end;


    function foreachnode(var n: tnode; f: foreachnodefunction; arg: pointer): boolean;
      begin
        result:=foreachnode(pm_postprocess,n,f,arg);
      end;


  function foreachnodestatic(procmethod : tforeachprocmethod;var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;

    function process_children(res : boolean) : boolean;
      var
        i: longint;
      begin
        result:=res;
        case n.nodetype of
        asn:
          if assigned(tasnode(n).call) then
            begin
              result := foreachnodestatic(procmethod,tasnode(n).call,f,arg);
              exit
            end;
          calln:
            begin
              result := foreachnodestatic(procmethod,tnode(tcallnode(n).callinitblock),f,arg) or result;
              result := foreachnodestatic(procmethod,tcallnode(n).methodpointer,f,arg) or result;
              result := foreachnodestatic(procmethod,tcallnode(n).funcretnode,f,arg) or result;
              result := foreachnodestatic(procmethod,tnode(tcallnode(n).callcleanupblock),f,arg) or result;
            end;
          ifn, whilerepeatn, forn, tryexceptn, tryfinallyn:
            begin
              { not in one statement, won't work because of b- }
              result := foreachnodestatic(procmethod,tloopnode(n).t1,f,arg) or result;
              result := foreachnodestatic(procmethod,tloopnode(n).t2,f,arg) or result;
            end;
          raisen:
            { frame tree }
            result := foreachnodestatic(traisenode(n).third,f,arg) or result;
          tempcreaten:
            { temp. initialization code }
            if assigned(ttempcreatenode(n).tempinfo^.tempinitcode) then
              result := foreachnodestatic(ttempcreatenode(n).tempinfo^.tempinitcode,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(procmethod,pcaseblock(tcasenode(n).blocks[i])^.statement,f,arg) or result;
              result := foreachnodestatic(procmethod,tcasenode(n).elseblock,f,arg) or result;
            end;
        end;
        if n.inheritsfrom(tbinarynode) then
          begin
            { first process the "payload" of statementnodes }
            result := foreachnodestatic(procmethod,tbinarynode(n).left,f,arg) or result;
            result := foreachnodestatic(procmethod,tbinarynode(n).right,f,arg) or result;
          end
        else if n.inheritsfrom(tunarynode) then
          result := foreachnodestatic(procmethod,tunarynode(n).left,f,arg) or result;
      end;

    begin
      result := false;
      if not assigned(n) then
        exit;
      if procmethod=pm_preprocess then
        result:=process_children(result);
      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;
      if (procmethod=pm_postprocess) or (procmethod=pm_postandagain) then
        result:=process_children(result);
      if procmethod=pm_postandagain then
        begin
          case f(n,arg) of
            fen_norecurse_false:
              exit;
            fen_norecurse_true:
              begin
                result := true;
                exit;
              end;
            fen_true:
              result := true;
          end;
        end;
    end;


    function foreachnodestatic(var n: tnode; f: staticforeachnodefunction; arg: pointer): boolean;
      begin
        result:=foreachnodestatic(pm_postprocess,n,f,arg);
      end;


    function do_check(var n: tnode; arg: pointer): foreachnoderesult;
      begin
        if not(n.nodetype in pnodetypeset(arg)^) then
          internalerror(200610141);
        result:=fen_true;
      end;


    procedure checktreenodetypes(n : tnode;typeset : tnodetypeset);
      begin
        foreachnodestatic(n,@do_check,@typeset);
      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).methodpointer.getcopy);
          end;
        typecheckpass(p2);
        p1.free;
        p1:=p2;
      end;


    function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
      var
        hp : tnode;
      begin
        result:=false;
        if (p1.resultdef.typ<>procvardef) or
           (tponly and
            ([m_tp_procvar,m_mac_procvar] * current_settings.modeswitches = [])) 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 [calln,loadn,temprefn]) then
          begin
            hp:=ccallnode.create_procvar(nil,p1);
            typecheckpass(hp);
            p1:=hp;
            result:=true;
          end;
      end;


    function get_high_value_sym(vs: tparavarsym):tsym;
      begin
        result := tsym(vs.owner.Find('high'+vs.name));
      end;


    function get_local_or_para_sym(const aname:string):tsym;
      var
        pd : tprocdef;
      begin
        result:=nil;
        { is not assigned while parsing a property }
        if not assigned(current_procinfo) then
          exit;
        { we can't use searchsym here, because the
          symtablestack is not fully setup when pass1
          is run for nested procedures }
        pd:=current_procinfo.procdef;
        repeat
          result := tsym(pd.localst.Find(aname));
          if assigned(result) then
            break;
          result := tsym(pd.parast.Find(aname));
          if assigned(result) then
            break;
          { try the parent of a nested function }
          if assigned(pd.owner.defowner) and
             (pd.owner.defowner.typ=procdef) then
            pd:=tprocdef(pd.owner.defowner)
          else
            break;
        until false;
      end;


    function load_high_value_node(vs:tparavarsym):tnode;
      var
        srsym : tsym;
      begin
        result:=nil;
        srsym:=get_high_value_sym(vs);
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,vs.owner);
            typecheckpass(result);
          end
        else
          CGMessage(parser_e_illegal_expression);
      end;


    function load_self_node:tnode;
      var
        srsym : tsym;
      begin
        result:=nil;

        srsym:=get_local_or_para_sym('self');
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,srsym.owner);
            include(result.flags,nf_is_self);
          end
        else
          begin
            result:=cerrornode.create;
            CGMessage(parser_e_illegal_expression);
          end;
        typecheckpass(result);
      end;


    function load_result_node:tnode;
      var
        srsym : tsym;
      begin
        result:=nil;
        srsym:=get_local_or_para_sym('result');
        if assigned(srsym) then
          result:=cloadnode.create(srsym,srsym.owner)
        else
          begin
            result:=cerrornode.create;
            CGMessage(parser_e_illegal_expression);
          end;
        typecheckpass(result);
      end;


    function load_self_pointer_node:tnode;
      var
        srsym : tsym;
      begin
        result:=nil;
        srsym:=get_local_or_para_sym('self');
        if assigned(srsym) then
          begin
            result:=cloadnode.create(srsym,srsym.owner);
            include(result.flags,nf_load_self_pointer);
          end
        else
          begin
            result:=cerrornode.create;
            CGMessage(parser_e_illegal_expression);
          end;
        typecheckpass(result);
      end;


    function load_vmt_pointer_node:tnode;
      var
        srsym : tsym;
      begin
        result:=nil;
        srsym:=get_local_or_para_sym('vmt');
        if assigned(srsym) then
          result:=cloadnode.create(srsym,srsym.owner)
        else
          begin
            result:=cerrornode.create;
            CGMessage(parser_e_illegal_expression);
          end;
        typecheckpass(result);
      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_objectdef) then
          begin
            srsym:=search_class_member(current_objectdef,'FREEINSTANCE');
            if assigned(srsym) and
               (srsym.typ=procsym) then
              begin
                { if self<>0 and vmt<>0 then freeinstance }
                addstatement(newstatement,cifnode.create(
                    caddnode.create(andn,
                        caddnode.create(unequaln,
                            load_self_pointer_node,
                            cnilnode.create),
                        caddnode.create(unequaln,
                            load_vmt_pointer_node,
                            cnilnode.create)),
                    ccallnode.create(nil,tprocsym(srsym),srsym.owner,load_self_node,[]),
                    nil));
              end
            else
              internalerror(200305108);
          end
        else
          if is_object(current_objectdef) then
            begin
              { parameter 3 : vmt_offset }
              { parameter 2 : pointer to vmt }
              { parameter 1 : self pointer }
              para:=ccallparanode.create(
                        cordconstnode.create(current_objectdef.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.resultdef) then
          typecheckpass(p);
        if is_ansistring(p.resultdef) or
           is_wide_or_unicode_string(p.resultdef) or
           is_interfacecom(p.resultdef) or
           is_dynamic_array(p.resultdef) 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.resultdef),initrtti,rdt_normal)),
                  ccallparanode.create(
                      caddrnode.create_internal(p),
                  nil)));
          end;
      end;


    function finalize_data_node(p:tnode):tnode;
      var
        newstatement : tstatementnode;
      begin
        if not assigned(p.resultdef) then
          typecheckpass(p);
        if is_ansistring(p.resultdef) then
          begin
            result:=internalstatements(newstatement);
            addstatement(newstatement,ccallnode.createintern('fpc_ansistr_decr_ref',
                  ccallparanode.create(
                    ctypeconvnode.create_internal(p,voidpointertype),
                  nil)));
            addstatement(newstatement,cassignmentnode.create(
               ctypeconvnode.create_internal(p.getcopy,voidpointertype),
               cnilnode.create
               ));
          end
        else if is_widestring(p.resultdef) then
          begin
            result:=internalstatements(newstatement);
            addstatement(newstatement,ccallnode.createintern('fpc_widestr_decr_ref',
                  ccallparanode.create(
                    ctypeconvnode.create_internal(p,voidpointertype),
                  nil)));
            addstatement(newstatement,cassignmentnode.create(
               ctypeconvnode.create_internal(p.getcopy,voidpointertype),
               cnilnode.create
               ));
          end
        else if is_unicodestring(p.resultdef) then
          begin
            result:=internalstatements(newstatement);
            addstatement(newstatement,ccallnode.createintern('fpc_unicodestr_decr_ref',
                  ccallparanode.create(
                    ctypeconvnode.create_internal(p,voidpointertype),
                  nil)));
            addstatement(newstatement,cassignmentnode.create(
               ctypeconvnode.create_internal(p.getcopy,voidpointertype),
               cnilnode.create
               ));
          end
        else if is_interfacecom(p.resultdef) then
          begin
            result:=internalstatements(newstatement);
            addstatement(newstatement,ccallnode.createintern('fpc_intf_decr_ref',
                  ccallparanode.create(
                    ctypeconvnode.create_internal(p,voidpointertype),
                  nil)));
            addstatement(newstatement,cassignmentnode.create(
               ctypeconvnode.create_internal(p.getcopy,voidpointertype),
               cnilnode.create
               ));
          end
        else
          result:=ccallnode.createintern('fpc_finalize',
                ccallparanode.create(
                    caddrnode.create_internal(
                        crttinode.create(
                            tstoreddef(p.resultdef),initrtti,rdt_normal)),
                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;
      var
        correction: byte;
{$ifdef ARM}
        dummy : byte;
{$endif ARM}
      begin
        result := 0;
        while assigned(p) do
          begin
            case p.nodetype of
              { floating point constants usually need loading from memory }
              realconstn,
              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=staticvarsym) and
                     (vo_is_thread_var in tstaticvarsym(tloadnode(p).symtableentry).varoptions) then
                    inc(result,5)
                  else
                    inc(result);
                  if (result >= NODE_COMPLEXITY_INF) then
                    result := NODE_COMPLEXITY_INF;
                  exit;
                end;
              subscriptn:
                begin
                  if is_class_or_interface_or_dispinterface_or_objc(tunarynode(p).left.resultdef) then
                    inc(result,2);
                  if (result = NODE_COMPLEXITY_INF) then
                    exit;
                  p := tunarynode(p).left;
                end;
              blockn,
              callparan:
                p := tunarynode(p).left;
              notn,
              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;
              addn,subn,orn,andn,xorn,muln,divn,modn,symdifn,
              shln,shrn,
              equaln,unequaln,gtn,gten,ltn,lten,
              assignn:
                begin
{$ifdef CPU64BITALU}
                  correction:=1;
{$else CPU64BITALU}
                  correction:=2;
{$endif CPU64BITALU}
                  inc(result,node_complexity(tbinarynode(p).left)+1*correction);
                  if (p.nodetype in [muln,divn,modn]) then
                    inc(result,5*correction*correction);
                  if (result >= NODE_COMPLEXITY_INF) then
                    begin
                      result := NODE_COMPLEXITY_INF;
                      exit;
                    end;
                  p := tbinarynode(p).right;
                end;
              ordconstn:
                begin
{$ifdef ARM}
                  if not(is_shifter_const(tordconstnode(p).value.svalue,dummy)) then
                    result:=2;
{$endif ARM}
                  exit;
                end;
              stringconstn,
              tempcreaten,
              tempdeleten,
              pointerconstn,
              nothingn,
              niln:
                exit;
              inlinen:
                begin
                  { this code assumes that the inline node has   }
                  { already been firstpassed, and consequently   }
                  { that inline nodes which are transformed into }
                  { calls already have been transformed          }
                  case tinlinenode(p).inlinenumber of
                    in_lo_qword,
                    in_hi_qword,
                    in_lo_long,
                    in_hi_long,
                    in_lo_word,
                    in_hi_word,
                    in_length_x,
                    in_assigned_x,
                    in_pred_x,
                    in_succ_x,
                    in_round_real,
                    in_trunc_real,
                    in_int_real,
                    in_frac_real,
                    in_cos_real,
                    in_sin_real,
                    in_arctan_real,
                    in_pi_real,
                    in_abs_real,
                    in_sqr_real,
                    in_sqrt_real,
                    in_ln_real,
                    in_unaligned_x,
                    in_prefetch_var:
                      begin
                        inc(result);
                        p:=tunarynode(p).left;
                      end;
                    in_abs_long:
                      begin
                        inc(result,3);
                        if (result >= NODE_COMPLEXITY_INF) then
                          begin
                            result:=NODE_COMPLEXITY_INF;
                            exit;
                          end;
                        p:=tunarynode(p).left;
                      end;
                    in_sizeof_x,
                    in_typeof_x:
                      begin
                        inc(result);
                        if (tinlinenode(p).left.nodetype<>typen) then
                          { get instance vmt }
                          p:=tunarynode(p).left
                        else
                          { type vmt = global symbol, result is }
                          { already increased above             }
                          exit;
                      end;
          {$ifdef SUPPORT_MMX}
                    in_mmx_pcmpeqb..in_mmx_pcmpgtw,
          {$endif SUPPORT_MMX}
                    { load from global symbol }
                    in_typeinfo_x,
                    { load frame pointer }
                    in_get_frame,
                    in_get_caller_frame,
                    in_get_caller_addr:
                      begin
                        inc(result);
                        exit;
                      end;

                    in_inc_x,
                    in_dec_x,
                    in_include_x_y,
                    in_exclude_x_y,
                    in_assert_x_y :
                      begin
                        { operation (add, sub, or, and }
                        inc(result);
                        { left expression }
                        inc(result,node_complexity(tcallparanode(tunarynode(p).left).left));
                        if (result >= NODE_COMPLEXITY_INF) then
                          begin
                            result := NODE_COMPLEXITY_INF;
                            exit;
                          end;
                        p:=tcallparanode(tunarynode(p).left).right;
                        if assigned(p) then
                          p:=tcallparanode(p).left;
                      end;
                    else
                      begin
                        result := NODE_COMPLEXITY_INF;
                        exit;
                      end;
                  end;

                end;
              else
                begin
                  result := NODE_COMPLEXITY_INF;
                  exit;
                end;
            end;
        end;
      end;


    { this function returns an indication how much fpu registers
      will be required.
      Note: The algorithms need to be pessimistic to prevent a
      fpu stack overflow on i386 }
    function node_resources_fpu(p: tnode): cardinal;
      var
        res1,res2,res3 : cardinal;
      begin
        result:=0;
        res1:=0;
        res2:=0;
        res3:=0;
        if p.inheritsfrom(tunarynode) then
          begin
            if assigned(tunarynode(p).left) then
              res1:=node_resources_fpu(tunarynode(p).left);
            if p.inheritsfrom(tbinarynode) then
              begin
                if assigned(tbinarynode(p).right) then
                  res2:=node_resources_fpu(tbinarynode(p).right);
                if p.inheritsfrom(ttertiarynode) and assigned(ttertiarynode(p).third) then
                  res3:=node_resources_fpu(ttertiarynode(p).third)
              end;
          end;
        result:=max(max(res1,res2),res3);
        case p.nodetype of
          calln:
            { it could be a recursive call, so we never really know the number of used fpu registers }
            result:=maxfpuregs;
          realconstn,
          typeconvn,
          loadn :
            begin
              if p.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER] then
                result:=max(result,1);
            end;
          assignn,
          addn,subn,muln,slashn,
          equaln,unequaln,gtn,gten,ltn,lten :
            begin
              if (tbinarynode(p).left.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER]) or
                 (tbinarynode(p).right.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER])then
                result:=max(result,2);
              if(p.expectloc in [LOC_CFPUREGISTER,LOC_FPUREGISTER]) then
                inc(result);
            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;


    function callsimplify(var n: tnode; arg: pointer): foreachnoderesult;
      var
        hn : tnode;
        treechanged : ^boolean;
      begin
        result:=fen_false;
        if n.inheritsfrom(tloopnode) and
           not (lnf_simplify_processing in tloopnode(n).loopflags) then
          begin
            // Try to simplify condition
            dosimplify(tloopnode(n).left);
            // call directly second part below,
            // which might change the loopnode into
            // something else if the conditino is a constant node
            include(tloopnode(n).loopflags,lnf_simplify_processing);
            callsimplify(n,arg);
            // Be careful, n might have change node type
            if n.inheritsfrom(tloopnode) then
              exclude(tloopnode(n).loopflags,lnf_simplify_processing);
          end
        else
          begin
            hn:=n.simplify;
            if assigned(hn) then
              begin
                treechanged := arg;
                if assigned(treechanged) then
                  treechanged^:=true
                else
                  internalerror (201008181);
                n.free;
                n:=hn;
                typecheckpass(n);
              end;
          end;
      end;


    { tries to simplify the given node calling the simplify method recursively }
    procedure dosimplify(var n : tnode);
      var
        treechanged : boolean;
      begin
        // Optimize if code first
        repeat
          treechanged:=false;
          foreachnodestatic(pm_postandagain,n,@callsimplify,@treechanged);
        until not(treechanged);
      end;


    function getpropaccesslist(propsym:tpropertysym; pap:tpropaccesslisttypes;out propaccesslist:tpropaccesslist):boolean;
    var
      hpropsym : tpropertysym;
    begin
      result:=false;
      { find property in the overriden list }
      hpropsym:=propsym;
      repeat
        propaccesslist:=hpropsym.propaccesslist[pap];
        if not propaccesslist.empty then
          begin
            result:=true;
            exit;
          end;
        hpropsym:=hpropsym.overridenpropsym;
      until not assigned(hpropsym);
    end;


    procedure propaccesslist_to_node(var p1:tnode;st:TSymtable;pl:tpropaccesslist);
      var
        plist : ppropaccesslistitem;
      begin
        plist:=pl.firstsym;
        while assigned(plist) do
         begin
           case plist^.sltype of
             sl_load :
               begin
                 addsymref(plist^.sym);
                 if not assigned(st) then
                   st:=plist^.sym.owner;
                 { p1 can already contain the loadnode of
                   the class variable. When there is no tree yet we
                   may need to load it for with or objects }
                 if not assigned(p1) then
                  begin
                    case st.symtabletype of
                      withsymtable :
                        p1:=tnode(twithsymtable(st).withrefnode).getcopy;
                      ObjectSymtable :
                        p1:=load_self_node;
                    end;
                  end;
                 if assigned(p1) then
                  p1:=csubscriptnode.create(plist^.sym,p1)
                 else
                  p1:=cloadnode.create(plist^.sym,st);
               end;
             sl_subscript :
               begin
                 addsymref(plist^.sym);
                 p1:=csubscriptnode.create(plist^.sym,p1);
               end;
             sl_typeconv :
               p1:=ctypeconvnode.create_explicit(p1,plist^.def);
             sl_absolutetype :
               begin
                 p1:=ctypeconvnode.create(p1,plist^.def);
                 include(p1.flags,nf_absolute);
               end;
             sl_vec :
               p1:=cvecnode.create(p1,cordconstnode.create(plist^.value,plist^.valuedef,true));
             else
               internalerror(200110205);
           end;
           plist:=plist^.next;
         end;
      end;


    function node_to_propaccesslist(p1:tnode):tpropaccesslist;
      var
        sl : tpropaccesslist;

        procedure addnode(p:tnode);
        begin
          case p.nodetype of
            subscriptn :
              begin
                addnode(tsubscriptnode(p).left);
                sl.addsym(sl_subscript,tsubscriptnode(p).vs);
              end;
            typeconvn :
              begin
                addnode(ttypeconvnode(p).left);
                if nf_absolute in ttypeconvnode(p).flags then
                  sl.addtype(sl_absolutetype,ttypeconvnode(p).totypedef)
                else
                  sl.addtype(sl_typeconv,ttypeconvnode(p).totypedef);
              end;
            vecn :
              begin
                addnode(tvecnode(p).left);
                if tvecnode(p).right.nodetype=ordconstn then
                  sl.addconst(sl_vec,tordconstnode(tvecnode(p).right).value,tvecnode(p).right.resultdef)
                else
                  begin
                    Message(parser_e_illegal_expression);
                    { recovery }
                    sl.addconst(sl_vec,0,tvecnode(p).right.resultdef);
                  end;
             end;
            loadn :
              sl.addsym(sl_load,tloadnode(p).symtableentry);
            else
              internalerror(200310282);
          end;
        end;

      begin
        sl:=tpropaccesslist.create;
        addnode(p1);
        result:=sl;
      end;


    function is_bitpacked_access(n: tnode): boolean;
      begin
        case n.nodetype of
          vecn:
            result:=
              is_packed_array(tvecnode(n).left.resultdef) and
              (tarraydef(tvecnode(n).left.resultdef).elepackedbitsize mod 8 <> 0);
          subscriptn:
            result:=
              is_packed_record_or_object(tsubscriptnode(n).left.resultdef) and
              ((tsubscriptnode(n).vs.vardef.packedbitsize mod 8 <> 0) or
               (tsubscriptnode(n).vs.fieldoffset mod 8 <> 0));
          else
            result:=false;
        end;
      end;


    function genloadfield(n: tnode; const fieldname: string): tnode;
      var
        vs         : tsym;
      begin
        if not assigned(n.resultdef) then
          typecheckpass(n);
        vs:=tsym(tabstractrecorddef(n.resultdef).symtable.find(fieldname));
        if not assigned(vs) or
           (vs.typ<>fieldvarsym) then
          internalerror(2010061902);
        result:=csubscriptnode.create(vs,n);
      end;


    function has_no_code(n : tnode) : boolean;
      begin
        if n=nil then
          begin
            result:=true;
            exit;
          end;
        result:=false;
        case n.nodetype of
          nothingn:
            begin
               result:=true;
               exit;
            end;
          blockn:
            begin
              result:=has_no_code(tblocknode(n).left);
              exit;
            end;
          statementn:
            begin
              repeat
                result:=has_no_code(tstatementnode(n).left);
                n:=tstatementnode(n).right;
              until not(result) or not assigned(n);
              exit;
            end;
        end;
      end;

end.