dizzy 0.3-2 / usr / share / perl5 / Dizzy / Perl2GLSL.pm

package Dizzy::Perl2GLSL;

use strict;
use warnings;
use 5.010;

use B;

sub walk_optree {
	my ($op, $cv) = @_;

	# gather op information
	my $optype = ref($op);
	$optype =~ s/^B:://;
	my $opname = $op->name;

	if ($optype ~~ [qw(UNOP BINOP LISTOP LOGOP)]) {
		my @list = $op->name;

		my $child = $op->first;
		while (ref($child) ne "B::NULL") {
			push(@list, walk_optree($child, $cv));

			# and go on with the next one
			$child = $child->sibling;
		}

		if ($op->name eq "null" or $op->name eq "leavesub") {
			return @list[1..$#list];
		} else {
			return [@list];
		}
	} elsif ($opname eq "const") {
		if ($op->sv->isa("B::SV")) {
			# unthreaded perl
			return ${$op->sv->object_2svref};
		} else {
			# threaded perl
			return ${(($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ]->object_2svref};
		}
	} elsif ($opname eq "gv") {
		if ($op->gv->isa("B::GV")) {
			# unthreaded perl
			return ["glob", $op->gv->NAME, $op->gv];
		} else {
			# threaded perl
			my $pad = (($cv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
			return ["glob", $pad->NAME, $pad];
		}
	} elsif ($optype eq "OP") {
		if ($op->name eq "padsv") {
			return "var" . $op->targ;
		} else {
			return ();
		}
	} elsif ($optype eq "COP") {
		return ();
	}
}

# check if a trivial optimization can be applied
# if the op looks like it's been generated by code like
#     my $dist = sqrt($x**2 + $y**2);
# then return 1.
sub opt_check_dist_assignment {
	my ($op, $symtab) = @_;
	my @op = @{$op};

	return 0 if (ref($op[1]) eq "");                               # RHS is scalar
	return 0 if ($op[1]->[0] ne "sqrt");                           # not the sqrt function
	return 0 if (ref($op[1]->[1]) eq "");                          # scalar in sqrt

	my @arg = @{$op[1]->[1]};
	return 0 if ($arg[0] ne "add");                                # no addition
	return 0 if (ref($arg[1]) eq "" or ref($arg[2]) eq "");        # addition with a scalar
	return 0 if ($arg[1]->[0] ne "pow" or $arg[2]->[0] ne "pow");  # not adding two powers ($x**2 + $y**2)
	return 0 if ($arg[1]->[2] != 2 or $arg[2]->[2] != 2);          # not squaring the arguments

	if ($symtab->{$arg[1]->[1]} ne "coord_x"
	 or $symtab->{$arg[2]->[1]} ne "coord_y") {
		return 0;
	}

	# assume it is dist assignment
	return 1;
}

# check for inline functions to be expanded
sub opt_check_inline_builtin {
	my ($op, $symtab) = @_;
	my @op = @{$op};

	if ($op[$#op]->[1] eq "cosec") {
		return '(1. / sin(@))';
	} elsif ($op[$#op]->[1] =~ /^(asin|tan)$/) {
		return "$1(\@)";
	} else {
		return undef;
	}
}

sub make_code {
	my ($op, $symtab, $in_sub) = @_;
	$in_sub ||= 0;

	# not a ref? then it's a scalar
	if (ref($op) eq "") {
		# turn integers into floats..
		if ($op =~ /^\d+$/) {
			$op .= ".";
		}
		return $op;
	}

	# else it's a subexpression
	my @op = @{$op};
	if ($op[0] eq "lineseq") {
		# all child expressions are statements
		return join(";\n", map { make_code($_, $symtab, $in_sub) } @op[1..$#op]) . ";";
	} elsif ($op[0] eq "cond_expr") {
		# conditional expression
		return "(" . make_code($op[1], $symtab, $in_sub) . " ? " . make_code($op[2], $symtab, $in_sub) . " : " . make_code($op[3], $symtab, $in_sub) . ")";
	} elsif ($op[0] eq "glob") {
		return "GLOB?!";
	} elsif ($op[0] eq "return") {
		# return a value - behaviour depends on if we're in main() or not
		if ($in_sub) {
			# just return the value in question
			return "return " . make_code($op[1], $symtab, $in_sub);
		} else {
			# assign to the fragment color and return
			return "float retval = " . make_code($op[1], $symtab, $in_sub) . "; gl_FragColor = vec4(vec3(retval), 1.0)";
		}
	} elsif ($op[0] eq "entersub") {
		# external subroutine call: last child is the sub, rest is arguments
		my $code = opt_check_inline_builtin($op, $symtab);
		if (defined($code)) {
			# substitute the inline code and return
			$code =~ s/\@/join(", ", map { make_code($_, $symtab, $in_sub) } @op[1..$#op-1])/e;
			return $code;
		} else {
			# register the subroutine name and the associated code
			$symtab->{$op[$#op]->[1]} = "subroutine code:" . perl2glsl($op[$#op]->[2]->CV, $op[$#op]->[1]);
			return $op[$#op]->[1] . "(" . join(", ", map { make_code($_, $symtab, $in_sub) } @op[1..$#op-1]) . ")";
		}
	} elsif ($op[0] eq "sassign") {
		# scalar assignment
		my $allocate = defined($symtab->{$op[2]}) ? "" : "float ";
		$symtab->{$op[2]} = 1;
		if (opt_check_dist_assignment($op, $symtab)) {
			return "$allocate$op[2] = length(gl_TexCoord[0].xy - 0.5)";
		} else {
			return "$allocate$op[2] = " . make_code($op[1], $symtab, $in_sub);
		}
	} elsif ($op[0] eq "aassign") {
		# list assignment
		# for now, only allow parameter assignment for this and reject everything else
		if ($op[1]->[0] ne "rv2av" or ref($op[1]->[1]) ne "ARRAY" or $op[1]->[1]->[0] ne "glob" or $op[1]->[1]->[1] ne "_") {
			return "ERROR";
		}
		if ($in_sub) {
			foreach (2..$#op) {
				$symtab->{$op[$_]} = "argument_" . ($_ - 2);
			}
			return "1";
		} else {
			$symtab->{$op[2]} = "coord_x";
			$symtab->{$op[3]} = "coord_y";
			return "float $op[2] = gl_TexCoord[0].x - 0.5; float $op[3] = gl_TexCoord[0].y - 0.5";
		}

	} elsif ($op[0] =~ /^(add|subtract|multiply|divide|[lg][te])$/) {
		my $operator = {
			add => "+", subtract => "-", multiply => "*", divide => "/",
			"lt" => "<", "gt" => ">", "le" => "<=", "ge" => ">=",
		}->{$op[0]};
		return "(" . make_code($op[1], $symtab, $in_sub) . " $operator " . make_code($op[2], $symtab, $in_sub) . ")";
	} elsif ($op[0] eq "negate") {
		return "-(" . make_code($op[1], $symtab, $in_sub) . ")";

	} elsif ($op[0] ~~ [qw(sqrt sin cos pow log abs)]) {
		# builtin functions
		return "$op[0](" . join(", ", map { make_code($_, $symtab, $in_sub) } @op[1..$#op]) . ")";
	} else {
		return "UNKNOWN_$op[0]_OP";
	}
}

sub perl2glsl {
	my ($coderef, $in_sub) = @_;
	$in_sub ||= 0;

	# generate an optree suitable for further processing - if needed
	my $cv;
	if (ref($coderef) ne "B::CV") {
		$cv = B::svref_2object($coderef);
	} else {
		$cv = $coderef;
	}
	my $tree = walk_optree($cv->ROOT, $cv);

	# walk the optree, generating code out of it
	my $symtab = {};
	my $code = make_code($tree, $symtab, $in_sub);

	# get any subroutine definitions out and prepend them to the shader code
	my $subdefs = join("\n", map { /^subroutine code:(.*)$/s } grep { /^subroutine code:/ } values(%{$symtab}));

	# now if we've been generating code for a subroutine, generate the parameter list
	if ($in_sub) {
		my @params = sort { $symtab->{$a} cmp $symtab->{$b} } grep { $symtab->{$_} =~ /^argument_/ } keys(%{$symtab});
		return "float $in_sub(float " . join(", float ", @params) . ") { $code }\n";
	} else {
		return $subdefs . "void main() { $code }\n";
	}
}

1;