use v5.10;
use MooseX::Declare;
use Mildew::SSA;
use Mildew::Types;
use utf8;
class Mildew::Backend::OptC with Mildew::Backend::C {
use File::Temp qw(tempfile tmpnam);
use String::Escape qw(backslash quote);
use Getopt::Long qw(GetOptionsFromArray);
use Encode qw(encode_utf8);
has options=>(is=>'ro',default=>sub {{}});
has trace=>(is=>'rw');
has dump=>(is=>'rw');
method BUILD {
my ($trace,$dump,$cflags,$ld_library_path,$no_setting,$valgrind,$gdb,$no_wrap_in_block);
GetOptionsFromArray(
($self->options->{BACKEND} // []),
'trace' => \$trace,
'dump=s' => \$dump,
'cflags=s' => \$cflags,
'no-setting' => \$no_setting,
'ld-library-path=s' => \$ld_library_path,
'valgrind' => \$valgrind,
'gdb' => \$gdb,
'no-wrap-in-block' => \$no_wrap_in_block,
) || die 'incorrent options passed to Mildew::Backend::OptC';
use YAML::XS;
$self->trace($trace);
$self->dump($dump);
$self->cflags([split(':',$cflags)]) if $cflags;
$self->load_setting(!$no_setting) if $no_setting;
$self->ld_library_path([split(':',$ld_library_path)]) if $ld_library_path;
$self->valgrind($valgrind);
$self->gdb($gdb);
$self->wrap_in_block(!$no_wrap_in_block);
}
method c_source($ast) {
my $ssa_ast = Mildew::SSA::to_ssa($ast->simplified,{
'$scope' => Mildew::Type::Scope->new(outer=> $Mildew::LexicalPreludeType)
});
my ($funcs,$expr,$call_init_funcs) = $self->emit_block($ssa_ast);
my $boilerplate = $self->get_boilerplate;
my $body =
$call_init_funcs
. "SMOP__Object* yeast = " . $expr . ";\n"
. "SMOP__Object* frame = SMOP__Yeast__Frame_create(interpreter,yeast);\n"
. "yeast_reg_set(interpreter,frame,0,SMOP_REFERENCE(interpreter,interpreter));\n"
. "yeast_reg_set(interpreter,frame,1,SMOP_REFERENCE(interpreter,SMOP__S1P__LexicalPrelude));\n";
$boilerplate =~ s/%%BODY%%/$body/;
$boilerplate =~ s/%%FUNCS%%/$funcs/;
$boilerplate;
}
method yeast($ast) {
my $ssa_ast = Mildew::SSA::to_ssa($ast->simplified,{
'$scope' => Mildew::Type::Scope->new(outer=> $Mildew::LexicalPreludeType)
});
$self->emit_block($ssa_ast);
}
method emit_block($block) {
state $unique_func_id = 0;
my $func_name = 'smop_yeast_' . $unique_func_id++;
my $funcs = '';
my $call_init_funcs = '';
my $i = 0;
my $code;
my %labels;
my %regs;
my $reg_id = 0;
my $constant_decls;
my $init_constants = "static void ${func_name}_init(interpreter) {";
my $constants_id = 0;
my $constant = sub {
my $c = $func_name . "_constant_" . $constants_id++;
$constant_decls .= "static SMOP__Object* $c;\n";
$init_constants .= "$c = $_[0];\n";
$c;
};
for (@{$block->regs}) {
$regs{'$'.$_} = $reg_id++;
}
my $value = sub {
if ($_[0]->isa('Mildew::AST::Reg')) {
if ($_[0]->name =~ /^¢|^\?/) {
my $n = $_[0]->name;
$n =~ s/^¢|^\?//;
return $n;
}
unless (defined $regs{$_[0]->real_name}) {
$regs{$_[0]->real_name} = $reg_id++;
}
"frame->reg[" . $regs{$_[0]->real_name} . "]";
} elsif ($_[0]->isa('Mildew::AST::StringConstant')) {
my $str = $_[0]->value;
# TODO properly quote characters
$str =~ s/(["\\])/\\$1/g;
$str =~ s/\n/\\n/g;
$constant->('SMOP__NATIVE__idconst_createn("' . $str . '",' . length(encode_utf8($_[0]->value)) . ')');
} elsif ($_[0]->isa('Mildew::AST::IntegerConstant')) {
$constant->('SMOP__NATIVE__int_create(' . $_[0]->value . ')');
} elsif ($_[0]->isa('Mildew::AST::Block::SSA')) {
my ($func,$expr,$init) = $self->emit_block($_[0]);
$funcs .= $func;
$call_init_funcs .= $init;
$constant->($expr);
} else {
die "don't know how to emit: ",ref($_[0]);
#$constant->(ref($_[0]).'???');
}
};
for my $subblock (@{$block->stmts}) {
if ($subblock->id) {
$labels{$subblock->id} = $i;
}
for my $stmt (@{$subblock->stmts}) {
if ($stmt->isa('Mildew::AST::Assign')) {
# TODO - handle profile_info more cleanly
if ($stmt->rvalue->isa('Mildew::AST::Call') && defined $Mildew::profile_info) {
$i++;
}
}
$i++;
}
}
$i = 0;
for my $subblock (@{$block->stmts}) {
for my $stmt (@{$subblock->stmts}) {
#$code .= "\n/*".$stmt->pretty."*/\n";
$code .= "case $i:";
if ($self->trace) {
$code .= "\nprintf(".quote(backslash($stmt->pretty . "\n")).");\n";
}
if ($self->dump) {
my $file = quote(backslash($self->dump));
$code .= "\nsmop_dump_print(interpreter,(SMOP__Object*)frame,$file);\n";
}
if ($stmt->isa('Mildew::AST::Goto')) {
$code .= "frame->pc = " . $labels{$stmt->block->id} . ";" . "break;\n"
} elsif ($stmt->isa('Mildew::AST::Branch')) {
$code .= "frame->pc = "
. $value->($stmt->cond)
. " == SMOP__NATIVE__bool_false ? "
. $labels{$stmt->else->id}
. " : "
. $labels{$stmt->then->id}
. ";break;\n";
} elsif ($stmt->isa('Mildew::AST::Reg')) {
# make it a noop
$code .= ';';
} elsif ($stmt->isa('Mildew::AST::Assign')) {
if ($stmt->rvalue->isa('Mildew::AST::Call')) {
my $type = $stmt->rvalue->capture->invocant->type_info->type;
my ($c,$trailing) = $type->emit_call($i,$stmt,$value);
$code .= $c;
if ($trailing) {
$i++;
$code .= "case $i: frame->pc = " . ($i+1) . ';' . $trailing;
}
} elsif ($stmt->rvalue->isa('Mildew::AST::Phi')) {
# TODO make it a noop
$code .= ';';
} elsif ($stmt->rvalue->isa('Mildew::AST::InferredTypeTest')) {
my $type = $stmt->rvalue->value->type_info->type;
$code .= Mildew::Emit::Yeast::assign($value->($stmt->lvalue),"SMOP_REFERENCE(interpreter,".$value->(Mildew::AST::IntegerConstant->new(value=>eval($stmt->rvalue->test) ? 1 : 0).")"));
die if $@;
} else {
$code .= Mildew::Emit::Yeast::assign($value->($stmt->lvalue),"SMOP_REFERENCE(interpreter,".$value->($stmt->rvalue).")");
}
} else {
$code .= "/*".ref($stmt)."*/\n";
}
$i++;
}
}
($funcs . $constant_decls . $init_constants . "}\n" . "static void " . $func_name . "(SMOP__Object* interpreter,SMOP__Yeast__Frame* frame) {"
. " switch (frame->pc) {"
. $code
. "case $i : frame->pc = -1;\n"
. " }}\n","SMOP__Yeast_create(" . (scalar keys %regs)
. ",(SMOP__Object*[]) {NULL}"
. ",$func_name)","${call_init_funcs}${func_name}_init(interpreter);");
}
}