1
package Language::INTERCAL::Optimiser;
3
# Oprimiser for CLC-INTERCAL
5
# This file is part of CLC-INTERCAL.
7
# Copyright (C) 1999 Claudio Calvelli <lunatic@assurdo.com>, all rights reserved
9
# WARNING - do not operate heavy machinery while using CLC-INTERCAL
11
# This program is free software; you can redistribute it and/or modify
12
# it under the terms of the GNU General Public License as published by
13
# the Free Software Foundation; either 2 of the License, or
14
# (at your option) any later version.
16
# This program is distributed in the hope that it will be useful,
17
# but WITHOUT ANY WARRANTY; without even the implied warranty of
18
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19
# GNU General Public License for more details.
21
# You should have received a copy of the GNU General Public License
22
# along with this program; if not, write to the Free Software
23
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25
use vars qw($VERSION);
28
use Language::INTERCAL::Opcodes;
29
use Language::INTERCAL::Runtime::Library;
32
$_[0][0] == E_REGISTER;
36
$_[0][0] == E_CONSTANT;
40
my ($ptree, $filename, $line) = @_;
41
# I've temporarily moved everything to the second optimiser until I
42
# convince myself of what is safe to run before seeing the whole program
47
my ($ptree, $filename, $line) = @_;
48
my $quantum = exists $ptree->{'flags'}{'quantum'};
49
my $ignore = exists $ptree->{'flags'}{'ignore'};
50
my $postprocess = exists $ptree->{'flags'}{'postprocess'};
51
my $overload = exists $ptree->{'flags'}{'overload'};
52
my $qip = $quantum || $postprocess || $ignore;
53
my $abstain = $ptree->{'abstain'};
54
my $reinstate = $ptree->{'reinstate'};
55
my $gabstain = $ptree->{'gabstain'};
56
my $greinstate = $ptree->{'greinstate'};
57
my $labels = $ptree->{'labels'};
58
my $abstain_calculate = 0;
61
my ($p, $fid, $bid, $sid, $stmt) = @_;
62
if ($stmt->[3][0] == S_GABSTAIN || $stmt->[3][0] == S_REINSTATE) {
63
$abstain_calculate = 1 if grep {$_ == S_ASSIGN} @{$stmt->[3]};
70
my ($p, $fid, $bid, $sid, $stmt) = @_;
71
my $bc = $stmt->[3][0];
72
if ($bc == S_ABSTAIN ||
79
do_expression($stmt->[3], 1, \%regcon, $quantum);
81
if ($bc == S_WHILE_E) {
82
do_expression($stmt->[3], 2, \%regcon, $quantum);
84
if ($bc == S_WHILE_BC || $bc == S_WHILE_CB) {
86
&$code($p, -1, 0, 0, [1, 100, 0, $stmt->[3][1]]);
88
&$code($p, -1, 0, 0, [1, 100, 0, $stmt->[3][2]]);
92
my $rname = $stmt->[3][1][1] . $stmt->[3][1][2];
93
delete $regcon{$rname};
96
my $rname = $stmt->[3][1][1] . $stmt->[3][1][2];
97
$regcon{$rname}[3] = 0 if exists $regcon{$rname};
99
if ($bc == S_ASSIGN) {
103
do_expression($s, $i, \%regcon, $quantum);
105
# the next condition errs on the side of correctness, it
106
# would be OK to say "$s->[1] cannot be overloaded" instead
107
# of "the program does not contain overloading". Same for
108
# ignore. Perhaps building a list of registers which appear
109
# in overload/ignore... make a note for another release.
110
# we also need to check for ABSTAIN FROM CALCULATING
111
# (ABSTAIN FROM (label) does not matter because we never join
112
# together statements if one has a label)
113
if (! $qip && ! $overload && _is_plainreg($s->[1])) {
114
my $rname = $s->[1][1] . $s->[1][2];
115
if (ref $stmt->[2] || $stmt->[2] < 100 || $abstain_calculate) {
116
delete $regcon{$rname};
118
if (exists $regcon{$rname} && $regcon{$rname}[3]) {
119
_remove($ptree, $regcon{$rname}[1], $regcon{$rname}[2]);
121
if (@$s == 3 && _is_const($s->[2])) {
123
$v = $s->[1][1] eq ':' ? ato32($v) : ato16($v);
124
$regcon{$rname} = [$v, $fid, $stmt, 1];
126
delete $regcon{$rname};
131
if ($bc == S_RETRIEVE || $bc == S_STASH) {
135
if (_is_plainreg($s->[$i])) {
136
# this errs on the side of correctness - we could
137
# easily build a stack within $regcon{$rname} and
138
# push it at stash, pop at retrieve. Maybe in a
140
my $rname = $s->[$i][1] . $s->[$i][2];
141
delete $regcon{$rname};
145
if ($bc == S_LEARN) {
146
do_expression($stmt->[3], 2, \%regcon, $quantum);
148
if ($bc == S_STUDY) {
149
do_expression($stmt->[3], 1, \%regcon, $quantum);
150
do_expression($stmt->[3], 2, \%regcon, $quantum);
151
do_expression($stmt->[3], 3, \%regcon, $quantum);
153
if ($bc == S_ENROL) {
155
for $i (2..$#{$stmt->[3]}) {
156
do_expression($stmt->[3], $i, \%regcon, $quantum);
160
$ptree->iterate($code, sub { %regcon = (); });
164
$ptree->iterate(sub {
165
my ($p, $fid, $bid, $sid, $stmt) = @_;
166
my $bc = $stmt->[3][0];
168
# anything following a stop can be removed
169
_remove($ptree, $fid, $stmt) if $stop;
170
$stop = 1 if $stmt->[1] &&
171
(! ref $stmt->[2]) && $stmt->[2] == 100 &&
175
# if we are in the first block, we can execute any ABSTAINs etc
176
if ($first && $bid == 1) {
177
if (($bc == S_ABSTAIN || $bc == S_REINSTATE) &&
178
(! ref $stmt->[2]) && $stmt->[2] == 100 &&
180
_is_const($stmt->[3][1]) && exists $labels->{$stmt->[3][1][1]})
182
my $l = $labels->{$stmt->[3][1][1]};
183
$ptree->{'files'}[$l->[0]][$l->[1]][$l->[2]][1] =
184
$bc == S_ABSTAIN ? 0 : 1;
185
_remove($ptree, $fid, $stmt);
188
if (($bc == S_GABSTAIN || $bc == S_GREINSTATE) &&
189
(! ref $stmt->[2]) && $stmt->[2] == 100 &&
192
my $ab = $bc == S_GABSTAIN ? 0 : 1;
193
my @s = @{$stmt->[3]};
195
$ptree->iterate(sub {
196
my ($p1, $fid1, $bid1, $sid1, $stmt1) = @_;
197
if (grep {$_ == $stmt1->[3][0]} @s) {
201
_remove($ptree, $fid, $stmt);
204
if ($bc == S_CONVERT || $bc == S_SWAP) {
205
if ((! ref $stmt->[2]) && $stmt->[2] == 100 && $stmt->[1]) {
206
my $code1 = $stmt->[3][1][0];
207
my $code2 = $stmt->[3][2][0];
209
if ($code1 != $code2) {
210
$ptree->iterate(sub {
211
my ($p1, $fid1, $bid1, $sid1, $stmt1) = @_;
213
($fid1 == $fid && $bid1 > $bid) ||
218
my $code = $stmt1->[3][0];
219
if ($code == S_SWAP || $code == S_CONVERT) {
220
for (my $i = 1; $i < @{$stmt1->[3]}; $i++) {
221
my $c = $stmt1->[3][$i][0];
223
$stmt1->[3][$i][0] = $code2;
225
if ($c == $code2 && $bc == S_SWAP) {
226
$stmt1->[3][$i][0] = $code1;
230
if ($code == $code1) {
231
_convert($ptree, $fid1, $bid1, $sid1,
234
if ($code == $code2 && $bc == S_SWAP) {
235
_convert($ptree, $fid1, $bid1, $sid1,
241
_remove($ptree, $fid, $stmt);
248
# a statement initially abstained from -- if there is no
249
# way to reinstate it, away it goes...
250
if (! $stmt->[1] && ($bc == S_STOP || ! $quantum && ! $postprocess)) {
255
for $s (@$reinstate) {
256
if (_is_const($s->[0])) {
257
$ok = 0 if $stmt->[0] == atoi($s->[0][1]);
265
for $s (@$greinstate) {
268
$ok = 0 if grep {$_ == $bc} @s;
272
_remove($ptree, $fid, $stmt) if $ok;
277
my ($p, $fid, $bid, $sid, $stmt) = @_;
278
$first = $first && $stop if $bid == 1;
284
my ($stmt, $place, $regcon, $quantum) = @_;
285
my $e = $stmt->[$place];
287
if ($ec == E_AND || $ec == E_OR || $ec == E_XOR) {
288
do_expression($e, 1, $regcon, $quantum);
289
if (_is_const($e->[1])) {
290
my $val = $e->[1][1];
291
$val = i_and($val) if $ec == E_AND;
292
$val = i_or($val) if $ec == E_OR;
293
$val = i_xor($val) if $ec == E_XOR;
294
$stmt->[$place] = [E_CONSTANT, $val];
298
if ($ec == E_INTERLEAVE || $ec == E_SELECT || $ec == E_OVERLOAD_RANGE) {
299
do_expression($e, 1, $regcon, $quantum);
300
do_expression($e, 2, $regcon, $quantum);
301
if (_is_const($e->[1]) && _is_const($e->[2])) {
303
if ($ec == E_INTERLEAVE) {
304
$val = i_interleave($e->[1][1], $e->[2][1]);
305
} elsif ($ec == E_SELECT) {
306
$val = i_select($e->[1][1], $e->[2][1]);
308
$stmt->[$place] = [E_CONSTANT, $val];
309
} elsif ($ec == E_SELECT &&
310
($e->[1][0] == E_AND ||
311
$e->[1][0] == E_OR ||
312
$e->[1][0] == E_XOR) &&
313
$e->[1][1][0] == E_INTERLEAVE &&
314
$e->[2][0] == E_CONSTANT &&
315
atoi($e->[2][1]) == 0x55555555)
317
# This is a "binary" logical operator in disguise
318
my $op = $e->[1][0] == E_AND ? E_BAND
319
: $e->[1][0] == E_OR ? E_BOR
321
$stmt->[$place] = [$op, $e->[1][1][1], $e->[1][1][2]];
325
if ($ec == E_SUBSCRIPT) {
328
do_expression($e, $i, $regcon, $quantum);
332
if ($ec == E_OVERLOAD_REGISTER) {
333
do_expression($e, 2, {}, $quantum);
336
# if ($ec == E_OWNER) {
337
# do_expression($e, 2, $regcon, $quantum);
340
if ($ec == E_REGISTER && exists $regcon->{$e->[1] . $e->[2]}) {
341
$stmt->[$place] = [E_CONSTANT, $regcon->{$e->[1] . $e->[2]}[0]];
346
my ($ptree, $fid, $stmt) = @_;
347
my $code = $stmt->[3][0];
348
$stmt->[3][0] = S_NOP;
350
$id = 'come_froms' if $code == S_COME;
351
$id = 'abstain' if $code == S_ABSTAIN;
352
$id = 'gabstain' if $code == S_GABSTAIN;
353
$id = 'reinstate' if $code == S_REINSTATE;
354
$id = 'greinstate' if $code == S_GREINSTATE;
355
return $ptree if $id eq '';
357
my $c = $ptree->{$id};
358
for ($cid = 0; $cid < @$c; $cid++) {
359
if ($c->[$cid][1] == $fid && $c->[$cid][4] == $stmt->[4]) {
360
splice(@$c, $cid, 1);
368
my ($ptree, $fid, $bid, $sid, $stmt, $code) = @_;
369
$stmt->[3][0] = $code;
371
$id = 'come_froms' if $code == S_COME;
372
$id = 'abstain' if $code == S_ABSTAIN;
373
$id = 'gabstain' if $code == S_GABSTAIN;
374
$id = 'reinstate' if $code == S_REINSTATE;
375
$id = 'greinstate' if $code == S_GREINSTATE;
376
return $ptree if $id eq '';
378
my $c = $ptree->{$id};
379
my $l = $stmt->[3][1];
380
$l = $l->[1] if $l->[0] == E_CONSTANT;
381
push @$c, [$stmt->[3][1], $fid, $bid, $sid, $stmt->[4]];
386
my ($ptree, $fid, $bid, $sid, $stmt, $newcode) = @_;
387
_remove($ptree, $fid, $stmt);
388
_add($ptree, $fid, $bid, $sid, $stmt, $newcode);
added
removed
Language/INTERCAL/Optimiser.pm
