Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Optimiser.pm @ 3553:a2c0fbb7c2b1
<Roujo> revert
author | HackBot |
---|---|
date | Thu, 29 Aug 2013 20:30:48 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::Optimiser; # Optimiser for INTERCAL bytecode; see also "optimise.iacc" # This file is part of CLC-INTERCAL # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved. # CLC-INTERCAL is copyrighted software. However, permission to use, modify, # and distribute it is granted provided that the conditions set out in the # licence agreement are met. See files README and COPYING in the distribution. use strict; use vars qw($VERSION $PERVERSION); ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Optimiser.pm 1.-94.-2") =~ /\s(\S+)$/; use Carp; use Language::INTERCAL::Exporter '1.-94.-2'; use Language::INTERCAL::Splats '1.-94.-2', qw(:SP); use Language::INTERCAL::ByteCode '1.-94.-2', qw(:BC bc_bytype bc_match); sub new { @_ == 1 or croak "Usage: new Language::INTERCAL::Optimiser"; my ($class) = @_; bless { rules => [], search => [], }, $class; } sub add { @_ == 3 or croak "Usage: OPTIMISER->add(PATTERN, REWRITE)"; my ($opt, $pattern, $rewrite) = @_; push @{$opt->{rules}}, [$pattern, $rewrite]; delete $opt->{search}; $opt; } sub optimise { @_ == 2 or croak "Usage: OPTIMISER->optimise(CODE)"; my ($opt, $code) = @_; _make_search($opt); _optimise($opt, $code); } sub read { @_ == 2 or croak "Usage: OPTIMISER->read(FILEHANDLE)"; my ($opt, $fh) = @_; _make_search($opt); my $r = $opt->{rules}; $fh->read_binary(pack('v', scalar @$r)); for my $i (@$r) { my ($p, $w) = @$i; $fh->read_binary(pack('v/a* v/a*', $p, $w)); } my $s = $opt->{search}; $fh->read_binary(pack('v', scalar @$s)); for my $i (@$s) { $fh->read_binary(pack('v*', scalar @$i, @$i)); } } sub write { @_ == 2 or croak "Usage: Language::INTERCAL::Optimiser->write(FILEHANDLE)"; my ($class, $fh) = @_; my $nr = unpack('v', $fh->write_binary(2)) || 0; my @rules = (); while (@rules < $nr) { my $pl = unpack('v', $fh->write_binary(2)); my $p = $fh->write_binary($pl); my $wl = unpack('v', $fh->write_binary(2)); my $w = $fh->write_binary($wl); push @rules, [$p, $w]; } my $ns = unpack('v', $fh->write_binary(2)) || 0; my @search = (); while (@search < $ns) { my $ni = unpack('v', $fh->write_binary(2)); my @i = unpack('v*', $fh->write_binary(2 * $ni)); push @search, \@i; } bless { rules => \@rules, search => \@search, }, $class; } sub _make_search { my ($opt) = @_; return if exists $opt->{search}; my $olist = $opt->{rules}; my @search = (); for (my $o = 0; $o < @$olist; $o++) { my ($pattern, $rewrite) = @{$olist->[$o]}; for my $p (@$pattern) { my ($type, $code) = @$p; next if $code eq ''; my $e = substr($code, 0, 1); my @s; if ($type eq 'C') { @s = (ord($e)); } else { @s = bc_bytype($e); } push @{$search[$_]}, $o for @s; last; } } $opt->{search} = \@search; } sub _optimise { my ($opt, $code) = @_; my $olist = $opt->{rules}; return $code unless @$olist; my $search = $opt->{search}; return $code unless @$search; my $i = 0; CODE: while ($i < length($code)) { my $c = ord(substr($code, $i, 1)); $i++; next unless $search->[$c] && @{$search->[$c]}; my $changes = 0; RULE: for my $try (@{$search->[$c]}) { my ($pattern, $rewrite) = @{$opt->{optimise}[$try]}; my @match = (); my $start = $i; for my $p (@$pattern) { my ($type, $data) = @$p; next if $data eq ''; my $skip; if ($type eq 'C') { # constant chunk of bytecode next RULE if $data ne substr($code, $i, length $data); $skip = length $data; } else { # bytecode pattern matching $skip = bc_match($data, $code, $i); next RULE if ! defined $skip; } push @match, [$i, $skip]; $i += $skip; } my $length = $i - $start; # this rule matches - now do the necessary rewriting my $newcode = ''; for my $r (@$rewrite) { my ($type, $data) = @$r; if ($type eq 'C') { $newcode .= $data; } else { my ($pos, $skip) = @{$match[$data]}; $newcode .= substr($code, $pos, $skip); } } substr($code, $start, $length) = $newcode; $i = 0; next CODE; } } $code; } 1;