From 4c3f76931bfd9b65994f25fe40736b9728190750 Mon Sep 17 00:00:00 2001 From: jnthn Date: Wed, 1 Aug 2012 21:28:13 +0200 Subject: [PATCH] Elimination of boxable_native, and better handling of literal allomorphy. --- src/Perl6/Optimizer.pm | 61 +++++++++++++++++++++++++++--------------- src/Perl6/World.pm | 18 +++++-------- 2 files changed, 46 insertions(+), 33 deletions(-) diff --git a/src/Perl6/Optimizer.pm b/src/Perl6/Optimizer.pm index 4860dab21ad..9a0d2aff8ed 100644 --- a/src/Perl6/Optimizer.pm +++ b/src/Perl6/Optimizer.pm @@ -26,6 +26,9 @@ class Perl6::Optimizer { # of line numbers. has %!worrying; + # The type type, Mu. + has $!Mu; + # Entry point for the optimization process. method optimize($past, *%adverbs) { # Initialize. @@ -35,6 +38,7 @@ class Perl6::Optimizer { $!inline_arg_counter := 0; %!deadly := nqp::hash(); %!worrying := nqp::hash(); + $!Mu := self.find_lexical('Mu'); my $*DYNAMICALLY_COMPILED := 0; # Work out optimization level. @@ -158,7 +162,7 @@ class Perl6::Optimizer { try { if $obj.is_dispatcher { $dispatcher := 1 } } if $dispatcher { # Try to do compile-time multi-dispatch. - my @ct_arg_info := analyze_args_for_ct_call($op); + my @ct_arg_info := self.analyze_args_for_ct_call($op); if +@ct_arg_info { my @types := @ct_arg_info[0]; my @flags := @ct_arg_info[1]; @@ -185,7 +189,7 @@ class Perl6::Optimizer { } elsif nqp::can($obj, 'signature') { # If we know enough about the arguments, do a "trial bind". - my @ct_arg_info := analyze_args_for_ct_call($op); + my @ct_arg_info := self.analyze_args_for_ct_call($op); if +@ct_arg_info { my @types := @ct_arg_info[0]; my @flags := @ct_arg_info[1]; @@ -218,7 +222,7 @@ class Perl6::Optimizer { # If it's a private method call, we can sometimes resolve it at # compile time. If so, we can reduce it to a sub call in some cases. elsif $*LEVEL >= 3 && $op.op eq 'callmethod' && $op.name eq 'dispatch:' { - if $op[1].has_compile_time_value && $op[1] == 3 { + if $op[1].has_compile_time_value && nqp::istype($op[1], QAST::Want) && $op[1][1] eq 'Ss' { my $name := $op[1][2].value; # get raw string name my $pkg := $op[2].returns; # actions always sets this my $meth := $pkg.HOW.find_private_method($pkg, $name); @@ -267,38 +271,51 @@ class Perl6::Optimizer { # Checks arguments to see if we're going to be able to do compile # time analysis of the call. - sub analyze_args_for_ct_call($op) { + my @allo_map := ['', 'Ii', 'Nn', 'Ss']; + method analyze_args_for_ct_call($op) { my @types; my @flags; + my @allomorphs; + my $num_prim := 0; + my $num_allo := 0; + + # Initial analysis. for @($op) { # Can't cope with flattening or named. if $_.flat || $_.named ne '' { return []; } - # See if we know the node's type. - if $_ { - @types.push(nqp::null()); - @flags.push($_); - } - elsif nqp::can($_, 'returns') && !nqp::isnull($_.returns) { - my $type := $_.returns(); - if pir::isa($type, 'Undef') { - return []; - } - elsif $type.HOW.archetypes.generic { - return []; - } - else { - my $prim := pir::repr_get_primitive_type_spec__IP($type); - @types.push($type); - @flags.push($prim); - } + # See if we know the node's type; if so, check it. + my $type := $_.returns(); + my $ok_type := 0; + try $ok_type := nqp::istype($type, $!Mu); + if $ok_type { + my $prim := pir::repr_get_primitive_type_spec__IP($type); + my $allo := $_.has_compile_time_value && nqp::istype($_, QAST::Want) + ?? $_[1] !! ''; + @types.push($type); + @flags.push($prim); + @allomorphs.push($allo); + $num_prim := $num_prim + 1 if $prim; + $num_allo := $num_allo + 1 if $allo; } else { return []; } } + + # See if we have an allomorphic constant that may allow us to do + # a native dispatch with it; takes at least one declaratively + # native argument to make this happen. + if @types == 2 && $num_prim == 1 && $num_allo == 1 { + my $prim_flag := @flags[0] || @flags[1]; + my $allo_idx := @allomorphs[0] ?? 0 !! 1; + if @allomorphs[$allo_idx] eq @allo_map[$prim_flag] { + @flags[$allo_idx] := $prim_flag; + } + } + [@types, @flags] } diff --git a/src/Perl6/World.pm b/src/Perl6/World.pm index 3fb682fba40..98601471095 100644 --- a/src/Perl6/World.pm +++ b/src/Perl6/World.pm @@ -1069,7 +1069,8 @@ class Perl6::World is HLL::World { ~ $namedkey; } if nqp::existskey(%!const_cache, $cache_key) { - return QAST::WVal.new( :value(%!const_cache{$cache_key}) ); + my $value := %!const_cache{$cache_key}; + return QAST::WVal.new( :value($value), :returns($value.WHAT) ); } } @@ -1104,7 +1105,7 @@ class Perl6::World is HLL::World { # Build QAST for getting the boxed constant from the constants # table, but also annotate it with the constant itself in case # we need it. Add to cache. - my $qast := QAST::WVal.new( :value($constant) ); + my $qast := QAST::WVal.new( :value($constant), :returns($constant.WHAT) ); if !$nocache { %!const_cache{$cache_key} := $constant; } @@ -1134,12 +1135,7 @@ class Perl6::World is HLL::World { QAST::VM.new( :pirop('set Ns'), QAST::SVal.new( :value(~$value) ) ) !! QAST::NVal.new( :value($value) ) ); } - if $type eq 'Int' { - $past := 1; - } - elsif $type eq 'Num' { - $past := 2; - } + $past.returns($const.returns); $past; } @@ -1147,9 +1143,9 @@ class Perl6::World is HLL::World { # Returns PAST to do the lookup of the constant. method add_string_constant($value) { my $const := self.add_constant('Str', 'str', $value); - my $past := QAST::Want.new($const, 'Ss', QAST::SVal.new( :value($value) )); - $past := 3; - $past; + QAST::Want.new( + $const, :returns($const.returns), + 'Ss', QAST::SVal.new( :value($value) )); } # Adds the result of a constant folding operation to the SC and