performance enhancements

diff --git a/Changes b/Changes
index 5dd4f62..a79f3ea 100644 (file)
--- a/Changes
+++ b/Changes
@@ -5,6 +5,17 @@ Revision history for Perl extension Moose
       - fixed minor issue which occasionally 
         comes up during global destruction 
         (thanks omega)
+        
+    * Moose::Meta::Attribute
+      - changed how we do type checks so that 
+        we reduce the overall cost by approx. 
+        factor of 5
+          
+    * Moose::Meta::TypeConstraint
+      - changed how constraints are compiled
+        so that we do less recursion and more
+        iteration. This makes the type check 
+        faster :)
 
 0.14 Mon. Oct. 9, 2006
 

diff --git a/benchmarks/type_constraints.pl b/benchmarks/type_constraints.pl
new file mode 100644 (file)
index 0000000..7b1469b
--- /dev/null
+++ b/benchmarks/type_constraints.pl
@@ -0,0 +1,34 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Benchmark qw[cmpthese];
+
+{
+    package Foo;
+    use Moose;
+    use Moose::Util::TypeConstraints;
+    
+    has 'baz' => (is => 'rw');
+    has 'bar' => (is => 'rw', isa => 'Foo');
+    has 'boo' => (is => 'rw', isa => type 'CustomFoo' => where { blessed($_) && $_->isa('Foo') });
+}
+
+my $foo = Foo->new;
+
+cmpthese(200_000, 
+    {
+        'w/out_constraint' => sub {
+            $foo->baz($foo);
+        },
+        'w_constraint' => sub {
+            $foo->bar($foo);            
+        },
+        'w_custom_constraint' => sub {
+            $foo->boo($foo);            
+        },        
+    }
+);
+
+1;
\ No newline at end of file

diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index f94c875..878f8cd 100644 (file)
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -234,7 +234,7 @@ sub _inline_check_constraint {
        
        # FIXME - remove 'unless defined($value) - constraint Undef
        return sprintf <<'EOF', $value, $value, $value, $value
-defined($attr->type_constraint->check(%s))
+defined($type_constraint->(%s))
        || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
        . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
   if defined(%s);
@@ -263,7 +263,7 @@ sub _inline_check_lazy {
            return 'unless (exists $_[0]->{$attr_name}) {' .
                   '    if ($attr->has_default) {' .
                   '        my $default = $attr->default($_[0]);' .
-               '        (defined($attr->type_constraint->check($default)))' .
+               '        (defined($type_constraint->($default)))' .
                '               || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
                '               . $attr->type_constraint->name . ") with " . (defined($default) ? "\'$default\'" : "undef")' .
                '          if defined($default);' .                     
@@ -344,6 +344,13 @@ sub generate_accessor_method {
     . $attr->_inline_check_lazy
     . 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
     . ' }';
+    
+    # NOTE:
+    # set up the environment
+    my $type_constraint = $attr->type_constraint 
+                                ? $attr->type_constraint->_compiled_type_constraint
+                                : undef;
+    
     my $sub = eval $code;
     confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
     return $sub;    
@@ -360,6 +367,13 @@ sub generate_writer_method {
        . $attr->_inline_store($inv, $value_name)
        . $attr->_inline_trigger($inv, $value_name)
     . ' }';
+    
+    # NOTE:
+    # set up the environment
+    my $type_constraint = $attr->type_constraint 
+                                ? $attr->type_constraint->_compiled_type_constraint
+                                : undef;    
+    
     my $sub = eval $code;
     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
     return $sub;    

diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm
index 7f03b58..e67e6f3 100644 (file)
--- a/lib/Moose/Meta/TypeConstraint.pm
+++ b/lib/Moose/Meta/TypeConstraint.pm
@@ -9,7 +9,7 @@ use Sub::Name    'subname';
 use Carp         'confess';
 use Scalar::Util 'blessed';
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 __PACKAGE__->meta->add_attribute('name'       => (reader => 'name'      ));
 __PACKAGE__->meta->add_attribute('parent'     => (reader => 'parent'    ));
@@ -39,6 +39,17 @@ sub coerce {
     ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) 
 }
 
+sub _collect_all_parents {
+    my $self = shift;
+    my @parents;
+    my $current = $self->parent;
+    while (defined $current) {
+        unshift @parents => $current;
+        $current = $current->parent;
+    }
+    return @parents;
+}
+
 sub compile_type_constraint {
     my $self  = shift;
     my $check = $self->constraint;
@@ -46,13 +57,21 @@ sub compile_type_constraint {
         || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
     my $parent = $self->parent;
     if (defined $parent) {
-        # we have a subtype ...
-        $parent = $parent->_compiled_type_constraint;
+        # we have a subtype ...    
+        # so we gather all the parents in order
+        # and grab their constraints ...
+        my @parents = map { $_->constraint } $self->_collect_all_parents;
+        # then we compile them to run without
+        # having to recurse as we did before
                $self->_compiled_type_constraint(subname $self->name => sub {                   
                        local $_ = $_[0];
-                       return undef unless defined $parent->($_[0]) && $check->($_[0]);
+            foreach my $parent (@parents) {
+                return undef unless $parent->($_[0]);
+            }
+                       return undef unless $check->($_[0]);
                        1;
                });        
+                
     }
     else {
         # we have a type ....
@@ -115,7 +134,7 @@ use strict;
 use warnings;
 use metaclass;
 
-our $VERSION = '0.02';
+our $VERSION = '0.03';
 
 __PACKAGE__->meta->add_attribute('type_constraints' => (
     accessor  => 'type_constraints',
@@ -173,13 +192,21 @@ sub coerce {
     return undef;    
 }
 
+sub _compiled_type_constraint {
+    my $self  = shift;
+    return sub {
+        my $value = shift;
+        foreach my $type (@{$self->type_constraints}) {
+            return 1 if $type->check($value);
+        }
+        return undef;    
+    }
+}
+
 sub check {
     my $self  = shift;
     my $value = shift;
-    foreach my $type (@{$self->type_constraints}) {
-        return 1 if $type->check($value);
-    }
-    return undef;
+    $self->_compiled_type_constraint->($value);
 }
 
 sub validate {