Transforming Syntax – optimizer example

gistfile1.pl

use strict; use warnings; use 5.010;
 
my $ast = bless( [
                 [
                   bless( [
                            bless( [
                                     bless( [
                                              bless( ['Myvalue.xyz'], 'Ast::Var' ),
                                              '==',
                                              bless( ['1'], 'Ast::Literal' )
                                            ], 'Ast::Binop' ),
                                     'Or',
                                     bless( [
                                              bless( ['Frmae_1.signal_1'], 'Ast::Var' ),
                                              '==',
                                              bless( ['1'], 'Ast::Literal' )
                                            ], 'Ast::Binop' )
                                   ], 'Ast::Binop' ),
                            bless( [
                                     bless( ['a'], 'Ast::Var' ),
                                     '=',
                                     bless( ['1'], 'Ast::Literal' )
                                   ], 'Ast::Binop' ),
                            bless( [
                                     bless( ['a'], 'Ast::Var' ),
                                     '=',
                                     bless( ['0'], 'Ast::Literal' )
                                   ], 'Ast::Binop' )
                          ], 'Ast::Cond' )
                 ]
               ], 'Ast::Block' );
 
say $ast->simplify->prettyprint;
 
 
# AST classes below
 
package Ast;
    use Scalar::Util qw/blessed/;
 
    sub new {
        my ($class, @args) = @_;
        bless \@args => $class;
    }
    sub childs { @{ shift() } }
    
    sub prettyprint {
        my ($self, $indent) = @_;
        $indent //= 0;  # initialize $indent if no value passed
        $indent++;      # increment indent level
		my $items = join "\n",         # concatenate items with newline in between
            map { "  "x$indent . $_ }  # pad the items with correct intendation
            map { blessed($_) && $_->can("prettyprint") ? $_->prettyprint($indent) : $_ } $self->childs;
        my $type = ref $self;
        return "$type(\n" . $items . " )";
    }

    sub simplify {
        my $self = shift;
        my @childs = map {blessed($_) && $_->can("simplify") ? $_->simplify : $_}  $self->childs;
        ref($self)->new(@childs);
    }
 
package Ast::Binop;
    use parent -norequire, 'Ast';
 
    sub l   { shift()->[0] }
    sub op  { shift()->[1] }
    sub r   { shift()->[2] }
 
package Ast::Var;
    use parent -norequire, 'Ast';
 
    sub name { shift()->[0] }
 
    sub prettyprint {
        my $self = shift;
		'${' . $self->name . '}';
    }
 
package Ast::Cond;
    use parent -norequire, 'Ast';
 
    sub cond { shift()->[0] }
    sub then { shift()->[1] }
    sub else { shift()->[2] }

    sub prettyprint {
        my ($self, $indent) = @_;
        $indent //= 0;
		my ($cond, $then, $else) =
            map { Scalar::Util::blessed($_) && $_->can("prettyprint") ? $_->prettyprint($indent) : $_ } 
				$self->childs;
        return "if $cond\n"
			. "  "x$indent . "then $then\n"
			. "  "x$indent . "else $else";
    }

    sub simplify {
        my $self = shift;
        my ($cond, $then, $else) = @$self;

        if (
            not( grep not($_->isa('Ast::Binop') && $_->op eq '=' && $_->l->isa('Ast::Var')), $then, $else) and
            $then->l->name eq $else->l->name
        ) {
            return Ast::Binop->new(
                $then->l->simplify,
                '=',
                Ast::Cond->new($cond->simplify, $then->r->simplify, $else->r->simplify),
            );
        }
		# else: just do what would have been done by default
        return $self->SUPER::simplify;
    }
 
package Ast::Block;
    use parent -norequire, 'Ast';
 
    sub contents { shift()->[0] }
 
    sub new { 
        my ($class, @items) = @_;
		$class->SUPER::new(\@items);
    }
    sub childs { @{ shift()->contents } }
 
package Ast::Literal;
    use parent -norequire, 'Ast';
 
    sub val { shift()->[0] }
 
    sub prettyprint {
        my $self = shift;
		my $val = $self->val // return "undef";
		return qq("$val");
    }