From: Stevan Little 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 {