src/jdesugar4.pl

#!/usr/bin/env perl
# jdesugar4 -- the nscc desugaring stage, fifth stage of the nscc
# pipeline. owns: while -> label+goto+if, switch -> a compare
# chain of nested ifs (each case independent -- nsc switch does NOT
# fall through, the one deliberate departure from c89; break still
# works, jumping past the rest of the chain), ?: -> if+assign with a
# fresh tmp, &&/|| -> short-circuit ifs with a fresh tmp, ! -> == 0,
# compound assignment -> simple assignment (the lhs is read twice:
# with no structs or arrays an nsc lvalue expression can have no side
# effects, so that is always correct), ++/-- -> load/op/store with a
# tmp holding the pre/post value, break/continue -> goto the nearest
# loop's/switch's exit/continue label. everything else is carried
# through untouched, type annotations included.
#
# output format .cast.j4: a FLAT statement list per function body
# (blocks are gone) using only { decl, assign, call, icall, if, goto,
# label, return } statements -- expression nodes are still full trees
# (jlower5 flattens those), all still carrying their ': T' atoms from
# jtype3. j4-created tmps are decls with negative sym ids (sym=-1,
# -2, ...), so a generated tmp can never collide with a real symbol;
# labels are per-function, numbered L0, L1, ... in creation order.
#
# this stage's own mini pipeline: in -- preproc -- proc -- out, where
# preproc is the tast deserialization and proc is the desugar proper.
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use jcplib::util qw(stage_err);
use jcplib::tree qw(read_tree write_tree mk find_kid);
 
my $RAW = do { local $/; <STDIN>; };
my $FILE = $ENV{NSCC_FILE} || 'input';
 
sub err_at {
	my ($node, $msg) = @_;
	my ($at) = grep { /^at=/ } @{$node->{atoms}};
	$at //= 'at=?:?';
	$at =~ s/^at=//;
	stage_err("jdesugar4: $FILE:$at: $msg");
}
 
sub type_of {
	my ($node) = @_;
	my $atoms = $node->{atoms};
	return $atoms->[-1] if @$atoms && $atoms->[-2] && $atoms->[-2] eq ':';
	return undef;
}
 
 
my $LABEL_N;    # next label number
my $TMP_N;      # next tmp sym id (negative)
my @BRK;        # innermost break target
my @CONT;       # innermost continue target (loops only)
 
sub new_label { return 'L' . $LABEL_N++; }
sub new_tmp { return --$TMP_N; }
 
sub mk_tmp_decl {
	my ($t) = @_;
	return mk('decl', ["tmp", $t, "sym=" . new_tmp()], []);
}
 
sub ref_of {
	my ($sym_atom, $t) = @_;
	return {op => 'ref', atoms => [$sym_atom, ':', $t], kids => []};
}
 
sub mk_assign {
	my ($ref, $expr) = @_;
	return mk('assign', ['='], [$ref, $expr]);
}
 
# (cast T (intlit V : i32) : T) -- the one typed constant form j4
# builds itself (j4 never emits a bare intlit: an intlit without a
# cast has no width of its own and jlower5 would have to guess).
sub mk_const {
	my ($v, $t) = @_;
	my $lit = {op => 'intlit', atoms => [$v, ':', 'i32'], kids => []};
	return {op => 'cast', atoms => [$t, ':', $t], kids => [$lit]};
}
 
sub tmp_id_of {
	my ($decl) = @_;
	return ($decl->{atoms}[-1] =~ /^sym=(-?\d+)$/ ? $1 : undef);
}
 
sub has_call {
	my ($n) = @_;
	return 0 unless ref $n;
	return 1 if $n->{op} eq 'call' || $n->{op} eq 'icall';
	for my $k (@{$n->{kids}}) { return 1 if has_call($k); }
	return 0;
}
 
# a rewritten assign/++/-- reads its deref lvalue's address expression
# twice (once per side of "x = x op e"); when that expression contains
# a call, reading it twice would run the call twice -- bind it to a
# fresh ptr tmp first, so the call (and everything under it) runs once.
# a member/index lvalue with a call-ful base cannot be bound (an lvalue
# has no pointer-to-it tmp in nsc), so that case is an error.
sub bind_lvalue_addr {
	my ($ld) = @_;
	if(($ld->{op} eq 'member' || $ld->{op} eq 'index') && has_call($ld)) {
		err_at($ld, '++/-- or compound assignment through a member/index whose base contains a call: copy the base to a tmp first');
	}
	if($ld->{op} eq 'deref' && has_call($ld->{kids}[0])) {
		my $tmp = mk_tmp_decl('ptr');
		my $id = tmp_id_of($tmp);
		my $addr = ref_of("sym=$id", 'ptr');
		my $new = {op => 'deref', atoms => [':', 'i64'], kids => [ref_of("sym=$id", 'ptr')]};
		return ($new, $tmp, mk_assign($addr, $ld->{kids}[0]));
	}
	return ($ld);
}
 
 
sub ds_expr {
	my ($e) = @_;
	my $op = $e->{op};
 
	if($op eq 'binop') {
		my $bop = $e->{atoms}[0];
		if($bop eq '&&' || $bop eq '||') {
			my ($ld, @ls) = ds_expr($e->{kids}[0]);
			my ($rd, @rs) = ds_expr($e->{kids}[1]);
			my $tmp = mk_tmp_decl('i32');
			my $id = tmp_id_of($tmp);
			my $ref = ref_of("sym=$id", 'i32');
			my $set1 = mk_assign(ref_of("sym=$id", 'i32'), mk_const(1, 'i32'));
			my $set0 = mk_assign(ref_of("sym=$id", 'i32'), mk_const(0, 'i32'));
			my $outer;
			if($bop eq '&&') {
				# tmp=0; if a [ <b's stmts> if b [ tmp=1 ] ]  -- b
				# (and everything its evaluation produced) only
				# runs when a already held.
				my $inner = mk('if', [], [$rd, $set1]);
				$outer = mk('if', [], [$ld, @rs, $inner]);
			}
			else {
				# tmp=1; if a [] else [ <b's stmts> if b [] else
				# [ tmp=0 ] ]
				my $inner = mk('if', [], [$rd]);
				push @{$inner->{kids}}, mk('else', [], [$set0]);
				$outer = mk('if', [], [$ld]);
				push @{$outer->{kids}}, mk('else', [], [@rs, $inner]);
			}
			my $init = mk_assign(ref_of("sym=$id", 'i32'), $bop eq '&&' ? mk_const(0, 'i32') : mk_const(1, 'i32'));
			return ($ref, $tmp, $init, @ls, $outer);
		}
		my ($l, @ls) = ds_expr($e->{kids}[0]);
		my ($r, @rs) = ds_expr($e->{kids}[1]);
		return ({op => 'binop', atoms => [@{$e->{atoms}}], kids => [$l, $r]}, @ls, @rs);
	}
 
	if($op eq 'unop' && $e->{atoms}[0] eq '!') {
		my ($x, @xs) = ds_expr($e->{kids}[0]);
		my $zero = mk_const(0, 'i64');
		return ({op => 'binop', atoms => ['==', ':', 'i32'], kids => [$x, $zero]}, @xs);
	}
 
	if($op eq 'unop') {
		my ($x, @xs) = ds_expr($e->{kids}[0]);
		return ({op => 'unop', atoms => [@{$e->{atoms}}], kids => [$x]}, @xs);
	}
 
	if($op eq 'cond') {
		my ($cd, @cs) = ds_expr($e->{kids}[0]);
		my ($td, @ts) = ds_expr($e->{kids}[1]);
		my ($fd, @fs) = ds_expr($e->{kids}[2]);
		my $ty = type_of($e);
		my $tmp = mk_tmp_decl($ty);
		my $id = tmp_id_of($tmp);
		my $ref = ref_of("sym=$id", $ty);
		# each arm's own desugared stmts run INSIDE its branch (an
		# arm of ?: is only ever evaluated when taken).
		my $if = mk('if', [], [$cd, @ts, mk_assign(ref_of("sym=$id", $ty), $td)]);
		push @{$if->{kids}}, mk('else', [], [@fs, mk_assign(ref_of("sym=$id", $ty), $fd)]);
		return ($ref, $tmp, @cs, $if);
	}
 
	if($op eq 'assign') {
		my ($ld, @ls) = ds_expr($e->{kids}[0]);
		my ($rd, @rs) = ds_expr($e->{kids}[1]);
		my $aop = $e->{atoms}[0];
		if($aop eq '=') {
			return (mk('assign', ['='], [$ld, $rd]), @ls, @rs);
		}
		# x op= e  ->  x = x op e (the lhs is read twice; a deref
		# whose address expression contains a call gets bound to a
		# ptr tmp first so the call can only run once).
		my ($bound, @bs) = bind_lvalue_addr($ld);
		my $top = $aop eq '<<=' ? '<<' : $aop eq '>>=' ? '>>' : substr($aop, 0, 1);
		my $lt = type_of($e->{kids}[0]);
		my $bin = mk('binop', [$top, ':', $lt], [$bound, $rd]);
		return (mk('assign', ['='], [$bound, $bin]), @ls, @bs, @rs);
	}
 
	if($op eq 'preinc' || $op eq 'postinc' || $op eq 'predec' || $op eq 'postdec') {
		my ($ld, @ls) = ds_expr($e->{kids}[0]);
		my ($bound, @bs) = bind_lvalue_addr($ld);
		my $ty = type_of($e);
		my $lt = type_of($e->{kids}[0]);
		my $one = mk_const(1, $lt);
		my $opc = $op =~ /inc/ ? '+' : '-';
		my $add = mk('binop', [$opc, ':', $lt], [$bound, $one]);
		my $tmp = mk_tmp_decl($ty);
		my $id = tmp_id_of($tmp);
		my $ref = ref_of("sym=$id", $ty);
		if($op eq 'preinc' || $op eq 'predec') {
			return ($ref, $tmp, @ls, @bs, mk_assign(ref_of("sym=$id", $ty), $add), mk_assign($bound, $add));
		}
		return ($ref, $tmp, @ls, @bs, mk_assign(ref_of("sym=$id", $ty), $bound), mk_assign($bound, $add));
	}
 
	if($op eq 'call' || $op eq 'icall' || $op eq 'addr' || $op eq 'deref' || $op eq 'cast' || $op eq 'member' || $op eq 'index') {
		my (@stmts, @kids);
		for my $k (@{$e->{kids}}) {
			my ($kd, @ks) = ds_expr($k);
			push @kids, $kd;
			push @stmts, @ks;
		}
		return ({op => $op, atoms => [@{$e->{atoms}}], kids => \@kids}, @stmts);
	}
 
	if($op eq 'initlist') {
		my (@stmts, @kids);
		for my $k (@{$e->{kids}}) {
			my ($kd, @ks) = ds_expr($k);
			push @kids, $kd;
			push @stmts, @ks;
		}
		return ({op => 'initlist', atoms => [], kids => \@kids}, @stmts);
	}
 
	# leaves: ref/intlit/charlit/strlit -- unchanged.
	return ($e);
}
 
 
sub ds_stmt_list {
	my ($stmts, $out) = @_;
	ds_stmt($_, $out) for @$stmts;
	return;
}
 
sub ds_stmt {
	my ($s, $out) = @_;
	my $op = $s->{op};
 
	if($op eq 'block') {
		ds_stmt_list($s->{kids}, $out);
		return;
	}
	if($op eq 'decl') {
		my $init = find_kid($s, 'init');
		my @kids;
		if($init) {
			my ($id, @st) = ds_expr($init->{kids}[0]);
			push @$out, @st;
			push @kids, mk('init', [], [$id]);
		}
		push @$out, {op => 'decl', atoms => [@{$s->{atoms}}], kids => \@kids};
		return;
	}
	if($op eq 'stmt') {
		my ($ed, @st) = ds_expr($s->{kids}[0]);
		push @$out, @st;
		# a call or assign IS the side effect and keeps its node;
		# a bare tmp ref (the result value of a ++/-- expression
		# statement) has nothing left to do, its effects already ran
		# in @st, so the discarded result is dropped.
		if($ed->{op} eq 'assign' || $ed->{op} eq 'call' || $ed->{op} eq 'icall') { push @$out, $ed; }
		return;
	}
	if($op eq 'assign') {
		my ($ed, @st) = ds_expr($s);
		push @$out, @st, $ed;
		return;
	}
	if($op eq 'ret') {
		if(@{$s->{kids}}) {
			my ($ed, @st) = ds_expr($s->{kids}[0]);
			push @$out, @st;
			push @$out, {op => 'ret', atoms => [@{$s->{atoms}}], kids => [$ed]};
		}
		else {
			push @$out, {op => 'ret', atoms => [@{$s->{atoms}}], kids => []};
		}
		return;
	}
	if($op eq 'if') {
		my ($cd, @cs) = ds_expr($s->{kids}[0]);
		push @$out, @cs;
		my @then;
		ds_stmt($s->{kids}[1], \@then);
		my $node = mk('if', [], [$cd, @then]);
		if(@{$s->{kids}} > 2) {
			my @else;
			ds_stmt($s->{kids}[2]{kids}[0], \@else);
			push @{$node->{kids}}, mk('else', [], \@else);
		}
		push @$out, $node;
		return;
	}
	if($op eq 'while') {
		# the condition is re-desugared (ds_expr called again) rather
		# than reusing a single ($cd, @cs) computed once outside the
		# loop -- a &&/|| condition's @cs is real statements (the
		# flag init + short-circuit ifs from ds_expr's &&/|| case, see
		# above) that must re-run on EVERY check, not just the first:
		# with a single @cs emitted once before l_cond, every re-entry
		# via the bottom-of-loop goto only re-tested the stale flag
		# left over from the first evaluation, so "while(j<8 &&
		# arr[j]!=0)" never noticed arr[j] becoming 0 and looped
		# forever. re-running ds_expr per check (cheap -- it just
		# rebuilds ast nodes, no side effects of its own) keeps @cs
		# and its label needs fresh each time, same as the condition
		# itself would be re-evaluated in any other compiler's ir.
		my $l_cond = new_label();
		my $l_end = new_label();
		push @BRK, $l_end;
		push @CONT, $l_cond;
		push @$out, mk('label', [$l_cond], []);
		my ($cd, @cs) = ds_expr($s->{kids}[0]);
		push @$out, @cs;
		my @body;
		ds_stmt($s->{kids}[1], \@body);
		my $node = mk('if', [], [$cd, @body]);
		push @{$node->{kids}}, mk('else', [], [mk('goto', [$l_end], [])]);
		push @$out, $node;
		push @$out, mk('goto', [$l_cond], []);
		push @$out, mk('label', [$l_end], []);
		pop @CONT;
		pop @BRK;
		return;
	}
	if($op eq 'switch') {
		my ($ed, @es) = ds_expr($s->{kids}[0]);
		my $l_end = new_label();
		push @BRK, $l_end;
		push @$out, @es;
		my @entries = @{$s->{kids}}[1 .. $#{$s->{kids}}];
		my @cases = grep { $_->{op} eq 'case' } @entries;
		my ($def) = grep { $_->{op} eq 'default' } @entries;
		my $chain;
		# inside-out, so case order survives as an if/else-if chain;
		# default (if any) is the innermost else.
		for my $i (reverse 0 .. $#cases) {
			my @body;
			ds_stmt_list([@{$cases[$i]{kids}}[1 .. $#{$cases[$i]{kids}}]], \@body);
			# the compare chain's condition, cast to i64 exactly the
			# way jtype3 casts every other if condition (a j4-built
			# if must follow the same rule: an if condition is always
			# an i64).
			my $cmp = mk('binop', ['==', ':', 'i32'], [$ed, $cases[$i]{kids}[0]]);
			my $cond = mk('cast', ['i64', ':', 'i64'], [$cmp]);
			my $node = mk('if', [], [$cond, @body]);
			if($chain) {
				push @{$node->{kids}}, mk('else', [], [$chain]);
			}
			elsif($def) {
				my @d;
				ds_stmt_list($def->{kids}, \@d);
				push @{$node->{kids}}, mk('else', [], \@d);
			}
			$chain = $node;
		}
		if($chain) {
			push @$out, $chain;
		}
		elsif($def) {
			my @d;
			ds_stmt_list($def->{kids}, \@d);
			push @$out, @d;
		}
		push @$out, mk('label', [$l_end], []);
		pop @BRK;
		return;
	}
	if($op eq 'break') {
		err_at($s, "'break' outside any loop or switch") unless @BRK;
		push @$out, mk('goto', [$BRK[-1]], []);
		return;
	}
	if($op eq 'continue') {
		err_at($s, "'continue' outside any loop") unless @CONT;
		push @$out, mk('goto', [$CONT[-1]], []);
		return;
	}
	if($op eq 'goto' || $op eq 'label') {
		push @$out, $s;
		return;
	}
	stage_err("jdesugar4: unknown statement node: $op");
}
 
sub preproc {
	my ($text) = @_;
	return read_tree($text);
}
 
sub proc {
	my ($unit) = @_;
	for my $top (@{$unit->{kids}}) {
		next unless $top->{op} eq 'func';
		my $body = find_kid($top, 'body');
		$LABEL_N = 0;
		$TMP_N = 0;
		@BRK = ();
		@CONT = ();
		my @out;
		ds_stmt_list($body->{kids}, \@out);
		$body->{kids} = \@out;
	}
	return write_tree($unit);
}
 
print proc(preproc($RAW));