| git.druid.rocks | index | druid520 | nscc | src/ | jemit8.pl |
src/jemit8.pl
#!/usr/bin/env perl
# jemit8 -- the nscc asm-emission stage, ninth and last stage of the
# nscc pipeline. owns: att syntax quirks (operand order, $immediates,
# %registers, -8(%rbp) memory), section directives, .globl only for
# linkage=global symbols, .type/.size for functions, and the operand
# suffix rules: loads sign-extend (movsbq/movswq/movslq/movq -- all
# nsc values are signed), stores and ops take the width suffix of
# their type (b/w/l/q), immediates use the narrowest legal spelling
# (movq $imm32 sign-extends; larger i64 constants take movabsq). the
# output is plain x86_64 att asm, no gnu syntax extensions: no
# %gs:-style segment prefixes, no {sae}, no @PLT/@GOTPCREL operand
# modifiers -- what you see is exactly what gas consumes.
#
# a "ret" in mir1 becomes the full epilogue (movq %rbp,%rsp; popq
# %rbp; ret), and every function additionally gets that epilogue at
# its end, so a function that falls off its last statement still
# returns cleanly. strings land in .rodata as .LC0, .LC1, ... in
# first-use order, one .byte per byte plus the trailing NUL; globals
# land in .data at their declared width.
#
# when the mir1 stream starts with a target header (nscc's -s flag
# injects it between jdesugar4 and jlower5, or a user writes it by
# hand for a cross-compile), this stage emits the freestanding
# startup: our own _start (no crt1, no libc -- rbp nulled to mark the
# stack bottom, argc in %rdi, argv in %rsi, then call main, then
# exit(main's return) via the raw syscall -- syscall number 1 on
# netbsd, 60 on linux), and, on netbsd, the .note.netbsd.ident
# section every netbsd executable must carry, in charge's exact
# src/netbsd-note.s shape (plain "a" flags, .align 4, .int header
# words, .ascii name + .byte 0, .long version, .align 4), with
# osver= encoded the netbsd way (major*100000000 + minor*1000000 +
# teeny*100). -s assumes an i32 main.
#
# this stage's own mini pipeline: in -- preproc -- proc -- out, where
# preproc is the mir1 deserialization and proc is the emission.
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 %SUF = (i8 => 'b', i16 => 'w', i32 => 'l', i64 => 'q',
u8 => 'b', u16 => 'w', u32 => 'l', u64 => 'q',
ptr => 'q');
my %MOVS = (i8 => 'movsbq', i16 => 'movswq', i32 => 'movslq', i64 => 'movq',
u8 => 'movzbq', u16 => 'movzwq', u32 => 'movl', u64 => 'movq',
ptr => 'movq');
sub lerr {
my ($line, $msg) = @_;
stage_err("jemit8: $msg in mir1 line: $line");
}
sub clean {
my ($ln) = @_;
$ln =~ s/^ //;
return $ln;
}
my $TARGET; # the optional "target MODE key=value ..." header line
sub preproc {
my ($t) = @_;
my @l = grep { /\S/ } split /\n/, $t;
if(@l && $l[0] =~ /^target \S+( \S+=\S+)*$/) {
$TARGET = shift @l;
}
return \@l;
}
# an immediate that needs movabsq: one that does not fit in a signed
# 32-bit sign-extended operand. the raw text (which gas accepts hex or
# decimal) is kept for emission; only the size check needs the value.
sub needs_abs {
my ($v) = @_;
my $n;
if($v =~ /^0[xX]/) {
# same non-portable advisory as jtype3's int_value, same
# reasoning for why it's safe to silence narrowly here: a
# 64-bit-high-bit-set hex literal is exactly the case this
# function exists to detect (it needs movabsq precisely
# because it doesn't fit in 32 bits), so seeing one here is
# the expected case, not a bug.
no warnings 'portable';
$n = hex(substr($v, 2));
}
else { $n = 0 + $v; }
return $n < -0x80000000 || $n > 0x7FFFFFFF;
}
sub proc {
my ($lines) = @_;
my $out = '';
my @strings;
my @gvars;
my $cur_name = '';
my $text_seen = 0;
my $last_ret = 0; # the previous body line was already a full epilogue
# the target header (nscc's -s flag) makes the mir1 self-
# describing: mode + os (+ osver on netbsd). jemit8 is its only
# consumer; j5-j7 pass it through untouched.
my $mode = '';
my %targ;
if(defined $TARGET && $TARGET =~ /^target (\S+)(.*)$/) {
$mode = $1;
for my $kv (split ' ', $2) {
if($kv =~ /^(\w+)=(\S+)$/) { $targ{$1} = $2; }
}
}
stage_err("jemit8: unknown target mode '$mode'") if $mode ne '' && $mode ne 'freestanding';
if($mode eq 'freestanding') {
my $os = $targ{os} // '';
my %sys_exit = (Linux => 60, NetBSD => 1);
stage_err("jemit8: freestanding target needs os=Linux or os=NetBSD, got '$os'") unless $sys_exit{$os};
$out .= "\t.text\n";
$text_seen = 1;
$out .= "\t.globl _start\n";
$out .= "\t.type _start, \@function\n";
$out .= "_start:\n";
$out .= "\txorq %rbp, %rbp\n";
$out .= "\tmovq (%rsp), %rdi\n";
$out .= "\tleaq 8(%rsp), %rsi\n";
$out .= "\tcall main\n";
$out .= "\tmovl %eax, %edi\n";
$out .= "\tmovl \$$sys_exit{$os}, %eax\n";
$out .= "\tsyscall\n";
$out .= "\thlt\n";
$out .= "\t.size _start, .-_start\n";
}
for my $l0 (@$lines) {
my $l = clean($l0);
if($l =~ /^func (\S+) sym=(\d+) linkage=(\S+) ret=(\S+) frame=(\d+) locals=(\d+) vregs=(\d+)$/) {
my ($name, $linkage, $frame) = ($1, $3, $5);
# _start is ours in freestanding mode: a user symbol with
# that name would collide with the emitted one.
stage_err('jemit8: freestanding target reserves the symbol _start')
if $mode eq 'freestanding' && $name eq '_start';
unless($text_seen) { $out .= "\t.text\n"; $text_seen = 1; }
if($linkage eq 'GLOBAL') {
$out .= "\t.globl $name\n";
}
$out .= "\t.type $name, \@function\n";
$out .= "$name:\n";
$out .= "\tpushq %rbp\n";
$out .= "\tmovq %rsp, %rbp\n";
$out .= "\tsubq \$$frame, %rsp\n" if $frame > 0;
$cur_name = $name;
next;
}
if($l eq 'end') {
# a body that already ended with a ret got its epilogue
# there; a body that falls off the end needs one now.
unless($last_ret) {
$out .= "\tmovq %rbp, %rsp\n";
$out .= "\tpopq %rbp\n";
$out .= "\tret\n";
}
$out .= "\t.size $cur_name, .-$cur_name\n";
next;
}
if($l =~ /^str (.*)$/) {
my $s = $1;
$s =~ s/^"//;
$s =~ s/"$//;
$s =~ s/\\x([0-9A-Fa-f]{2})/chr(hex($1))/ge;
$s .= "\0";
push @strings, $s;
next;
}
if($l =~ /^gvar (\S+) sym=(\d+) linkage=(\S+) (\S+) (.*)$/) {
stage_err('jemit8: freestanding target reserves the symbol _start')
if $mode eq 'freestanding' && $1 eq '_start';
# struct/array globals carry one value per word, all as
# .quad (word-addressed storage); scalars one directive
# at their declared width.
push @gvars, {name => $1, linkage => $3, ty => $4, vals => [split ' ', $5]};
next;
}
my @f = grep { length } split /[ ,]+/, $l;
$last_ret = 0;
if($f[0] eq 'mov_imm') {
my ($t, $val, $dst) = @f[1 .. 3];
# registers always hold 64-bit sign-extended values, so
# a mov_imm is always a q-width move (narrower widths
# are a load/store concern, not a register one).
if(needs_abs($val)) {
# movabsq has no memory-destination form: an imm64
# going to memory rides through %rax.
if($dst =~ /^%[a-z0-9]+$/) {
$out .= "\tmovabsq \$$val, $dst\n";
}
else {
$out .= "\tmovabsq \$$val, %rax\n";
$out .= "\tmovq %rax, $dst\n";
}
}
else {
$out .= "\tmovq \$$val, $dst\n";
}
next;
}
if($f[0] eq 'movs') {
my ($t, $src, $dst) = @f[1 .. 3];
# a u32 load is movl, and movl spells its 64-bit
# destination as the 32-bit register (movl writes the
# low half and zero-extends, which IS the u32 value).
if($t eq 'u32' && $dst =~ /^%/) {
my %d = (rax => 'eax', rcx => 'ecx', rdx => 'edx', rdi => 'edi', rsi => 'esi', r8 => 'r8d', r9 => 'r9d');
my $r = substr($dst, 1);
$dst = '%' . ($d{$r} // $r);
}
$out .= "\t$MOVS{$t} $src, $dst\n";
next;
}
if($f[0] eq 'st') {
my ($t, $src, $d) = @f[1 .. 3];
# stores through a pointer (the (%rcx) form) are typed
# at their exact width -- an 8-byte store would clobber
# the neighboring word; slot/global stores are always 8
# bytes wide (every load sign/zero-extends from the
# declared width anyway, so the upper bytes written here
# are never read).
if($d =~ /^\(/) {
# the source register must match the width's
# register spelling (%rax can't ride an l suffix).
my $w = $SUF{$t};
$src = {b => '%al', w => '%ax', l => '%eax'}->{$w} // $src;
$out .= "\tmov$w $src, $d\n";
}
else {
$out .= "\tmovq $src, $d\n";
}
next;
}
if($f[0] eq 'movq') {
$out .= "\tmovq $f[1], $f[2]\n";
next;
}
if($f[0] =~ /^(add|sub|imul|and|or|xor|shl|sar|shr|neg|not)$/) {
my $op = $1;
# all integer math happens on 64-bit sign-extended
# values (see mov_imm above): the q form is correct for
# every declared width, since the declared width's
# wrapping is applied by the st/load pair around it.
if($op eq 'neg' || $op eq 'not') { $out .= "\t${op}q $f[2]\n"; }
else { $out .= "\t${op}q $f[2], $f[3]\n"; }
next;
}
if($f[0] eq 'cmp') {
my ($t, $a, $b) = ($f[1], $f[2], $f[3]);
$out .= "\tcmpq $a, $b\n";
next;
}
if($f[0] =~ /^set(.+)$/) {
$out .= "\tset$1 $f[1]\n";
next;
}
if($f[0] eq 'movl' && $f[1] eq '$0') {
$out .= "\tmovl \$0, $f[2]\n";
next;
}
if($f[0] eq 'jcc') {
$out .= "\tj$f[1] .L$cur_name.$f[2]\n";
next;
}
if($f[0] =~ /^j(ne|e|l|le|g|ge|mp)$/) {
$out .= "\t$f[0] .L$cur_name.$f[1]\n";
next;
}
if($f[0] eq 'goto') {
$out .= "\tjmp .L$cur_name.$f[1]\n";
next;
}
if($f[0] eq 'label') {
# control-flow labels carry the function name and the
# .L prefix: a bare label (or even a .L-prefixed one) is
# a per-file symbol to gas, so two functions each
# carrying an I0 would collide -- .L<name>.<label> is
# unique per function and stays out of the symbol table.
$out .= ".L$cur_name.$f[1]:\n";
next;
}
if($f[0] eq 'call') {
$out .= "\tcall $f[1]\n";
next;
}
if($f[0] eq 'icall') {
# indirect call through a register: att spells the
# register operand of an indirect call with a '*'.
$out .= "\tcall *$f[1]\n";
next;
}
if($f[0] eq 'ret') {
$out .= "\tmovq %rbp, %rsp\n";
$out .= "\tpopq %rbp\n";
$out .= "\tret\n";
$last_ret = 1;
next;
}
if($f[0] eq 'cqto' || $f[0] eq 'cdq') {
$out .= "\t$f[0]\n";
next;
}
if($f[0] eq 'idivq' || $f[0] eq 'idivl' || $f[0] eq 'divq' || $f[0] eq 'divl') {
$out .= "\t$f[0] $f[1]\n";
next;
}
if($f[0] eq 'lea') {
$out .= "\tlea $f[1], $f[2]\n";
next;
}
lerr($l, 'unhandled instruction');
}
# .rodata: one .LCn label per string, byte by byte.
if(@strings) {
$out .= "\t.section .rodata\n";
for my $i (0 .. $#strings) {
$out .= ".LC$i:\n";
my @bytes = map { ord($_) } split //, $strings[$i];
$out .= "\t.byte " . join(',', @bytes) . "\n";
}
}
# -s on netbsd: the ident note every netbsd executable must
# carry (the kernel refuses to exec a netbsd binary without it),
# shaped exactly like charge's own src/netbsd-note.s: plain "a"
# section flags (no %note GNU-ism -- netbsd matches the note by
# its name/content, not its section type), .align 4, .int for
# the three header words (namesz 7, descsz 4, type 1 =
# ELF_NOTE_TYPE_NETBSD_TAG), the name as .ascii + a .byte 0
# terminator, and the version from NSCC_OSVER encoded netbsd's
# way (major*100000000 + minor*1000000 + teeny*100, so 10.0 is
# 1000000000 and 10.99.12 is 1099001200), .align 4 again after.
if($mode eq 'freestanding' && ($targ{os} // '') eq 'NetBSD') {
my $ver = $targ{osver} // '';
stage_err('jemit8: freestanding netbsd target needs osver=') unless $ver =~ /\S/;
my ($maj, $min, $tn) = $ver =~ /^(\d+)(?:\.(\d+))?(?:\.(\d+))?/;
stage_err("jemit8: unparsable netbsd osver '$ver'") unless defined $maj;
$min //= 0;
$tn //= 0;
my $num = $maj * 100000000 + $min * 1000000 + $tn * 100;
$out .= "\t.section .note.netbsd.ident, \"a\"\n";
$out .= "\t.align 4\n";
$out .= "\t.int 7\n";
$out .= "\t.int 4\n";
$out .= "\t.int 1\n";
$out .= "\t.ascii \"NetBSD\"\n";
$out .= "\t.byte 0\n";
$out .= "\t.long $num\n";
$out .= "\t.align 4\n";
}
# .data: one entry per defined global; aggregates emit one .quad
# per word.
if(@gvars) {
my %dir = (i8 => '.byte', i16 => '.word', i32 => '.long', i64 => '.quad',
u8 => '.byte', u16 => '.word', u32 => '.long', u64 => '.quad', ptr => '.quad');
my %width = (i8 => 1, i16 => 2, i32 => 4, i64 => 8,
u8 => 1, u16 => 2, u32 => 4, u64 => 8, ptr => 8);
my @data = grep { !(@{$_->{vals}} == 1 && $_->{vals}[0] =~ /^uninit:/) } @gvars;
my @bss = grep { @{$_->{vals}} == 1 && $_->{vals}[0] =~ /^uninit:/ } @gvars;
if(@data) {
$out .= "\t.data\n";
for my $g (@data) {
$out .= "\t.globl $g->{name}\n" if $g->{linkage} eq 'GLOBAL';
if($g->{ty} =~ /^\[(\d+)\](.+)$/) {
# byte-packed array: element 0 at the symbol, elements
# run UP (increasing addresses), each at its width.
my $d = $dir{$2};
$out .= "$g->{name}:\n";
$out .= "\t$d $_\n" for @{$g->{vals}};
}
elsif($g->{ty} =~ /^struct\./) {
# struct: fields run DOWNWARD (field 0 at the symbol),
# one .quad per word.
$out .= "\t.quad $_\n" for reverse @{$g->{vals}}[1 .. $#{$g->{vals}}];
$out .= "$g->{name}:\n";
$out .= "\t.quad $g->{vals}[0]\n";
}
else {
$out .= "$g->{name}:\n";
$out .= "\t$dir{$g->{ty}} $g->{vals}[0]\n";
}
}
}
# gvars with no initializer: real storage, just zeroed --
# emitted as a COMMON symbol (.comm), not a plain .bss label.
# this matters: t23 has one file with `global i32 counter = 0;`
# (a real, initialized definition) and another with
# `global i32 counter;` (no initializer) both referring to the
# SAME shared variable -- the uninitialized side is a tentative
# definition, expected to merge with whichever file actually
# has the real one, same as C's classic common-symbol rule. a
# .bss label + .globl is a strong definition and collides
# ("multiple definition of `counter'") the moment a real
# initialized definition exists anywhere else; .comm is exactly
# the GNU as/ld primitive for "storage that's fine coalescing
# with a stronger definition elsewhere, or with other .comm
# declarations of the same name" -- no separate .bss section or
# .globl needed, .comm symbols are external by construction.
# the exact byte size travels in the "uninit:N" marker itself,
# computed back in jlower5.pl while struct/array type info was
# still available -- jemit8 only sees flattened text by this
# point and has no struct table of its own to re-derive it
# from, so it just trusts the number it was given.
for my $g (@bss) {
my ($bytes) = $g->{vals}[0] =~ /^uninit:(\d+)$/;
my $align = ($g->{ty} =~ /^\[(\d+)\](.+)$/) ? $width{$2} : 8;
$out .= "\t.comm $g->{name}, $bytes, $align\n";
}
}
return $out;
}
print proc(preproc($RAW));