← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to fpcsrc/compiler/opttail.pas

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
fpcsrc/compiler/opttail.pas
 
1
{
 
2
    Tail recursion optimization
 
3
 
 
4
    Copyright (c) 2006 by Florian Klaempfl
 
5
 
 
6
    This program is free software; you can redistribute it and/or modify
 
7
    it under the terms of the GNU General Public License as published by
 
8
    the Free Software Foundation; either version 2 of the License, or
 
9
    (at your option) any later version.
 
10
 
 
11
    This program is distributed in the hope that it will be useful,
 
12
    but WITHOUT ANY WARRANTY; without even the implied warranty of
 
13
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
14
    GNU General Public License for more details.
 
15
 
 
16
    You should have received a copy of the GNU General Public License
 
17
    along with this program; if not, write to the Free Software
 
18
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
 
 
20
 ****************************************************************************
 
21
}
 
22
unit opttail;
 
23
 
 
24
{$i fpcdefs.inc}
 
25
 
 
26
  interface
 
27
 
 
28
    uses
 
29
      symdef,node;
 
30
 
 
31
    procedure do_opttail(var n : tnode;p : tprocdef);
 
32
 
 
33
  implementation
 
34
 
 
35
    uses
 
36
      globtype,
 
37
      symconst,symsym,
 
38
      defcmp,
 
39
      nutils,nbas,nflw,ncal,nld,ncnv,
 
40
      pass_1,
 
41
      paramgr;
 
42
 
 
43
    procedure do_opttail(var n : tnode;p : tprocdef);
 
44
 
 
45
      var
 
46
        labelnode : tlabelnode;
 
47
 
 
48
      function find_and_replace_tailcalls(var n : tnode) : boolean;
 
49
 
 
50
        var
 
51
          usedcallnode : tcallnode;
 
52
 
 
53
        function is_recursivecall(n : tnode) : boolean;
 
54
          begin
 
55
            result:=(n.nodetype=calln) and (tcallnode(n).procdefinition=p);
 
56
            if result then
 
57
              usedcallnode:=tcallnode(n)
 
58
            else
 
59
              { obsolete type cast? }
 
60
              result:=((n.nodetype=typeconvn) and (ttypeconvnode(n).convtype=tc_equal) and is_recursivecall(ttypeconvnode(n).left));
 
61
          end;
 
62
 
 
63
        function is_resultassignment(n : tnode) : boolean;
 
64
          begin
 
65
            result:=((n.nodetype=loadn) and (tloadnode(n).symtableentry=p.funcretsym)) or
 
66
              ((n.nodetype=typeconvn) and (ttypeconvnode(n).convtype=tc_equal) and is_resultassignment(ttypeconvnode(n).left));
 
67
          end;
 
68
 
 
69
        var
 
70
          calcnodes,
 
71
          copynodes,
 
72
          hp : tnode;
 
73
          nodes,
 
74
          calcstatements,
 
75
          copystatements : tstatementnode;
 
76
          paranode : tcallparanode;
 
77
          tempnode : ttempcreatenode;
 
78
          loadnode : tloadnode;
 
79
          oldnodetree : tnode;
 
80
        begin
 
81
          { no tail call found and replaced so far }
 
82
          result:=false;
 
83
          if n=nil then
 
84
            exit;
 
85
          case n.nodetype of
 
86
            statementn:
 
87
              begin
 
88
                hp:=n;
 
89
                { search last node }
 
90
                while assigned(tstatementnode(hp).right) do
 
91
                  hp:=tstatementnode(hp).right;
 
92
                result:=find_and_replace_tailcalls(tstatementnode(hp).left);
 
93
              end;
 
94
            ifn:
 
95
              begin
 
96
                result:=find_and_replace_tailcalls(tifnode(n).right);
 
97
                { avoid short bool eval here }
 
98
                result:=find_and_replace_tailcalls(tifnode(n).t1) or result;
 
99
              end;
 
100
            assignn:
 
101
              begin
 
102
                if is_resultassignment(tbinarynode(n).left) and
 
103
                   is_recursivecall(tbinarynode(n).right) then
 
104
                  begin
 
105
                    { found one! }
 
106
                    {
 
107
                    writeln('tail recursion optimization for ',p.mangledname);
 
108
                    printnode(output,n);
 
109
                    }
 
110
                    { create assignments for all parameters }
 
111
 
 
112
                    { this is hairy to do because one parameter could be used to calculate another one, so
 
113
                      assign them first to temps and then add them }
 
114
 
 
115
                    calcnodes:=internalstatements(calcstatements);
 
116
                    copynodes:=internalstatements(copystatements);
 
117
                    paranode:=tcallparanode(usedcallnode.left);
 
118
                    while assigned(paranode) do
 
119
                      begin
 
120
                        tempnode:=ctempcreatenode.create(paranode.left.resultdef,paranode.left.resultdef.size,tt_persistent,true);
 
121
                        addstatement(calcstatements,tempnode);
 
122
                        addstatement(calcstatements,
 
123
                          cassignmentnode.create(
 
124
                            ctemprefnode.create(tempnode),
 
125
                            paranode.left
 
126
                            ));
 
127
 
 
128
                        { "cast" away const varspezs }
 
129
                        loadnode:=cloadnode.create(paranode.parasym,paranode.parasym.owner);
 
130
                        include(loadnode.flags,nf_isinternal_ignoreconst);
 
131
 
 
132
                        addstatement(copystatements,
 
133
                          cassignmentnode.create(
 
134
                            loadnode,
 
135
                            ctemprefnode.create(tempnode)
 
136
                            ));
 
137
                        addstatement(copystatements,ctempdeletenode.create_normal_temp(tempnode));
 
138
 
 
139
                        { reused }
 
140
                        paranode.left:=nil;
 
141
                        paranode:=tcallparanode(paranode.right);
 
142
                      end;
 
143
 
 
144
                    oldnodetree:=n;
 
145
                    n:=internalstatements(nodes);
 
146
 
 
147
                    if assigned(usedcallnode.methodpointerinit) then
 
148
                      begin
 
149
                        addstatement(nodes,usedcallnode.methodpointerinit);
 
150
                        usedcallnode.methodpointerinit:=nil;
 
151
                      end;
 
152
 
 
153
                    addstatement(nodes,calcnodes);
 
154
                    addstatement(nodes,copynodes);
 
155
 
 
156
                    { create goto }
 
157
                    addstatement(nodes,cgotonode.create(labelnode));
 
158
 
 
159
                    if assigned(usedcallnode.methodpointerdone) then
 
160
                      begin
 
161
                        { methodpointerdone should contain only temp. node clean up }
 
162
                        checktreenodetypes(usedcallnode.methodpointerdone,
 
163
                          [tempdeleten,blockn,statementn,temprefn,nothingn]);
 
164
                        addstatement(nodes,usedcallnode.methodpointerdone);
 
165
                        usedcallnode.methodpointerdone:=nil;
 
166
                      end;
 
167
 
 
168
                    oldnodetree.free;
 
169
 
 
170
                    do_firstpass(n);
 
171
                    result:=true;
 
172
                  end;
 
173
              end;
 
174
            blockn:
 
175
              result:=find_and_replace_tailcalls(tblocknode(n).left);
 
176
          end;
 
177
        end;
 
178
 
 
179
      var
 
180
        s : tstatementnode;
 
181
        oldnodes : tnode;
 
182
        i : longint;
 
183
      begin
 
184
        { check if the parameters actually would support tail recursion elimination }
 
185
        for i:=0 to p.paras.count-1 do
 
186
          with tparavarsym(p.paras[i]) do
 
187
            if (varspez in [vs_out,vs_var]) or
 
188
              ((varspez=vs_const) and
 
189
               (paramanager.push_addr_param(varspez,vardef,p.proccalloption)) or
 
190
               { parameters requiring tables are too complicated to handle
 
191
                 and slow down things anyways so a tail recursion call
 
192
                 makes no sense
 
193
               }
 
194
               vardef.needs_inittable) then
 
195
               exit;
 
196
 
 
197
        labelnode:=clabelnode.create(cnothingnode.create);
 
198
        if find_and_replace_tailcalls(n) then
 
199
          begin
 
200
            oldnodes:=n;
 
201
            n:=internalstatements(s);
 
202
            addstatement(s,labelnode);
 
203
            addstatement(s,oldnodes);
 
204
          end
 
205
        else
 
206
          labelnode.free;
 
207
      end;
 
208
 
 
209
end.
 
210