src/jalloc7.pl

#!/usr/bin/env perl
# jalloc7 -- the nscc register-allocation stage, eighth stage of the
# nscc pipeline. owns: virtual reg -> physical location, using the
# dumb strategy described in docs/ir.btft: EVERY vreg gets its own 8-byte
# stack slot (no liveness analysis, no spilling decisions, nothing
# clever -- slow, but correct and done), and real registers appear
# only where a single instruction immediately needs one: %rax as the
# scratch for almost everything, %rcx for deref addresses, shift
# counts and idiv divisors, %rdi/%rsi/%rdx/%rcx/%r8/%r9 for call args,
# %r11 for an indirect call's target address (loaded right after the
# args, right before the call -- it collides with none of the above),
# %rax for call results and returns. every mir0 line expands to a
# short fixed sequence of mir1 lines, self-contained -- nothing in one
# instruction's expansion assumes anything about the previous one's
# register contents except the cmp/setcc flag handoff, which the two
# adjacent lines guarantee.
#
# output format .mir1.j7: same shapes as .mir0.j6 but with concrete
# physical locations instead of vregs. slots: a local %vN lives at
# -8(N+1)(%rbp); a vreg %rN lives at -8(locals+N+1)(%rbp). both
# mir0 operand orderings survive: "%rN = op ..." (dst first) and
# "op ..., %rN" (dst last) parse to the same mir1.
#
# this stage's own mini pipeline: in -- preproc -- proc -- out, where
# preproc is the mir0 deserialization and proc is the allocation.
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use jcplib::util qw(stage_err);
 
my $RAW = do { local $/; <STDIN>; };
 
my @ARGREG = qw(%rdi %rsi %rdx %rcx %r8 %r9);
 
sub lerr {
	my ($line, $msg) = @_;
	stage_err("jalloc7: $msg in mir0 line: $line");
}
 
sub clean {
	my ($ln) = @_;
	$ln =~ s/^     //;
	return $ln;
}
 
my $TARGET;     # the optional target header line, passed through verbatim
 
sub preproc {
	my ($t) = @_;
	my @l = grep { /\S/ } split /\n/, $t;
	if(@l && $l[0] =~ /^target \S+( \S+=\S+)*$/) {
		$TARGET = shift @l;
	}
	return \@l;
}
 
sub proc {
	my ($lines) = @_;
	my @out;
	$TARGET //= '';
	push @out, $TARGET if $TARGET ne '';
	my $nloc = 0;
	my $argi = 0;     # outgoing call args
	my $argpi = 0;    # incoming function params
	my $slot = sub {
		my ($x) = @_;
		return $x =~ /^%r(\d+)$/ ? (-8 * ($nloc + $1 + 1)) . '(%rbp)' : $x;
	};
	my $e = sub { push @out, @_; return; };
 
	for my $l0 (@$lines) {
		my $l = clean($l0);
		if($l =~ /^func (\S+) sym=(\d+) linkage=(\S+) ret=(\S+) frame=(\d+) locals=(\d+) vregs=(\d+)$/) {
			$nloc = $6;
			$argi = 0;
			$argpi = 0;
			$e->($l);
			next;
		}
		if($l eq 'end' || $l =~ /^gvar /) {
			$e->($l);
			next;
		}
		if($l =~ /^str / || $l =~ /^label / || $l =~ /^goto / || $l =~ /^jcc / || $l =~ /^jmp /) {
			$e->($l);
			next;
		}
		if($l =~ /^call (\S+)$/) {
			$e->($l);
			$argi = 0;
			next;
		}
		if($l =~ /^icall (%r\d+)$/) {
			# indirect call: the target address loads into %r11 --
			# sysv's own scratch register, never an arg register
			# (%rdi..%r9 are already holding this call's args, loaded
			# by the arg lines just above), never the result (%rax),
			# and never %rcx (arg 4). then call through it.
			$e->("movq " . $slot->($1) . ", %r11", "icall %r11");
			$argi = 0;
			next;
		}
		if($l =~ /^argp (\S+) (-?\d+\(%rbp\))$/) {
			# incoming arg spill: the i-th argp of the function
			# comes from the i-th sysv arg register, in order.
			$e->("st $1 $ARGREG[$argpi], $2");
			$argpi++;
			next;
		}
 
		# "%rN = OP ..." (dst first) vs "OP ..., %rN" (dst last).
		my $dst;
		if($l =~ /^(%r\d+) = (.*)$/) { $dst = $1; $l = $2; }
		my @f = grep { length } split /[ ,]+/, $l;
		my $sdst = sub { return $slot->($dst); };
 
		if($f[0] eq 'mov_imm') {
			my ($t, $val) = @f[1 .. 2];
			$e->("mov_imm $t $val, " . $sdst->());
			next;
		}
		if($f[0] eq 'lea_slot' || $f[0] eq 'lea_glob' || $f[0] eq 'lea_str') {
			my $what = $f[1];
			$what = "$what(%rbp)" if $f[0] eq 'lea_slot';
			$what = "$what(%rip)" if $f[0] ne 'lea_slot';
			$e->("lea $what, %rax", "movq %rax, " . $sdst->());
			next;
		}
		if($f[0] eq 'mov') {
			my ($t, $src) = @f[1 .. 2];
			$src = $slot->($src) if $src =~ /^%r\d+$/;
			$e->("movs $t $src, %rax", "movq %rax, " . $sdst->());
			next;
		}
		if($f[0] eq 'st') {
			my ($t, $src, $d) = @f[1 .. 3];
			if($d =~ /^%r\d+$/) {
				# a typed store through a pointer: st T %rS, %rM
				# (struct field/array element writes).
				$e->("movq " . $slot->($d) . ", %rcx", "movs $t " . $slot->($src) . ", %rax", "st $t %rax, (%rcx)");
				next;
			}
			if($src =~ /^%r\d+$/) {
				$e->("movs $t " . $slot->($src) . ", %rax");
				$src = '%rax';
			}
			$e->("st $t $src, $d");
			next;
		}
		if($f[0] eq 'ld8') {
			my ($src) = $f[1];
			$e->("movq " . $slot->($src) . ", %rcx", "movq (%rcx), %rcx", "movq %rcx, " . $sdst->());
			next;
		}
		if($f[0] eq 'ld') {
			# a typed load through a pointer (struct field/array
			# element): the address rides in %rcx, the value loads
			# at the field's own width.
			my ($t, $src) = @f[1 .. 2];
			$e->("movq " . $slot->($src) . ", %rcx", "movs $t (%rcx), %rax", "movq %rax, " . $sdst->());
			next;
		}
		if($f[0] eq 'st8') {
			my ($src, $d) = @f[1 .. 2];
			$e->("movq " . $slot->($d) . ", %rcx", "movq " . $slot->($src) . ", %rax", "movq %rax, (%rcx)");
			next;
		}
		if($f[0] =~ /^(add|sub|imul|and|or|xor|shl|sar|shr)$/) {
			# "%rN = op T %rA, %rB" -- dst rides the prefix; both
			# operands are always vregs (constants were materialized
			# by mov_imm already).
			my ($op, $t, $a, $b) = @f;
			my $d = $dst;
			if($op eq 'shl' || $op eq 'sar' || $op eq 'shr') {
				# a = value, b = count: the count goes through %cl.
				$e->("movs $t " . $slot->($a) . ", %rax", "movq " . $slot->($b) . ", %rcx", "$op $t %cl, %rax", "st $t %rax, " . $slot->($d));
			}
			else {
				$e->("movs $t " . $slot->($a) . ", %rax", "$op $t " . $slot->($b) . ", %rax", "st $t %rax, " . $slot->($d));
			}
			next;
		}
		if($f[0] eq 'neg' || $f[0] eq 'not') {
			# "neg T %rS, %rD" -- source first, dst last.
			my ($op, $t, $src, $d) = @f;
			$e->("movs $t " . $slot->($src) . ", %rax", "$op $t %rax", "st $t %rax, " . $slot->($d));
			next;
		}
		if($f[0] eq 'cast') {
			my ($t1, $t2, $src) = @f[1 .. 3];
			$e->("movs $t1 " . $slot->($src) . ", %rax", "st $t2 %rax, " . $sdst->());
			next;
		}
		if($f[0] eq 'cmp') {
			my ($t, $op, $a, $b) = @f[1 .. 4];
			# operands are vregs or imms only (jselect6 never
			# selects raw memory operands for cmp). flags must
			# reflect A - B, so whenever A is materialized into a
			# register, B goes last (at&t cmp src,dst = dst-src);
			# the imm,mem form is the one case A-B comes out
			# naturally (cmp $imm, mem = mem - imm... which is
			# B - A, so A must be materialized instead).
			my $a_mem = $a =~ /^%r\d+$/;
			my $b_mem = $b =~ /^%r\d+$/;
			$a = $slot->($a) if $a_mem;
			$b = $slot->($b) if $b_mem;
			if($a_mem) {
				# A in %rax, B as the second operand: %rax - B.
				$e->("movs $t $a, %rax", $b_mem ? ("cmp $t $b, %rax") : ("cmp $t \$$b, %rax"));
			}
			else {
				# A is an imm: materialize it, then cmp B, %rax
				# (B may be a slot or another imm).
				my $bop = $b_mem ? $b : "\$$b";
				$e->("mov_imm $t $a, %rax", "cmp $t $bop, %rax");
			}
			next;
		}
		if($f[0] eq 'setcc') {
			my ($cc, $d) = @f[1 .. 2];
			$e->("movl \$0, " . $slot->($d), "set$cc " . $slot->($d));
			next;
		}
		if($f[0] eq 'ret') {
			if(@f == 3) {
				my ($t, $src) = @f[1 .. 2];
				$e->("movs $t " . $slot->($src) . ", %rax");
			}
			$e->('ret');
			next;
		}
		if($f[0] eq 'sret') {
			# a struct return: word 0 in %rax, word 1 in %rdx.
			my ($n, $off) = @f[1 .. 2];
			$e->("movs i64 $off(%rbp), %rax");
			$e->("movs i64 " . ($off - 8) . "(%rbp), %rdx") if $n == 2;
			$e->('ret');
			next;
		}
		if($f[0] eq 'scall') {
			# the words of a struct-returning call's result land in
			# the target local's slots (%rax, then %rdx).
			my ($n, $off) = @f[1 .. 2];
			$e->("st i64 %rax, $off(%rbp)");
			$e->("st i64 %rdx, " . ($off - 8) . "(%rbp)") if $n == 2;
			next;
		}
		if($f[0] eq 'retv') {
			my ($t, $d) = @f[1 .. 2];
			$e->("st $t %rax, " . $slot->($d));
			next;
		}
		if($f[0] eq 'arg') {
			my ($t, $src) = @f[1 .. 2];
			$e->("movs $t " . $slot->($src) . ", $ARGREG[$argi]");
			$argi++;
			next;
		}
		if($f[0] eq 'udiv' || $f[0] eq 'umod') {
			# unsigned division: the high half is zeroed, never
			# sign-extended (no cqto/cdq), and div divides.
			my ($op, $t, $a, $b) = @f;
			my $q = $t eq 'u64' || $t eq 'i64' || $t eq 'ptr';
			$e->("movs $t " . $slot->($a) . ", %rax", "movq \$0, %rdx", "movs $t " . $slot->($b) . ", %rcx");
			$e->($q ? 'divq %rcx' : 'divl %ecx');
			my $src = $op eq 'udiv' ? '%rax' : '%rdx';
			$e->("st $t $src, " . $sdst->());
			next;
		}
		if($f[0] eq 'idiv' || $f[0] eq 'imod') {
			my ($op, $t, $a, $b) = @f;
			my $q = $t eq 'i64' || $t eq 'ptr';
			$e->("movs $t " . $slot->($a) . ", %rax", "movs $t " . $slot->($b) . ", %rcx");
			$e->($q ? 'cqto' : 'cdq', $q ? 'idivq %rcx' : 'idivl %ecx');
			my $src = $op eq 'idiv' ? '%rax' : '%rdx';
			$e->("st $t $src, " . $sdst->());
			next;
		}
		lerr($l0, 'unhandled instruction');
	}
 
	# one 5-space indent on every mir1 line except the target/func/
	# end/gvar headers (docs/ir.btft's mir1 shape).
	my $out = join("\n", map { /^(target |func |end$|gvar )/ ? $_ : "     $_" } @out);
	$out .= "\n" if @out;
	return $out;
}
 
print proc(preproc($RAW));