Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
899 lines (799 sloc) 28.6 KB
my $more-code-sentinel := nqp::hash();
# Provides base functionality for a compiler object.
class HLL::Compiler does HLL::Backend::Default {
has @!stages;
has $!parsegrammar;
has $!parseactions;
has @!cmdoptions;
has $!compiler_progname;
has $!language;
has %!config;
has $!user_progname;
has @!cli-arguments;
has %!cli-options;
has $!backend;
has $!save_ctx;
method BUILD() {
# Backend is set to the default one, by default.
$!backend := self.default_backend();
# Default stages.
@!stages := nqp::split(' ', 'start parse ast ' ~ $!backend.stages());
# Command options and usage.
@!cmdoptions := nqp::split(' ', 'e=s help|h target=s trace|t=s encoding=s output|o=s source-name=s combine version|v show-config verbose-config|V stagestats=s? ll-exception rxtrace nqpevent=s profile=s? profile-compile=s? profile-filename=s profile-kind=s profile-stage=s repl-mode=s bytecode|b compile=s'
#?if js
~ ' substagestats beautify nqp-runtime=s perl6-runtime=s libpath=s shebang execname=s source-map'
#?endif
#?if moar
~ ' confprog=s'
#?endif
);
%!config := nqp::hash();
}
method backend(*@value) {
if @value {
$!backend := @value[0];
@!stages := nqp::split(' ', 'start parse ast ' ~ $!backend.stages());
}
$!backend
}
method language($name?) {
if $name {
$!language := $name;
nqp::bindcomp($name, self);
}
$!language;
}
method compiler($name) {
nqp::getcomp($name);
}
method config() { %!config };
method autoprint($value) {
self.interactive_result($value)
unless nqp::tellfh(nqp::getstdout()) > $*AUTOPRINTPOS;
}
method readline($stdin, $stdout, $prompt) {
$stdout.print($prompt);
return $stdin.get;
}
method context() {
$!save_ctx # XXX starting value?
}
method interactive(*%adverbs) {
stderr().print(self.interactive_banner);
my $stdin := stdin();
my $stdout := stdout();
my $encoding := ~%adverbs<encoding>;
if $encoding && $encoding ne 'fixed_8' {
$stdin.set-encoding($encoding);
}
my $target := nqp::lc(%adverbs<target>);
my $prompt := self.interactive_prompt // '> ';
my $code;
while 1 {
last if $stdin.eof;
my str $newcode := self.readline($stdin, $stdout, ~$prompt);
if nqp::isnull_s($newcode) || !nqp::defined($newcode) {
nqp::print("\n");
last;
}
if $newcode {
$code := $code ~ $newcode;
}
# Set the current position of stdout for autoprinting control
my $*AUTOPRINTPOS := nqp::tellfh(nqp::getstdout());
my $*CTXSAVE := self;
my $*MAIN_CTX;
if $code {
$code := $code ~ "\n";
my $output;
{
$output := self.eval($code, :outer_ctx($!save_ctx), |%adverbs);
CATCH {
self.interactive_exception($!);
}
};
if self.input-incomplete($output) {
# Need to get more code before we execute
# Strip the trailing \, but reinstate the newline
if nqp::eqat($code, "\\\n", 0) {
$code := nqp::substr($code, 0, nqp::chars($code) - 2) ~ "\n";
}
if $code {
$prompt := '* ';
}
next;
}
if nqp::defined($*MAIN_CTX) {
$!save_ctx := $*MAIN_CTX;
}
$code := "";
$prompt := self.interactive_prompt // '> ';
next unless nqp::defined($output);
next if nqp::isnull($output);
if !$target {
self.autoprint($output);
} elsif $!backend.is_textual_stage($target) {
nqp::say($output);
} else {
self.dumper($output, $target, |%adverbs);
}
}
}
}
method interactive_result($value) {
nqp::say(~$value)
}
method interactive_exception($ex) {
nqp::print(~$ex ~ "\n")
}
method input-incomplete($value) {
nqp::where($value) == nqp::where($more-code-sentinel);
}
method needs-more-input() {
$more-code-sentinel
}
method eval($code, *@args, *%adverbs) {
my $output;
if $code && nqp::eqat($code, "\\\n", nqp::chars($code) - 2) {
return self.needs-more-input();
}
if nqp::existskey(%adverbs, 'profile-compile') {
$output := $!backend.run_profiled({
self.compile($code, :compunit_ok(1), |%adverbs);
}, %adverbs<profile-filename> || %adverbs<profile-compile>, %adverbs<profile-kind>);
}
else {
$output := self.compile($code, :compunit_ok(1), |%adverbs);
}
if $!backend.is_compunit($output) && %adverbs<target> eq '' {
my $outer_ctx := %adverbs<outer_ctx>;
$output := $!backend.compunit_mainline($output);
if nqp::defined($outer_ctx) {
nqp::forceouterctx($output, $outer_ctx);
}
if %adverbs<confprog> {
if nqp::can($!backend, 'confprog') {
$!backend.confprog(%adverbs<confprog>, |%adverbs);
}
}
if nqp::existskey(%adverbs, 'profile') {
if nqp::existskey(%adverbs, 'profile-compile') || nqp::existskey(%adverbs, 'profile-stage') {
note("Currently you cannot profile both compilation and runtime, ignoring --profile");
$output := $output(|@args);
}
else {
$output := $!backend.run_profiled({ $output(|@args) },
%adverbs<profile-filename> || %adverbs<profile>, %adverbs<profile-kind>);
}
}
elsif %adverbs<trace> {
$output := $!backend.run_traced(%adverbs<trace>, { $output(|@args) });
}
else {
$output := $output(|@args);
}
}
$output;
}
method ctxsave() {
$*MAIN_CTX := nqp::ctxcaller(nqp::ctx());
$*CTXSAVE := 0;
}
method panic(*@args) {
nqp::die(join('', @args))
}
method stages(@value?) {
if +@value {
@!stages := @value;
}
@!stages;
}
method parsegrammar(*@value) {
if +@value {
$!parsegrammar := @value[0];
}
$!parsegrammar;
}
method parseactions(*@value) {
if +@value {
$!parseactions := @value[0];
}
$!parseactions;
}
method interactive_banner() { '' }
method interactive_prompt() { '> ' }
method compiler_progname($value?) {
if nqp::defined($value) {
$!compiler_progname := $value;
}
$!compiler_progname;
}
method commandline_options(@value?) {
if +@value {
@!cmdoptions := @value;
}
@!cmdoptions;
}
method command_line(@args, *%adverbs) {
my $program-name := @args[0];
my $res := self.process_args(@args);
my %opts := $res.options;
my @a := $res.arguments;
for %opts {
%adverbs{$_.key} := $_.value;
}
self.usage($program-name) if %adverbs<help> || %adverbs<h>;
if %adverbs<compile> {
%adverbs<target> := 'mbc'; # FIXME - This needs to be changed to allow for other backends
%adverbs<output> := %adverbs<compile> ~ ".bc";
}
if $!backend.is_precomp_stage(%adverbs<target>) {
%adverbs<precomp> := 1;
}
my $*PERL6_RUNTIME;
if %adverbs<perl6-runtime> {
$*PERL6_RUNTIME := %adverbs<perl6-runtime>;
}
my $*LIBPATH;
if %adverbs<libpath> {
my $split := nqp::split('|||', %adverbs<libpath>);
$*LIBPATH := nqp::list_s();
for $split -> $str {
nqp::push_s($*LIBPATH, $str);
}
nqp::getcomp('JavaScript').eval('return (function(paths) {nqp.libpath(paths)})')($*LIBPATH);
}
my $*EXECNAME;
if %adverbs<execname> {
$*EXECNAME := %adverbs<execname>;
}
self.command_eval(|@a, |%adverbs);
}
method command_eval(*@a, *%adverbs) {
self.version if %adverbs<version> || %adverbs<v>;
self.verbose-config if %adverbs<verbose-config> || %adverbs<V>
|| %adverbs<show-config>;
self.nqpevent(%adverbs<nqpevent>) if %adverbs<nqpevent>;
my $result;
my $error;
my $has_error := 0;
my $target := nqp::lc(%adverbs<target>);
try {
{
if nqp::defined(%adverbs<e>) {
$!user_progname := '-e';
my $?FILES := '-e';
$result := self.eval(%adverbs<e>, '-e', |@a, |%adverbs);
unless $target eq '' || $!backend.is_textual_stage($target) || %adverbs<output> {
self.dumper($result, $target, |%adverbs);
}
}
elsif !@a {
# Is STDIN a TTY display? If so, start the REPL, otherwise, simply
# assume the program to eval is given on STDIN.
my $force := %adverbs<repl-mode>//'';
my $wants-interactive := $force
?? $force eq 'interactive'
?? 1 !! $force eq 'non-interactive'
?? 0 !! self.panic(
"Unknown REPL mode '$force'. Valid values"
~ " are 'non-interactive' and 'interactive'"
)
!! stdin().t();
$result := $wants-interactive
?? self.interactive(|%adverbs)
!! self.evalfiles('-', |%adverbs);
}
elsif %adverbs<combine> { $result := self.evalfiles(@a, |%adverbs) }
else { $result := self.evalfiles(@a[0], |@a, |%adverbs) }
if !nqp::isnull($result) && ($!backend.is_textual_stage($target) || %adverbs<output>) {
my $output := %adverbs<output>;
my $fh := ($output eq '' || $output eq '-')
?? stdout()
!! open($output, :w);
self.panic("Cannot write to $output") unless $fh;
$fh.print($result);
$fh.flush();
close($fh) unless ($output eq '' || $output eq '-');
}
CONTROL {
if nqp::can(self, 'handle-control') {
self.handle-control($_);
} else {
nqp::rethrow($_);
}
}
}
CATCH {
$has_error := 1;
$error := $_;
}
}
if $has_error {
if %adverbs<ll-exception> || !nqp::can(self, 'handle-exception') {
my $err := stderr();
my $message := nqp::getmessage($error);
my $payload := nqp::getpayload($error);
if nqp::isnull_s($message) && nqp::can($payload, 'message') {
$message := $payload.message;
}
$err.say($message);
$err.say(nqp::join("\n", nqp::backtracestrings($error)));
nqp::exit(1);
} else {
self.handle-exception($error);
}
}
if %adverbs<compile> {
my $command := "./linker/elfmaker " ~ %adverbs<output>;
self.syscall($command);
$command := "gcc -O3 -o " ~ %adverbs<compile> ~ " ./linker/attempt2.c " ~ %adverbs<output>;
self.syscall($command);
$command := "chmod 755 " ~ %adverbs<compile>;
self.syscall($command);
$command := "rm " ~ %adverbs<output>;
self.syscall($command);
}
$result;
}
method syscall($command) {
my $is-windows := nqp::backendconfig()<osname> eq 'MSWin32';
my class Queue is repr('ConcBlockingQueue') { }
my $queue := nqp::create(Queue);
my class VMDecoder is repr('Decoder') {}
my $dec := nqp::create(VMDecoder);
nqp::decoderconfigure($dec, 'utf8', nqp::hash());
my sub create_buf($type) {
my $buf := nqp::newtype(nqp::null(), 'VMArray');
nqp::composetype($buf, nqp::hash('array', nqp::hash('type', $type)));
nqp::setmethcache($buf, nqp::hash('new', method () {nqp::create($buf)}));
$buf;
}
my $args;
my $done := 0;
my $read-all1 := 0;
my $read-all2 := 0;
my $called_ready := 0;
# task-specific vars
my @stdout_bytes;
my @stderr_bytes;
my $config := nqp::hash(
'done', -> $status {
$done := $done + 1;
},
'ready', -> $stdin?, $stdout?, $stderr? {
$called_ready := $called_ready + 1;
},
'stdout_bytes', -> $seq, $data, $err {
if nqp::isconcrete($data) {
@stdout_bytes[$seq] := $data;
}
else {
++$read-all1;
}
},
'stderr_bytes', -> $seq, $data, $err {
if nqp::isconcrete($data) {
@stderr_bytes[$seq] := $data;
}
else {
++$read-all2;
}
},
'buf_type', create_buf(uint8)
);
# define a task
$args := $is-windows ?? nqp::list(nqp::getenvhash()<ComSpec>, '/c', $command)
!! nqp::list('/bin/sh', '-c', $command);
my $task := nqp::spawnprocasync($queue, $args, nqp::cwd(), nqp::getenvhash(), $config);
nqp::permit($task, 1, -1);
nqp::permit($task, 2, -1);
# run the task
while !$done || !$read-all1 || !$read-all2 {
if nqp::shift($queue) -> $task {
if nqp::list($task) {
my $code := nqp::shift($task);
$code(|$task);
}
else {
$task();
}
}
}
}
method process_args(@args) {
# First argument is the program name.
self.compiler_progname(@args.shift);
my $p := HLL::CommandLine::Parser.new(@!cmdoptions);
$p.add-stopper('-e');
$p.stop-after-first-arg;
my $res;
try {
$res := $p.parse(@args);
CATCH {
note($_);
self.usage(:use-stderr);
nqp::exit(1);
}
}
if $res {
%!cli-options := $res.options();
@!cli-arguments := $res.arguments();
}
else {
%!cli-options := nqp::hash();
@!cli-arguments := [];
}
$res;
}
method evalfiles($files, *@args, *%adverbs) {
my $target := nqp::lc(%adverbs<target>);
my $encoding := %adverbs<encoding>;
my @files := nqp::islist($files) ?? $files !! [$files];
$!user_progname := join(',', @files);
my @codes;
for @files -> $filename {
my $err := 0;
my $in-handle;
try {
if $filename eq '-' {
$in-handle := stdin();
}
elsif nqp::stat($filename, nqp::const::STAT_ISDIR) {
note("Can not run directory $filename.");
$err := 1;
}
elsif nqp::defined(%adverbs<bytecode>) || nqp::defined(%adverbs<b>) {
nqp::loadbytecode($filename);
nqp::exit(0);
}
else {
$in-handle := open($filename, :r, :enc($encoding));
}
CATCH {
note("Could not open $filename. $_");
$err := 1;
}
}
nqp::exit(1) if $err;
try {
nqp::push(@codes, $in-handle.slurp());
unless $filename eq '-' {
$in-handle.close;
}
CATCH {
note("Error while reading from file: $_");
$err := 1;
}
}
nqp::exit(1) if $err;
}
my $code := join('', @codes);
my $?FILES := %adverbs<source-name> || join(' ', @files);
my $r := self.eval($code, |@args, |%adverbs);
if $target eq '' || $!backend.is_textual_stage($target) || %adverbs<output> {
return $r;
} else {
return self.dumper($r, $target, |%adverbs);
}
}
method exists_stage($stage) {
my $found := 0;
for self.stages() {
if $_ eq $stage {
return 1;
}
}
return 0;
}
method execute_stage($stage, $result, %adverbs) {
if nqp::can($!backend, $stage) {
$!backend."$stage"($result, |%adverbs);
}
elsif nqp::can(self, $stage) {
self."$stage"($result, |%adverbs);
}
else {
nqp::die("Unknown compilation stage '$stage'");
}
}
method compile($source, :$from, :$lineposcache, *%adverbs) {
my %*COMPILING<%?OPTIONS> := %adverbs;
my $*LINEPOSCACHE := $lineposcache;
my $target := nqp::lc(%adverbs<target>);
my $result := $source;
my $stderr := stderr();
my $stdin := stdin();
my $stagestats := %adverbs<stagestats>;
unless $from eq '' || self.exists_stage($from) {
nqp::die("Unknown compilation input '$from'");
}
unless $target eq '' || self.exists_stage($target) {
nqp::die("Unknown compilation target '$target'");
}
for self.stages() {
if $from ne '' {
if $_ eq $from {
$from := '';
}
next;
}
$stderr.print(nqp::sprintf("Stage %-11s: ", [$_])) if nqp::defined($stagestats);
my num $timestamp := nqp::time_n();
my sub run() {
self.execute_stage($_, $result, %adverbs)
}
$result := %adverbs<profile-stage> eq $_
?? $!backend.run_profiled(&run, %adverbs<profile-filename> || %adverbs<profile-compile>, %adverbs<profile-kind>)
!! run();
my num $diff := nqp::sub_n(nqp::time_n(), $timestamp);
if nqp::defined($stagestats) {
$stderr.print(nqp::sprintf("%7.3f", [$diff]));
$!backend.force_gc() if nqp::bitand_i($stagestats, 0x4);
$stderr.print($!backend.vmstat())
if nqp::bitand_i($stagestats, 0x2);
$stderr.print("\n");
if nqp::bitand_i($stagestats, 0x8) {
$stderr.print("continue> ");
$stdin.get;
}
}
last if $_ eq $target;
}
if %adverbs<compunit_ok> {
return $result
}
else {
return $!backend.compunit_mainline($result);
}
}
method start($source, *%adverbs) {
$source;
}
method parse($source, *%adverbs) {
my $s := $source;
my $grammar;
my $actions;
if %adverbs<transcode> {
$s := $!backend.apply_transcodings($s, %adverbs<transcode>);
}
my $outer_ctx := %adverbs<outer_ctx>;
if nqp::existskey(%adverbs, 'grammar') {
$grammar := %adverbs<grammar>;
$actions := %adverbs<actions>;
}
else {
$grammar := self.parsegrammar;
$actions := self.parseactions;
}
$grammar.HOW.trace-on($grammar) if %adverbs<rxtrace>;
my $match := $grammar.parse($s, p => 0, actions => $actions);
$grammar.HOW.trace-off($grammar) if %adverbs<rxtrace>;
self.panic('Unable to parse source') unless $match;
return $match;
}
method ast($source, *%adverbs) {
my $ast := $source.ast();
self.panic("Unable to obtain AST from " ~ $source.HOW.name($source))
unless nqp::istype($ast, QAST::Node);
$ast;
}
method dumper($obj, $name, *%options) {
if nqp::can($obj, 'dump') {
my $out := stdout();
$out.print($obj.dump());
$out.flush();
}
elsif nqp::isstr($obj) {
my $out := stdout();
$out.print($obj);
$out.flush();
}
else {
nqp::die("Cannot dump this object; no dump method");
}
}
method usage($name?, :$use-stderr = False) {
my $print-func := $use-stderr ?? &note !! &say; # RT #130760
if $name {
$print-func($name);
}
my $usage := "This compiler is based on HLL::Compiler.\n\nOptions:\n";
for @!cmdoptions {
$usage := $usage ~ " $_\n";
}
$print-func($usage);
nqp::exit(0);
}
method version() {
my $version := %!config<version>;
my $backver := $!backend.version_string();
my $implementation := self.implementation();
my $language_name := self.language_name();
if nqp::can(self, 'language_version') {
nqp::say("This is $implementation version $version built on $backver\n" ~
"implementing $language_name " ~ self.language_version() ~ ".");
}
else {
nqp::say("This is $implementation version $version built on $backver");
}
nqp::exit(0);
}
method implementation() { $!language }
method language_name() { $!language }
method show-config() { self.verbose-config(); }
method verbose-config() {
my $bname := $!backend.name;
for sorted_keys($!backend.config) -> $key {
nqp::say($bname ~ '::' ~ $key ~ '=' ~ $!backend.config{$key});
}
for sorted_keys(%!config) -> $key {
nqp::say($!language ~ '::' ~ $key ~ '=' ~ %!config{$key});
}
nqp::exit(0);
}
method nqpevent(*@pos) {
$!backend.nqpevent(|@pos)
}
method removestage($stagename) {
my @new_stages := nqp::list();
for @!stages {
if $_ ne $stagename {
nqp::push(@new_stages, $_);
}
}
@!stages := @new_stages;
}
method addstage($stagename, *%adverbs) {
my $position;
my $where;
if %adverbs<before> {
$where := %adverbs<before>;
$position := 'before';
} elsif %adverbs<after> {
$where := %adverbs<after>;
$position := 'after';
} else {
my @new-stages := nqp::clone(self.stages);
nqp::push(@new-stages, $stagename);
self.stages(@new-stages);
return 1;
}
my @new-stages := nqp::list();
for self.stages {
if $_ eq $where {
if $position eq 'before' {
nqp::push(@new-stages, $stagename);
nqp::push(@new-stages, $_);
} else {
nqp::push(@new-stages, $_);
nqp::push(@new-stages, $stagename);
}
} else {
nqp::push(@new-stages, $_)
}
}
self.stages(@new-stages);
}
method parse_name($name) {
my @ns := nqp::split('::', $name);
my $sigil := nqp::substr(@ns[0], 0, 1);
# move any leading sigil to the last item
my $idx := nqp::index('$@%&', $sigil);
if $idx >= 0 {
@ns[0] := nqp::substr(@ns[0], 1);
@ns[-1] := $sigil ~ @ns[-1];
}
# remove any empty items from the list
# maybe replace with a grep() once we have the setting for sure
my @actual_ns;
for @ns {
nqp::push(@actual_ns, $_) unless $_ eq '';
}
@actual_ns;
}
method line_and_column_of($target, int $pos, int :$cache = 0) {
my $linepos;
if $cache {
# if we've previously cached c<linepos> for target, we use it.
$linepos := $*LINEPOSCACHE;
}
unless nqp::defined($linepos) {
# calculate a new linepos array.
$linepos := nqp::list_i();
if $cache {
$*LINEPOSCACHE := $linepos;
}
my str $s := ~$target;
my int $eos := nqp::chars($s);
my int $jpos := 0;
my int $ord;
# search for all of the newline markers in c<target>. when we
# find one, mark the ending offset of the line in c<linepos>.
while nqp::islt_i($jpos := nqp::findcclass(nqp::const::CCLASS_NEWLINE,
$s, $jpos, $eos), $eos)
{
$ord := nqp::ord($s, $jpos);
$jpos := nqp::add_i($jpos, 1);
nqp::push_i($linepos, $jpos);
# Treat \r\n as a single logical newline. Note that NFG
# implementations, we should check it really is a lone \r,
# not the first bit of a \r\n grapheme.
if nqp::iseq_i($ord, 13) && nqp::eqat($s, "\r", $jpos - 1) &&
$jpos < $eos && nqp::iseq_i(nqp::ord($s, $jpos), 10)
{
$jpos := nqp::add_i($jpos, 1);
}
}
}
# We have c<linepos>, so now we (binary) search the array
# for the largest element that is not greater than c<pos>.
my int $lo := 0;
my int $hi := nqp::elems($linepos);
my int $line;
while nqp::islt_i($lo, $hi) {
$line := nqp::div_i(nqp::add_i($lo, $hi), 2);
if nqp::isgt_i(nqp::atpos_i($linepos, $line), $pos) {
$hi := $line;
} else {
$lo := nqp::add_i($line, 1);
}
}
my $column := nqp::iseq_i($lo, 0)
?? $pos
!! nqp::sub_i($pos, nqp::atpos_i($linepos, nqp::sub_i($lo, 1)));
nqp::list_i(nqp::add_i($lo, 1), nqp::add_i($column, 1));
}
method lineof($target, int $pos, int :$cache = 0, int :$directives = 0) {
self.linefileof($target, $pos, :$cache, :$directives)[0]
}
method linefileof($target, int $pos, int :$cache = 0, int :$directives = 0) {
my int $line := nqp::atpos_i(self.line_and_column_of($target, $pos, :$cache), 0);
my str $file := '';
if $directives && (my @clds := @*comp_line_directives) {
my int $i := nqp::elems(@clds);
while $i > 0 {
$i := $i - 1;
last if $line > @clds[$i][0];
}
if $line > @clds[$i][0] {
my @directive := @clds[$i];
$line := $line - @directive[0] + @directive[1] - 1;
$file := @directive[2];
}
}
[$line, $file];
}
# the name of the file(s) that are executed, or -e or 'interactive'
method user-progname() { $!user_progname // 'interactive' }
# command line options and arguments as provided by the user
method cli-options() { %!cli-options }
method cli-arguments() { @!cli-arguments }
# set a recursion limit, if the backend supports it
method recursion_limit($limit) {
if nqp::can($!backend, 'recursion_limit') {
$!backend.recursion_limit($limit);
1;
}
else {
0;
}
}
method profiler-snapshot(*%args) {
my $backend;
if nqp::isconcrete(self) {
$backend := $!backend;
}
else {
$backend := self.default_backend();
}
if nqp::can($backend, 'profiler_snapshot') {
$backend.profiler_snapshot(|%args);
}
else {
nqp::die("The backend { $backend.HOW.name($backend) } doesn't support profiler-snapshot");
}
}
}
my $compiler := HLL::Compiler.new();
$compiler.language($compiler.backend.name);
You can’t perform that action at this time.