clc-intercal 1:1.0~4pre1.-94.-2-3 / usr / share / perl5 / Language / INTERCAL / Optimiser.pm

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;