+ constant propagation, based on a patch by Jeppe Johansen

git-svn-id: trunk@25958 -

.gitattributes

@@ -458,6 +458,7 @@ compiler/ogmacho.pas svneol=native#text/plain
 compiler/ogmap.pas svneol=native#text/plain
 compiler/ognlm.pas svneol=native#text/plain
 compiler/optbase.pas svneol=native#text/plain
+compiler/optconstprop.pas svneol=native#text/pascal
 compiler/optcse.pas svneol=native#text/plain
 compiler/optdead.pas svneol=native#text/plain
 compiler/optdfa.pas svneol=native#text/plain

compiler/optconstprop.pas

@@ -0,0 +1,326 @@
+{
+    Constant propagation across statements
+
+    Copyright (c) 2005-2012 by Jeppe Johansen and Florian Klaempfl
+
+    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 optconstprop;
+
+{$i fpcdefs.inc}
+
+{ $define DEBUG_CONSTPROP}
+
+  interface
+
+    uses
+      node;
+
+    { does constant propagation for rootnode
+
+      The approach is simple: It search for constant assignment statements. As soon as such
+      a statement is found, the following statements are search if they contain
+      a usage of the assigned variable. If this is a the case, the variable is
+      replaced by the constant. This does not work across points where the
+      program flow joins so e.g.
+
+      if ... then
+        ...
+        a:=1;
+        ...
+      else
+        ...
+        a:=1;
+        ...
+      writeln(a);
+
+      will not result in any constant propagation.
+    }
+    function do_optconstpropagate(var rootnode : tnode) : tnode;
+
+  implementation
+
+    uses
+      fmodule,
+      pass_1,procinfo,
+      symsym, symconst,
+      nutils, nbas, ncnv, nld, nflw, ncal;
+
+    function check_written(var n: tnode; arg: pointer): foreachnoderesult;
+      begin
+        result:=fen_false;
+
+        if n.isequal(tnode(arg)) and
+           ((n.flags*[nf_write,nf_modify])<>[]) then
+          begin
+            result:=fen_norecurse_true;
+          end;
+      end;
+
+
+    { propagates the constant assignment passed in arg into n }
+    function replaceBasicAssign(var n: tnode; arg: tnode; var tree_modified: boolean): boolean;
+      var
+        st2, oldnode: tnode;
+        old: pnode;
+        changed, tree_modified2,tree_modified3: boolean;
+        written : Boolean;
+      begin
+        result:=true;
+
+        if n = nil then
+          exit;
+
+        tree_modified:=false;
+        tree_modified2:=false;
+        tree_modified3:=false;
+
+        { while it might be usefull, to use foreach to iterate all nodes, it is safer to
+          iterate manually here so we have full controll how all nodes are processed }
+
+        { We cannot analyze beyond those nodes, so we terminate to be on the safe side }
+        if (n.nodetype in [addrn,derefn,dataconstn,asmn,withn,casen,whilerepeatn,forn,labeln,continuen,breakn,
+                           tryexceptn,raisen,tryfinallyn,onn,loadparentfpn,loadvmtaddrn,guidconstn,rttin,addoptn,asn,goton,
+                           objcselectorn,objcprotocoln]) then
+          exit(false)
+        else if n.nodetype=assignn then
+          begin
+            tree_modified:=false;
+
+            { we can propage the constant in both branches because the evaluation order is not defined }
+            result:=replaceBasicAssign(tassignmentnode(n).right, arg, tree_modified);
+            { do not use the intuitive way result:=result and replace... because this would prevent
+              replaceBasicAssign being called if the result is already false }
+            result:=replaceBasicAssign(tassignmentnode(n).left, arg, tree_modified2) and result;
+            tree_modified:=tree_modified or tree_modified2;
+
+            { but we have to check if left writes to the currently searched variable ... }
+            written:=foreachnodestatic(pm_postprocess, tassignmentnode(n).left, @check_written, tassignmentnode(arg).left);
+            { ... if this is the case, we have to stop searching }
+            result:=result and not(written);
+          end
+        else if n.isequal(tassignmentnode(arg).left) and ((n.flags*[nf_write,nf_modify])=[]) then
+          begin
+            n.Free;
+            n:=tassignmentnode(arg).right.getcopy;
+            inserttypeconv_internal(n, tassignmentnode(arg).left.resultdef);
+
+            tree_modified:=true;
+          end
+        else if n.nodetype=statementn then
+          result:=replaceBasicAssign(tstatementnode(n).left, arg, tree_modified)
+        else if n.nodetype=blockn then
+          begin
+            changed:=false;
+
+            st2:=tstatementnode(tblocknode(n).statements);
+            old:=@tblocknode(n).statements;
+            while assigned(st2) do
+              begin
+                repeat
+                  oldnode:=st2;
+
+                  tree_modified2:=false;
+                  if not replaceBasicAssign(st2, arg, tree_modified2) then
+                    begin
+                      old^:=st2;
+                      oldnode:=nil;
+                      changed:=changed or tree_modified2;
+                      result:=false;
+                      break;
+                    end
+                  else
+                    old^:=st2;
+                  changed:=changed or tree_modified2;
+                until oldnode=st2;
+
+                if oldnode = nil then
+                  break;
+
+                old:=@tstatementnode(st2).next;
+                st2:=tstatementnode(st2).next;
+              end;
+
+            tree_modified:=changed;
+          end
+        else if n.nodetype=ifn then
+          begin
+            result:=replaceBasicAssign(tifnode(n).left, arg, tree_modified);
+
+            if result then
+              begin
+                if assigned(tifnode(n).t1) then
+                  begin
+                    { we can propagate the constant in both branches of an if statement
+                      because even if the the branch writes to it, the else branch gets the
+                      unmodified value }
+                    result:=replaceBasicAssign(tifnode(n).right, arg, tree_modified2);
+
+                    { do not use the intuitive way result:=result and replace... because this would prevent
+                      replaceBasicAssign being called if the result is already false }
+                    result:=replaceBasicAssign(tifnode(n).t1, arg, tree_modified3) and result;
+
+                    tree_modified:=tree_modified or tree_modified2 or tree_modified3;
+                  end
+                else
+                  begin
+                    result:=replaceBasicAssign(tifnode(n).right, arg, tree_modified2);
+                    tree_modified:=tree_modified or tree_modified2;
+                  end;
+              end;
+          end
+        else if n.nodetype in [calln,inlinen] then
+          begin
+            if might_have_sideeffects(n) and (n.nodetype=inlinen) then
+              exit(false);
+
+            if n.nodetype=calln then
+              exit(false);
+
+            replaceBasicAssign(tunarynode(n).left, arg, tree_modified);
+            result:=false;
+          end
+        else if n.InheritsFrom(tbinarynode) then
+          begin
+            result:=replaceBasicAssign(tbinarynode(n).left, arg, tree_modified);
+            if result then
+              result:=replaceBasicAssign(tbinarynode(n).right, arg, tree_modified2);
+            tree_modified:=tree_modified or tree_modified2;
+          end
+        else if n.InheritsFrom(tunarynode) then
+          begin
+            result:=replaceBasicAssign(tunarynode(n).left, arg, tree_modified);
+          end;
+
+        if n.nodetype<>callparan then
+          begin
+            if tree_modified then
+              exclude(n.flags,nf_pass1_done);
+
+            do_firstpass(n);
+          end;
+      end;
+
+
+    function propagate(var n: tnode; arg: pointer): foreachnoderesult;
+      var
+        l,
+        st, st2, oldnode: tnode;
+        old: pnode;
+        a: tassignmentnode;
+        tree_mod, changed: boolean;
+      begin
+        result:=fen_true;
+
+        changed:=false;
+        PBoolean(arg)^:=false;
+
+        if not assigned(n) then
+          exit;
+
+        if n.nodetype in [calln] then
+          exit(fen_norecurse_true);
+
+        if n.nodetype=blockn then
+          begin
+            st:=tblocknode(n).statements;
+
+            while assigned(st) and
+                  (st.nodetype=statementn) and
+                  assigned(tstatementnode(st).statement) do
+              begin
+                if tstatementnode(st).statement.nodetype=assignn then
+                  begin
+                    a:=tassignmentnode(tstatementnode(st).statement);
+
+                    l:=a.left;
+
+                    if (((l.nodetype=loadn) and
+                         (tloadnode(l).symtableentry.typ=localvarsym) and
+                         (tloadnode(l).symtable=current_procinfo.procdef.localst)
+                        ) or
+                        ((l.nodetype=loadn) and
+                         (tloadnode(l).symtableentry.typ=paravarsym) and
+                         (tloadnode(l).symtable=current_procinfo.procdef.parast)
+                        ) or
+                        (l.nodetype = temprefn)) and
+                       (is_constintnode(a.right) or
+                        is_constboolnode(a.right) or
+                        is_constcharnode(a.right) or
+                        is_constenumnode(a.right) or
+                        is_conststringnode(a.right)) then
+                      begin
+                        st2:=tstatementnode(tstatementnode(st).right);
+                        old:=@tstatementnode(st).right;
+                        while assigned(st2) do
+                          begin
+                            repeat
+                              oldnode:=st2;
+
+                              { Simple assignment of constant found }
+                              tree_mod:=false;
+                              if not replaceBasicAssign(st2, a, tree_mod) then
+                                begin
+                                  old^:=st2;
+                                  oldnode:=nil;
+                                  changed:=changed or tree_mod;
+                                  break;
+                                end
+                              else
+                                old^:=st2;
+                              changed:=changed or tree_mod;
+                            until oldnode=st2;
+
+                            if oldnode = nil then
+                              break;
+
+                            old:=@tstatementnode(st2).next;
+                            st2:=tstatementnode(st2).next;
+                          end;
+                      end;
+                  end;
+
+                st:=tstatementnode(st).next;
+              end;
+          end;
+
+        PBoolean(arg)^:=changed;
+      end;
+
+
+    function do_optconstpropagate(var rootnode: tnode): tnode;
+      var
+        changed: boolean;
+      begin
+{$ifdef DEBUG_CONSTPROP}
+        writeln('************************ before constant propagation ***************************');
+        printnode(rootnode);
+{$endif DEBUG_CONSTPROP}
+        repeat
+          changed:=false;
+          foreachnodestatic(pm_postandagain, rootnode, @propagate, @changed);
+        until changed=false;
+{$ifdef DEBUG_CONSTPROP}
+        writeln('************************ after constant propagation ***************************');
+        printnode(rootnode);
+        writeln('*******************************************************************************');
+{$endif DEBUG_CONSTPROP}
+        result:=rootnode;
+      end;
+
+end.
+

compiler/psub.pas

@@ -113,7 +113,9 @@ implementation
        ncgutil,regvars,
        optbase,
        opttail,
-       optcse,optloop
+       optcse,
+       optloop,
+       optconstprop
 {$if defined(arm) or defined(avr) or defined(fpc_compiler_has_fixup_jmps)}
        ,aasmcpu
 {$endif arm}
@@ -1251,6 +1253,9 @@ implementation
           (pi_is_recursive in flags) then
           do_opttail(code,procdef);
 
+        if (cs_opt_constant_propagate in current_settings.optimizerswitches) then
+          do_optconstpropagate(code);
+
         if (cs_opt_nodedfa in current_settings.optimizerswitches) and
           { creating dfa is not always possible }
           ((flags*[pi_has_assembler_block,pi_uses_exceptions,pi_is_assembler,