* Improved escape analysis so the improved tretopt no longer fails.

    The downside is that because it is context-insensitive, several
    (correct) optimizations which were performed in the past no longer
    are now (and while some new ones are done now, the downside is bigger
    -- but at least the code should be correct in all cases now)

git-svn-id: trunk@8385 -

compiler/htypechk.pas

@@ -79,6 +79,16 @@ interface
         property  VisibleCount:integer read FProcVisibleCnt;
       end;
 
+    type
+      tregableinfoflag = (
+         // can be put in a register if it's the address of a var/out/const parameter
+         ra_addr_regable,
+         // orthogonal to above flag: the address of the node is taken and may
+         // possibly escape the block in which this node is declared (e.g. a
+         // local variable is passed as var parameter to another procedure)
+         ra_addr_taken);
+      tregableinfoflags = set of tregableinfoflag;
+
     const
       tok2nodes=24;
       tok2node:array[1..tok2nodes] of ttok2noderec=(
@@ -123,7 +133,7 @@ interface
     function isbinaryoverloaded(var t : tnode) : boolean;
 
     { Register Allocation }
-    procedure make_not_regable(p : tnode; how: tvarregable);
+    procedure make_not_regable(p : tnode; how: tregableinfoflags);
     procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word);
 
     { procvar handling }
@@ -676,43 +686,68 @@ implementation
 ****************************************************************************}
 
     { marks an lvalue as "unregable" }
-    procedure make_not_regable_intern(p : tnode; how: tvarregable; records_only: boolean);
+    procedure make_not_regable_intern(p : tnode; how: tregableinfoflags; records_only: boolean);
+      var
+        update_regable: boolean;
       begin
-         case p.nodetype of
-             subscriptn:
-               make_not_regable_intern(tsubscriptnode(p).left,how,true);
+        update_regable:=true;
+        repeat
+          case p.nodetype of
+            subscriptn:
+              begin
+                records_only:=true;
+                p:=tsubscriptnode(p).left;
+              end;
+            vecn:
+              begin
+                { arrays are currently never regable and pointers indexed like }
+                { arrays do not have be made unregable, but we do need to      }
+                { propagate the ra_addr_taken info                             }                                          
+                update_regable:=false;
+                p:=tvecnode(p).left;
+              end;
             typeconvn :
-               if (ttypeconvnode(p).resultdef.typ = recorddef) then
-                 make_not_regable_intern(ttypeconvnode(p).left,how,false)
-               else
-                 make_not_regable_intern(ttypeconvnode(p).left,how,records_only);
+               begin
+                 if (ttypeconvnode(p).resultdef.typ = recorddef) then
+                   records_only:=false;
+                 p:=ttypeconvnode(p).left;
+               end;
             loadn :
-              if (tloadnode(p).symtableentry.typ in [staticvarsym,localvarsym,paravarsym]) then
-                begin
-                  { this is overly conservative (make_not_regable is also called in }
-                  { other situations), but it avoids having to do this all over the }
-                  { the compiler                                                     }
-                  tabstractvarsym(tloadnode(p).symtableentry).addr_taken:=true;
-                  if (tabstractvarsym(tloadnode(p).symtableentry).varregable <> vr_none) and
-                     ((not records_only) or
-                      (tabstractvarsym(tloadnode(p).symtableentry).vardef.typ = recorddef)) then
-                    if (tloadnode(p).symtableentry.typ = paravarsym) then
-                      tabstractvarsym(tloadnode(p).symtableentry).varregable:=how
-                    else
-                      tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_none;
-                end;
+              begin
+                if (tloadnode(p).symtableentry.typ in [staticvarsym,localvarsym,paravarsym]) then
+                  begin
+                    if (ra_addr_taken in how) then
+                      tabstractvarsym(tloadnode(p).symtableentry).addr_taken:=true;
+                    if update_regable and
+                       (tabstractvarsym(tloadnode(p).symtableentry).varregable <> vr_none) and
+                       ((not records_only) or
+                        (tabstractvarsym(tloadnode(p).symtableentry).vardef.typ = recorddef)) then
+                      if (tloadnode(p).symtableentry.typ = paravarsym) and
+                         (ra_addr_regable in how) then
+                        tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_addr
+                      else
+                        tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_none;
+                  end;
+                break;
+              end;
             temprefn :
               begin
-                include(ttemprefnode(p).tempinfo^.flags,ti_addr_taken);
-                if (ti_may_be_in_reg in ttemprefnode(p).tempinfo^.flags) and
+                if (ra_addr_taken in how) then
+                  include(ttemprefnode(p).tempinfo^.flags,ti_addr_taken);
+                if update_regable and
+                   (ti_may_be_in_reg in ttemprefnode(p).tempinfo^.flags) and
                    ((not records_only) or
                     (ttemprefnode(p).tempinfo^.typedef.typ = recorddef)) then
                   exclude(ttemprefnode(p).tempinfo^.flags,ti_may_be_in_reg);
+                break;
               end;
-         end;
+            else
+              break;
+          end;
+        until false;
       end;
 
-    procedure make_not_regable(p : tnode; how: tvarregable);
+    procedure make_not_regable(p : tnode; how: tregableinfoflags);
       begin
         make_not_regable_intern(p,how,false);
       end;
@@ -1088,7 +1123,7 @@ implementation
                       be in a register }
                     if (m_tp7 in current_settings.modeswitches) or
                        (todef.size<fromdef.size) then
-                      make_not_regable(hp,vr_addr)
+                      make_not_regable(hp,[ra_addr_regable])
                     else
                       if report_errors then
                         CGMessagePos2(hp.fileinfo,type_e_typecast_wrong_size_for_assignment,tostr(fromdef.size),tostr(todef.size));

compiler/ncal.pas

@@ -987,20 +987,28 @@ implementation
 
                  { When the address needs to be pushed then the register is
                    not regable. Exception is when the location is also a var
-                   parameter and we can pass the address transparently }
+                   parameter and we can pass the address transparently (but
+                   that is handled by make_not_regable if ra_addr_regable is
+                   passed, and make_not_regable always needs to called for
+                   the ra_addr_taken info for non-invisble parameters }
                  if (
                      not(
                          (vo_is_hidden_para in parasym.varoptions) and
                          (left.resultdef.typ in [pointerdef,classrefdef])
                         ) and
                      paramanager.push_addr_param(parasym.varspez,parasym.vardef,
-                         aktcallnode.procdefinition.proccalloption) and
-                     not(
-                         (left.nodetype=loadn) and
-                         (tloadnode(left).is_addr_param_load)
-                        )
+                         aktcallnode.procdefinition.proccalloption)
                     ) then
-                   make_not_regable(left,vr_addr);
+                   { pushing the address of a variable to take the place of a temp  }
+                   { as the complex function result of a function does not make its }
+                   { address escape the current block, as the "address of the       }
+                   { function result" is not something which can be stored          }
+                   { persistently by the callee (it becomes invalid when the callee }
+                   { returns)                                                       }
+                   if not(vo_is_funcret in parasym.varoptions) then
+                     make_not_regable(left,[ra_addr_regable,ra_addr_taken])
+                   else
+                     make_not_regable(left,[ra_addr_regable]);
 
                  if do_count then
                   begin

compiler/ncnv.pas

@@ -1578,7 +1578,7 @@ implementation
             convtype:=tc_equal;
             if not(tstoreddef(resultdef).is_intregable) and
                not(tstoreddef(resultdef).is_fpuregable) then
-              make_not_regable(left,vr_addr);
+              make_not_regable(left,[ra_addr_regable]);
             exit;
           end;
 
@@ -1731,7 +1731,7 @@ implementation
                          not(tstoreddef(resultdef).is_fpuregable)) or
                         ((left.resultdef.typ = floatdef) and
                          (resultdef.typ <> floatdef))  then
-                       make_not_regable(left,vr_addr);
+                       make_not_regable(left,[ra_addr_regable]);
 
                      { class/interface to class/interface, with checkobject support }
                      if is_class_or_interface(resultdef) and
@@ -2644,7 +2644,7 @@ implementation
         { When using only a part of the value it can't be in a register since
           that will load the value in a new register first }
         if (resultdef.size<left.resultdef.size) then
-          make_not_regable(left,vr_addr);
+          make_not_regable(left,[ra_addr_regable]);
       end;
 
 

compiler/nld.pas

@@ -272,7 +272,7 @@ implementation
                     (symtable.symtablelevel<>current_procinfo.procdef.localst.symtablelevel) or
                     (current_procinfo.procdef.proctypeoption=potype_unitfinalize)
                   ) then
-                 make_not_regable(self,vr_none);
+                 make_not_regable(self,[ra_addr_taken]);
                resultdef:=tabstractvarsym(symtableentry).vardef;
              end;
            paravarsym,
@@ -291,7 +291,8 @@ implementation
                    { we can't inline the referenced parent procedure }
                    exclude(tprocdef(symtable.defowner).procoptions,po_inline);
                    { reference in nested procedures, variable needs to be in memory }
-                   make_not_regable(self,vr_none);
+                   { and behaves as if its address escapes its parent block         }
+                   make_not_regable(self,[ra_addr_taken]);
                  end;
                { fix self type which is declared as voidpointer in the
                  definition }

compiler/nmem.pas

@@ -353,7 +353,7 @@ implementation
         if codegenerror then
          exit;
 
-        make_not_regable(left,vr_addr);
+        make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
 
         { don't allow constants, for internal use we also
           allow taking the address of strings }
@@ -607,7 +607,7 @@ implementation
         // don't put records from which we load fields which aren't regable in integer registers
         if (left.resultdef.typ = recorddef) and
            not(tstoreddef(resultdef).is_intregable) then
-          make_not_regable(left,vr_addr);
+          make_not_regable(left,[ra_addr_regable]);
       end;
 
     procedure Tsubscriptnode.mark_write;

compiler/pdecvar.pas

@@ -974,7 +974,7 @@ implementation
                   { we can't take the size of an open array }
                   if is_open_array(pt.resultdef) or
                      (vs.vardef.size <> pt.resultdef.size) then
-                    make_not_regable(pt,vr_addr);
+                    make_not_regable(pt,[ra_addr_regable]);
                 end
               else
                 Message(parser_e_absolute_only_to_var_or_const);

compiler/rautils.pas

@@ -802,6 +802,8 @@ Begin
         inc(tabstractvarsym(sym).refs);
         { variable can't be placed in a register }
         tabstractvarsym(sym).varregable:=vr_none;
+        { and anything may happen with its address }
+        tabstractvarsym(sym).addr_taken:=true;
         case sym.typ of
           staticvarsym :
             begin