From: Dave Rolsky <autarch@urth.org>
Date: Tue, 21 Sep 2010 05:00:31 +0000 (-0500)
Subject: Refactored native trait inlining some more - added an optimized path to avoid copying... 
X-Git-Tag: 1.15~129
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e32b74894c664aec6fba53a8926f82ea546b4232;p=gitmo%2FMoose.git

Refactored native trait inlining some more - added an optimized path to avoid copying data whenever possible
---

diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
index 1119a4d..768337a 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/Writer.pm
@@ -23,9 +23,9 @@ sub _inline_copy_value {
 
     return q{} unless $self->_value_needs_copy;
 
-    my $code = "my \@potential = ${$potential_ref};";
+    my $code = "my \$potential = ${$potential_ref};";
 
-    ${$potential_ref} = '@potential';
+    ${$potential_ref} = '$potential';
 
     return $code;
 }
@@ -48,8 +48,8 @@ sub _inline_tc_code {
         return $self->_inline_check_member_constraint($new_value);
     }
     else {
-        return $self->_inline_check_coercion( '\\' . $potential_value ) . "\n"
-            . $self->_inline_check_constraint( '\\' . $potential_value );
+        return $self->_inline_check_coercion($potential_value) . "\n"
+            . $self->_inline_check_constraint($potential_value);
     }
 }
 
@@ -107,10 +107,7 @@ sub _inline_check_coercion {
     return ''
         unless $attr->should_coerce && $attr->type_constraint->has_coercion;
 
-    # We want to break the aliasing in @_ in case the coercion tries to make a
-    # destructive change to an array member.
-    my $code = 'my @copy = @{ $value }';
-    return '@_ = @{ $attr->type_constraint->coerce(\@copy) };';
+    return "$value = \$type_constraint_obj->coerce($value);";
 }
 
 sub _inline_check_constraint {
@@ -121,15 +118,20 @@ sub _inline_check_constraint {
     return $self->SUPER::_inline_check_constraint( $_[0] );
 }
 
-sub _capture_old_value { return q{} }
+sub _inline_get_old_value_for_trigger {
+    my ( $self, $instance ) = @_;
 
-sub _inline_set_new_value {
-    my ( $self, $inv, $new ) = @_;
+    my $attr = $self->associated_attribute;
+    return '' unless $attr->has_trigger;
+
+    my $mi = $attr->associated_class->get_meta_instance;
+    my $pred = $mi->inline_is_slot_initialized( $instance, $attr->name );
 
-    return $self->SUPER::_inline_store(
-        $inv,
-        $self->_value_needs_copy ? '\\' . $new : '[' . $new . ']'
-    );
+    return
+          'my @old = '
+        . $pred . q{ ? } . '[ @{'
+        . $self->_inline_get($instance)
+        . '} ] : ()' . ";\n";
 }
 
 sub _return_value      { return q{} }
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
index 8dcbf1f..a35b729 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm
@@ -51,11 +51,12 @@ sub _generate_method {
     $code .= "\n"
         . $self->_inline_tc_code(
         $new_values,
-        $potential_value
+        $potential_value,
+        $slot_access,
         );
 
     $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
-    $code .= "\n" . $self->_capture_old_value($slot_access);
+    $code .= "\n" . $self->_inline_capture_return_value($slot_access);
 
     $code
         .= "\n" . $self->_inline_store( $inv, '[' . $potential_value . ']' );
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm
index c991ca5..c273d55 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/clear.pm
@@ -15,4 +15,10 @@ sub _adds_members { 0 }
 
 sub _potential_value { return '()' }
 
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "$slot_access = [];";
+}
+
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm
index c203026..c5aeea5 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/delete.pm
@@ -25,7 +25,13 @@ sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
     return
-        "( do { my \@potential = \@{ $slot_access }; splice \@potential, \$_[0], 1; \@potential } )";
+        "( do { my \@potential = \@{ $slot_access }; splice \@potential, \$_[0], 1; \\\@potential } )";
+}
+
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "splice \@{ $slot_access }, \$_[0], 1;";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm
index dd45365..b5b40ee 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/insert.pm
@@ -19,9 +19,15 @@ sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
     return
-        "( do { my \@potential = \@{ $slot_access }; splice \@potential, \$_[0], 0, \$_[1]; \@potential } )";
+        "( do { my \@potential = \@{ $slot_access }; splice \@potential, \$_[0], 0, \$_[1]; \\\@potential } )";
 }
 
 sub _new_values { '$_[1]' }
 
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "splice \@{ $slot_access }, \$_[0], 0, \$_[1];";
+}
+
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm
index a16fb98..a04abd7 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/pop.pm
@@ -16,24 +16,25 @@ sub _adds_members { 0 }
 sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
-    return "( \@{ $slot_access } > 1 ? \@{ $slot_access }[ 0 .. \$#{ $slot_access } - 1 ] : () )";
+    return "[ \@{ $slot_access } > 1 ? \@{ $slot_access }[ 0 .. \$#{ $slot_access } - 1 ] : () ]";
 }
 
-sub _capture_old_value {
+sub _inline_capture_return_value {
     my ( $self, $slot_access ) = @_;
 
-    if ( $self->associated_attribute->has_trigger ) {
-        return 'my $old = $old[-1];';
-    }
-    else {
-        return "my \$old = $slot_access;";
-    }
+    return "my \$old = ${slot_access}->[-1];";
+}
+
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "pop \@{ $slot_access };";
 }
 
 sub _return_value {
-    my ( $self, $instance, $old_value ) = @_;
+    my ( $self, $slot_access ) = @_;
 
-    return 'return @{$old} ? $old->[-1] : undef;';
+    return 'return $old;';
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm
index c2b3125..a8975c7 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/push.pm
@@ -14,7 +14,13 @@ sub _adds_members { 1 }
 sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
-    return "( \@{ $slot_access }, \@_ )";
+    return "[ \@{ $slot_access }, \@_ ]";
+}
+
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "push \@{ $slot_access }, \@_;";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm
index 9fdd85b..f8541d8 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/set.pm
@@ -25,9 +25,15 @@ sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
     return
-        "( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \@potential } )";
+        "( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \\\@potential } )";
 }
 
 sub _new_values { '$_[1]' }
 
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "${slot_access}->[ \$_[0] ] = \$_[1];";
+}
+
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm
index f3a7f85..3ed2feb 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/shift.pm
@@ -16,24 +16,25 @@ sub _adds_members { 0 }
 sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
-    return "( \@{ $slot_access } > 1 ? \@{ $slot_access }[ 1 .. \$#{ $slot_access } ] : () )";
+    return "[ \@{ $slot_access } > 1 ? \@{ $slot_access }[ 1 .. \$#{ $slot_access } ] : () ]";
 }
 
-sub _capture_old_value {
+sub _inline_capture_return_value {
     my ( $self, $slot_access ) = @_;
 
-    if ( $self->associated_attribute->has_trigger ) {
-        return 'my $old = $old[-1];';
-    }
-    else {
-        return "my \$old = $slot_access;";
-    }
+    return "my \$old = ${slot_access}->[0];";
+}
+
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "shift \@{ $slot_access };";
 }
 
 sub _return_value {
-    my ( $self, $instance, $old_value ) = @_;
+    my ( $self, $slot_access ) = @_;
 
-    return 'return $old->[0]';
+    return 'return $old';
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm
index 3e14269..cde5f64 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/sort_in_place.pm
@@ -25,7 +25,7 @@ sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
     return
-        "( \$_[0] ? sort { \$_[0]->( \$a, \$b ) } \@{ $slot_access } : sort \@{ $slot_access} )";
+        "[ \$_[0] ? sort { \$_[0]->( \$a, \$b ) } \@{ $slot_access } : sort \@{ $slot_access} ]";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm
index 087898b..545c5e5 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/splice.pm
@@ -30,7 +30,13 @@ sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
     return "( do { my \@potential = \@{ $slot_access };"
-        . 'defined $len ? ( splice @potential, $idx, $len, @_ ) : ( splice @potential, $idx ); @potential } )';
+        . 'defined $len ? ( splice @potential, $idx, $len, @_ ) : ( splice @potential, $idx ); \\@potential } )';
+}
+
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "defined \$len ? ( splice \@{ $slot_access }, \$idx, \$len, \@_ ) : ( splice \@{ $slot_access }, \$idx );";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm
index 27f6b53..22a0d45 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Array/unshift.pm
@@ -14,7 +14,13 @@ sub _adds_members { 1 }
 sub _potential_value {
     my ( $self, $slot_access ) = @_;
 
-    return "( \@_, \@{ $slot_access } )";
+    return "[ \@_, \@{ $slot_access } ]";
+}
+
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "unshift \@{ $slot_access }, \@_;";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/append.pm b/lib/Moose/Meta/Method/Accessor/Native/String/append.pm
index 0c31f30..7652d87 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/append.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/append.pm
@@ -18,4 +18,10 @@ sub _potential_value {
     return "( $slot_access . \$_[0] )";
 }
 
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "$slot_access .= \$_[0];";
+}
+
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm b/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm
index df69b61..eb2e333 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/chomp.pm
@@ -18,15 +18,10 @@ sub _potential_value {
     return "( do { my \$val = $slot_access; chomp \$val; \$val } )";
 }
 
-sub _inline_set_new_value {
-    my ( $self, $inv, $new ) = @_;
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
 
-    return $self->SUPER::_inline_set_new_value(@_)
-        if $self->_value_needs_copy;
-
-    my $slot_access = $self->_inline_get($inv);
-
-    return "chomp ${slot_access}";
+    return "chomp $slot_access;";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm b/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm
index b6a9a24..118eec8 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/chop.pm
@@ -18,15 +18,10 @@ sub _potential_value {
     return "( do { my \$val = $slot_access; chop \$val; \$val } )";
 }
 
-sub _inline_set_new_value {
-    my ( $self, $inv, $new ) = @_;
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
 
-    return $self->SUPER::_inline_set_new_value(@_)
-        if $self->_value_needs_copy;
-
-    my $slot_access = $self->_inline_get($inv);
-
-    return "chop ${slot_access}";
+    return "chop $slot_access;";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm b/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm
index 2acebea..95ea12b 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/clear.pm
@@ -18,15 +18,10 @@ sub _potential_value {
     return "q{}";
 }
 
-sub _inline_set_new_value {
-    my ( $self, $inv, $new ) = @_;
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
 
-    return $self->SUPER::_inline_set_new_value(@_)
-        if $self->_value_needs_copy;
-
-    my $slot_access = $self->_inline_get($inv);
-
-    return "${slot_access} = q{}";
+    return "$slot_access = q{};";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm b/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm
index 156575a..bdbfb57 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/inc.pm
@@ -18,15 +18,10 @@ sub _potential_value {
     return "( do { my \$val = $slot_access; \$val++ } )";
 }
 
-sub _inline_set_new_value {
-    my ( $self, $inv, $new ) = @_;
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
 
-    return $self->SUPER::_inline_set_new_value(@_)
-        if $self->_value_needs_copy;
-
-    my $slot_access = $self->_inline_get($inv);
-
-    return "${slot_access}++";
+    return "${slot_access}++;";
 }
 
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm b/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm
index 2a115b2..afa145b 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/prepend.pm
@@ -18,4 +18,10 @@ sub _potential_value {
     return "( \$_[0] . $slot_access )";
 }
 
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
+
+    return "$slot_access = \$_[0] . $slot_access;";
+}
+
 1;
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm
index 76880cf..780f099 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/replace.pm
@@ -30,13 +30,8 @@ sub _potential_value {
     return "( do { my \$val = $slot_access; ref \$_[1] ? \$val =~ s/\$_[0]/\$_[1]->()/e : \$val =~ s/\$_[0]/\$_[1]/; \$val } )";
 }
 
-sub _inline_set_new_value {
-    my ( $self, $inv, $new ) = @_;
-
-    return $self->SUPER::_inline_set_new_value(@_)
-        if $self->_value_needs_copy;
-
-    my $slot_access = $self->_inline_get($inv);
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
 
     return "if ( ref \$_[1] ) { $slot_access =~ s/\$_[0]/\$_[1]->()/e; } else { $slot_access =~ s/\$_[0]/\$_[1]/; }";
 }
diff --git a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm
index 0a43e8a..2dd8c42 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/String/substr.pm
@@ -87,13 +87,8 @@ sub _potential_value {
         "( do { my \$potential = $slot_access; substr \$potential, \$offset, \$length, \$replacement; \$potential; } )";
 }
 
-sub _inline_set_new_value {
-    my ( $self, $inv, $new ) = @_;
-
-    return $self->SUPER::_inline_set_new_value(@_)
-        if $self->_value_needs_copy;
-
-    my $slot_access = $self->_inline_get($inv);
+sub _inline_optimized_set_new_value {
+    my ( $self, $inv, $new, $slot_access ) = @_;
 
     return "substr $slot_access, \$offset, \$length, \$replacement;";
 }
diff --git a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
index 39a6f68..d304e28 100644
--- a/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
+++ b/lib/Moose/Meta/Method/Accessor/Native/Writer.pm
@@ -55,14 +55,15 @@ sub _writer_core {
         );
 
     $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
-    $code .= "\n" . $self->_capture_old_value($slot_access);
+    $code .= "\n" . $self->_inline_capture_return_value($slot_access);
     $code .= "\n"
         . $self->_inline_set_new_value(
         $inv,
-        $potential_value
+        $potential_value,
+        $slot_access,
         );
     $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
-    $code .= "\n" . $self->_return_value( $inv, '@old', 'for writer' );
+    $code .= "\n" . $self->_return_value( $slot_access, 'for writer' );
 
     return $code;
 }
@@ -93,12 +94,21 @@ sub _constraint_must_be_checked {
     die '_constraint_must_be_checked must be overridden by ' . ref $_[0];
 }
 
-sub _capture_old_value { return q{} }
+sub _inline_capture_return_value { return q{} }
 
 sub _inline_set_new_value {
     my $self = shift;
 
-    return $self->SUPER::_inline_store(@_);
+    return $self->SUPER::_inline_store(@_)
+        if $self->_value_needs_copy;
+
+    return $self->_inline_optimized_set_new_value(@_);
+}
+
+sub _inline_optimized_set_new_value {
+    my $self = shift;
+
+    return $self->SUPER::_inline_store(@_)
 }
 
 sub _return_value { return q{} }
diff --git a/t/070_native_traits/002_trait_array.t b/t/070_native_traits/002_trait_array.t
index dc7d095..7271f41 100644
--- a/t/070_native_traits/002_trait_array.t
+++ b/t/070_native_traits/002_trait_array.t
@@ -118,6 +118,11 @@ sub run_tests {
         lives_ok { $obj->unshift( 101, 22 ) }
         'unshifted two values and lived';
 
+        is_deeply(
+            $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ],
+            'unshift changed the value of the array in the object'
+        );
+
         lives_ok { $obj->unshift() }
         'call to unshift without arguments lives';