From: Stevan Little <stevan.little@iinteractive.com>
Date: Wed, 11 Oct 2006 14:44:13 +0000 (+0000)
Subject: performance enhancements
X-Git-Tag: 0_15~4
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=431238198700daaa9506a6fff3f0fe48d15d1717;p=gitmo%2FMoose.git
performance enhancements
---
diff --git a/Changes b/Changes
index 5dd4f62..a79f3ea 100644
--- 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
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
--- 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
--- 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 {