Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Added X::TypeCheck::Argument and means for the Optimizer to throw typ… 
…ed exceptions.
  • Loading branch information
@peschwa @jnthn
peschwa authored and jnthn committed Jan 23, 2014
1 parent fa1e956 commit 79079be
Show file tree
Hide file tree
Showing 2 changed files with 175 additions and 30 deletions.
191 changes: 161 additions & 30 deletions src/Perl6/Optimizer.nqp
View file
Expand Up @@ -23,14 +23,13 @@ class Perl6::Optimizer {
# Unique ID for inline args variables.
has int $!inline_arg_counter;

# Things that should cause compilation to fail; keys are errors, value is
# array of line numbers.
has %!deadly;

# Things that should be warned about; keys are warnings, value is an array
# of line numbers.
has %!worrying;

# Typed exceptions, these are all deadly currently
has @!exceptions;

# Top type, Mu, and Any (the top non-junction type).
has $!Mu;
has $!Any;
Expand All @@ -49,13 +48,14 @@ class Perl6::Optimizer {
$!chain_depth := 0;
$!pres_topic_counter := 0;
$!inline_arg_counter := 0;
%!deadly := nqp::hash();
%!worrying := nqp::hash();
my $*DYNAMICALLY_COMPILED := 0;
my $*VOID_CONTEXT := 0;
my $*IN_DECLARATION := 0;
%!foldable_junction{'&infix:<|>'} := '&infix:<||>';
%!foldable_junction{'&infix:<&>'} := '&infix:<&&>';

@!exceptions := [];

# until there's a good way to figure out flattening at compile time,
# don't support these junctions
Expand Down Expand Up @@ -92,18 +92,22 @@ class Perl6::Optimizer {
# Walk and optimize the program.
self.visit_block($unit);

# Die if we failed check in any way; otherwise, print any warnings.
if +%!deadly {
my @fails;
for %!deadly {
my @parts := nqp::split("\n", $_.key);
my $headline := @parts.shift();
@fails.push("$headline (line" ~ (+$_.value == 1 ?? ' ' !! 's ') ~
join(', ', $_.value) ~ ")" ~
(+@parts ?? "\n" ~ join("\n", @parts) !! ""));
if +@!exceptions {
if +@!exceptions > 1 {
my $x_comp_group_sym := self.find_symbol(['X', 'Comp', 'Group']);
my @exs := [];
for @!exceptions {
nqp::push(@exs, $_);
}
my $x_comp_group := $x_comp_group_sym.new(:sorrows(@exs));
$x_comp_group.throw();
}
else {
@!exceptions[0].throw();
}
nqp::die("CHECK FAILED:\n" ~ join("\n", @fails))
}

# We didn't die from any Exception, so we print warnings now.
if +%!worrying {
my $err := nqp::getstderr();
nqp::printfh($err, "WARNINGS:\n");
Expand Down Expand Up @@ -551,7 +555,9 @@ class Perl6::Optimizer {
# time error. Check that it's not just compile-time unknown,
# however (shows up in e.g. sub foo(&x) { x() }).
unless self.is_lexical_declared($op.name) {
self.add_deadly($op, "Undefined routine '" ~ $op.name ~ "' called");
# I have trouble coming up with a test-case that reaches here.
# Additionally the suggestions are missing.
self.add_exception(['X', 'Undeclared'], $op, :symbol($op.name));
}
}
}
Expand All @@ -576,7 +582,10 @@ class Perl6::Optimizer {
}
}
else {
self.add_deadly($op, "Undefined private method '" ~ $name ~ "' called");
# Similarly to the case for X::Undeclared above,
# I have trouble finding a test-case here.
self.add_exception(['X', 'Method', 'NotFound'], $op,
:private(nqp::p6bool(1)), :typename($op.name), :$name);
}
}
}
Expand Down Expand Up @@ -704,6 +713,61 @@ class Perl6::Optimizer {

[@types, @flags]
}

method add_exception(@name, $op, *%opts) {
%opts<line> := HLL::Compiler.lineof($op.node.orig, $op.node.from, :cache(1));
%opts<modules> := $*W.p6ize_recursive(@*MODULES);

# get line numbers - we can't use $*W.locprepost here
# because the cursor has .from as .pos
# in contrast to node
my $pos := $op.node.from;
my $orig := $op.node.orig;

my $prestart := $pos - 40;
$prestart := 0 if $prestart < 0;
my $pre := nqp::substr($orig, $prestart, $pos - $prestart);
$pre := subst($pre, /.*\n/, "", :global);
$pre := '<BOL>' if $pre eq '';

my $postchars := $pos + 40 > nqp::chars($orig) ?? nqp::chars($orig) - $pos !! 40;
my $post := nqp::substr($orig, $pos, $postchars);
$post := subst($post, /\n.*/, "", :global);
$post := '<EOL>' if $post eq '';

%opts<pre> := nqp::box_s($pre, self.find_symbol(['Str']));
%opts<post> := nqp::box_s($post, self.find_symbol(['Str']));

%opts<is-compile-time> := nqp::p6bool(1);

for %opts -> $p {
if nqp::islist($p.value) {
my @a := [];
for $p.value {
nqp::push(@a, nqp::hllizefor($_, 'perl6'));
}
%opts{$p.key} := nqp::hllizefor(@a, 'perl6');
}
else {
%opts{$p.key} := nqp::hllizefor($p.value, 'perl6');
}
}
my $file := nqp::getlexdyn('$?FILES');
%opts<filename> := nqp::box_s(
(nqp::isnull($file) ?? '<unknown file>' !! $file),
self.find_symbol(['Str'])
);

my $exsym := self.find_symbol(@name);
my $x_comp := self.find_symbol(['X', 'Comp']);

unless nqp::istype($exsym, $x_comp) {
$exsym := $exsym.HOW.mixin($exsym, $x_comp);
}

my $ex := $exsym.new(|%opts);
nqp::push(@!exceptions, $ex);
}

method report_inevitable_dispatch_failure($op, @types, @flags, $obj, :$protoguilt) {
my @arg_names;
Expand All @@ -716,15 +780,16 @@ class Perl6::Optimizer {
@types[$i].HOW.name(@types[$i]));
$i := $i + 1;
}
self.add_deadly($op,
($protoguilt ?? "Calling proto of '" !! "Calling '") ~
$obj.name ~ "' " ~
(+@arg_names == 0
?? "requires arguments"
!! "will never work with argument types (" ~ join(', ', @arg_names) ~ ")"),
$obj.is_dispatcher && !$protoguilt ??

my %opts := nqp::hash();
%opts<protoguilt> := $protoguilt // nqp::p6bool(0);
%opts<arguments> := @arg_names;
%opts<objname> := $obj.name;
%opts<signature> := $obj.is_dispatcher && !$protoguilt ??
multi_sig_list($obj) !!
[" Expected: " ~ try $obj.signature.perl ]);
[" Expected: " ~ try $obj.signature.perl ];

self.add_exception(['X', 'TypeCheck', 'Argument'], $op, |%opts);
}

# Signature list for multis.
Expand Down Expand Up @@ -773,6 +838,76 @@ class Perl6::Optimizer {
}
}

# The following function is a nearly 1:1 copy of World.find_symbol.
# Finds a symbol that has a known value at compile time from the
# perspective of the current scope. Checks for lexicals, then if
# that fails tries package lookup.
method find_symbol(@name) {
# Make sure it's not an empty name.
unless +@name { nqp::die("Cannot look up empty name"); }

# GLOBAL is current view of global.
if +@name == 1 && @name[0] eq 'GLOBAL' {
return $*GLOBALish;
}

# If it's a single-part name, look through the lexical
# scopes.
if +@name == 1 {
my $final_name := @name[0];
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my %sym := @!block_stack[$i].symbol($final_name);
if +%sym {
if nqp::existskey(%sym, 'value') {
return %sym<value>;
}
else {
nqp::die("No compile-time value for $final_name");
}
}
}
}

# If it's a multi-part name, see if the containing package
# is a lexical somewhere. Otherwise we fall back to looking
# in GLOBALish.
my $result := $*GLOBALish;
if +@name >= 2 {
my $first := @name[0];
my int $i := +@!block_stack;
while $i > 0 {
$i := $i - 1;
my %sym := @!block_stack[$i].symbol($first);
if +%sym {
if nqp::existskey(%sym, 'value') {
$result := %sym<value>;
@name := nqp::clone(@name);
@name.shift();
$i := 0;
}
else {
nqp::die("No compile-time value for $first");
}
}
}
}

# Try to chase down the parts of the name.
for @name {
if nqp::existskey($result.WHO, ~$_) {
$result := ($result.WHO){$_};
}
else {
nqp::die("Could not locate compile-time value for symbol " ~
join('::', @name));
}
}

$result;
}

# Locates a lexical symbol and returns its compile time value. Dies if
# it does not exist.
method find_lexical($name) {
Expand Down Expand Up @@ -937,10 +1072,6 @@ class Perl6::Optimizer {
$call
}

# Adds an entry to the list of things that would cause a check fail.
method add_deadly($past_node, $message, @extras?) {
self.add_memo($past_node, $message, @extras, :type<deadly>);
}
# Adds an entry to the list of things that would just warn
method add_worry($past_node, $message, @extras?) {
self.add_memo($past_node, $message, @extras, :type<worry>);
Expand All @@ -950,7 +1081,7 @@ class Perl6::Optimizer {
my $mnode := $past_node.node;
my $line := HLL::Compiler.lineof($mnode.orig, $mnode.from, :cache(1));
my $key := $message ~ (+@extras ?? "\n" ~ join("\n", @extras) !! "");
my %cont := $type eq 'deadly' ?? %!deadly !! %!worrying;
my %cont := %!worrying;
unless %cont{$key} {
%cont{$key} := [];
}
Expand Down
14 changes: 14 additions & 0 deletions src/core/Exception.pm
View file
Expand Up @@ -1176,6 +1176,20 @@ my class X::TypeCheck::Assignment is X::TypeCheck {
!! "Type check failed in assignment; expected '{$.expected.^name}' but got '{$.got.^name}'";
}
}
my class X::TypeCheck::Argument is X::TypeCheck {
has $.protoguilt;
has @.arguments;
has $.objname;
has $.signature;
method message {
($.protoguilt ?? "Calling proto of '" !! "Calling '") ~
$.objname ~ "' " ~
(+@.arguments == 0
?? "requires arguments\n"
!! "will never work with argument types (" ~ join(', ', @.arguments) ~ ")\n")
~ $.signature
}
}

my class X::TypeCheck::Splice is X::TypeCheck does X::Comp {
has $.action;
Expand Down

0 comments on commit 79079be

Please sign in to comment.