|
996
|
1 package Language::INTERCAL::Optimiser;
|
|
|
2
|
|
|
3 # Optimiser for INTERCAL bytecode; see also "optimise.iacc"
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Optimiser.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
20 use Language::INTERCAL::ByteCode '1.-94.-2', qw(:BC bc_bytype bc_match);
|
|
|
21
|
|
|
22 sub new {
|
|
|
23 @_ == 1 or croak "Usage: new Language::INTERCAL::Optimiser";
|
|
|
24 my ($class) = @_;
|
|
|
25 bless {
|
|
|
26 rules => [],
|
|
|
27 search => [],
|
|
|
28 }, $class;
|
|
|
29 }
|
|
|
30
|
|
|
31 sub add {
|
|
|
32 @_ == 3 or croak "Usage: OPTIMISER->add(PATTERN, REWRITE)";
|
|
|
33 my ($opt, $pattern, $rewrite) = @_;
|
|
|
34 push @{$opt->{rules}}, [$pattern, $rewrite];
|
|
|
35 delete $opt->{search};
|
|
|
36 $opt;
|
|
|
37 }
|
|
|
38
|
|
|
39 sub optimise {
|
|
|
40 @_ == 2 or croak "Usage: OPTIMISER->optimise(CODE)";
|
|
|
41 my ($opt, $code) = @_;
|
|
|
42 _make_search($opt);
|
|
|
43 _optimise($opt, $code);
|
|
|
44 }
|
|
|
45
|
|
|
46 sub read {
|
|
|
47 @_ == 2 or croak "Usage: OPTIMISER->read(FILEHANDLE)";
|
|
|
48 my ($opt, $fh) = @_;
|
|
|
49 _make_search($opt);
|
|
|
50 my $r = $opt->{rules};
|
|
|
51 $fh->read_binary(pack('v', scalar @$r));
|
|
|
52 for my $i (@$r) {
|
|
|
53 my ($p, $w) = @$i;
|
|
|
54 $fh->read_binary(pack('v/a* v/a*', $p, $w));
|
|
|
55 }
|
|
|
56 my $s = $opt->{search};
|
|
|
57 $fh->read_binary(pack('v', scalar @$s));
|
|
|
58 for my $i (@$s) {
|
|
|
59 $fh->read_binary(pack('v*', scalar @$i, @$i));
|
|
|
60 }
|
|
|
61 }
|
|
|
62
|
|
|
63 sub write {
|
|
|
64 @_ == 2 or croak "Usage: Language::INTERCAL::Optimiser->write(FILEHANDLE)";
|
|
|
65 my ($class, $fh) = @_;
|
|
|
66 my $nr = unpack('v', $fh->write_binary(2)) || 0;
|
|
|
67 my @rules = ();
|
|
|
68 while (@rules < $nr) {
|
|
|
69 my $pl = unpack('v', $fh->write_binary(2));
|
|
|
70 my $p = $fh->write_binary($pl);
|
|
|
71 my $wl = unpack('v', $fh->write_binary(2));
|
|
|
72 my $w = $fh->write_binary($wl);
|
|
|
73 push @rules, [$p, $w];
|
|
|
74 }
|
|
|
75 my $ns = unpack('v', $fh->write_binary(2)) || 0;
|
|
|
76 my @search = ();
|
|
|
77 while (@search < $ns) {
|
|
|
78 my $ni = unpack('v', $fh->write_binary(2));
|
|
|
79 my @i = unpack('v*', $fh->write_binary(2 * $ni));
|
|
|
80 push @search, \@i;
|
|
|
81 }
|
|
|
82 bless {
|
|
|
83 rules => \@rules,
|
|
|
84 search => \@search,
|
|
|
85 }, $class;
|
|
|
86 }
|
|
|
87
|
|
|
88 sub _make_search {
|
|
|
89 my ($opt) = @_;
|
|
|
90 return if exists $opt->{search};
|
|
|
91
|
|
|
92 my $olist = $opt->{rules};
|
|
|
93 my @search = ();
|
|
|
94 for (my $o = 0; $o < @$olist; $o++) {
|
|
|
95 my ($pattern, $rewrite) = @{$olist->[$o]};
|
|
|
96 for my $p (@$pattern) {
|
|
|
97 my ($type, $code) = @$p;
|
|
|
98 next if $code eq '';
|
|
|
99 my $e = substr($code, 0, 1);
|
|
|
100 my @s;
|
|
|
101 if ($type eq 'C') {
|
|
|
102 @s = (ord($e));
|
|
|
103 } else {
|
|
|
104 @s = bc_bytype($e);
|
|
|
105 }
|
|
|
106 push @{$search[$_]}, $o for @s;
|
|
|
107 last;
|
|
|
108 }
|
|
|
109 }
|
|
|
110 $opt->{search} = \@search;
|
|
|
111 }
|
|
|
112
|
|
|
113 sub _optimise {
|
|
|
114 my ($opt, $code) = @_;
|
|
|
115 my $olist = $opt->{rules};
|
|
|
116 return $code unless @$olist;
|
|
|
117 my $search = $opt->{search};
|
|
|
118 return $code unless @$search;
|
|
|
119 my $i = 0;
|
|
|
120 CODE: while ($i < length($code)) {
|
|
|
121 my $c = ord(substr($code, $i, 1));
|
|
|
122 $i++;
|
|
|
123 next unless $search->[$c] && @{$search->[$c]};
|
|
|
124 my $changes = 0;
|
|
|
125 RULE: for my $try (@{$search->[$c]}) {
|
|
|
126 my ($pattern, $rewrite) = @{$opt->{optimise}[$try]};
|
|
|
127 my @match = ();
|
|
|
128 my $start = $i;
|
|
|
129 for my $p (@$pattern) {
|
|
|
130 my ($type, $data) = @$p;
|
|
|
131 next if $data eq '';
|
|
|
132 my $skip;
|
|
|
133 if ($type eq 'C') {
|
|
|
134 # constant chunk of bytecode
|
|
|
135 next RULE if $data ne substr($code, $i, length $data);
|
|
|
136 $skip = length $data;
|
|
|
137 } else {
|
|
|
138 # bytecode pattern matching
|
|
|
139 $skip = bc_match($data, $code, $i);
|
|
|
140 next RULE if ! defined $skip;
|
|
|
141 }
|
|
|
142 push @match, [$i, $skip];
|
|
|
143 $i += $skip;
|
|
|
144 }
|
|
|
145 my $length = $i - $start;
|
|
|
146 # this rule matches - now do the necessary rewriting
|
|
|
147 my $newcode = '';
|
|
|
148 for my $r (@$rewrite) {
|
|
|
149 my ($type, $data) = @$r;
|
|
|
150 if ($type eq 'C') {
|
|
|
151 $newcode .= $data;
|
|
|
152 } else {
|
|
|
153 my ($pos, $skip) = @{$match[$data]};
|
|
|
154 $newcode .= substr($code, $pos, $skip);
|
|
|
155 }
|
|
|
156 }
|
|
|
157 substr($code, $start, $length) = $newcode;
|
|
|
158 $i = 0;
|
|
|
159 next CODE;
|
|
|
160 }
|
|
|
161 }
|
|
|
162 $code;
|
|
|
163 }
|
|
|
164
|
|
|
165 1;
|
