From: Stevan Little Date: Fri, 10 Nov 2006 16:12:30 +0000 (+0000) Subject: It Works, *AND* Its Fast(er) X-Git-Tag: 0_18_002~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8ecb1fa00856ddb07f4e006c79fe4c48e08902c0;p=gitmo%2FMoose.git It Works, *AND* Its Fast(er) --- diff --git a/benchmarks/immutable.pl b/benchmarks/immutable.pl index c9ad538..ac11614 100644 --- a/benchmarks/immutable.pl +++ b/benchmarks/immutable.pl @@ -8,19 +8,16 @@ use Benchmark qw[cmpthese]; use Moose::Util::TypeConstraints; -BEGIN { - subtype 'Foo' => as 'Object' => where { blessed($_) && $_->isa('Foo') }; - - coerce 'Foo' - => from 'ArrayRef' - => via { Foo->new(@{$_}) }; -} - { package Foo; use Moose; + Foo->meta->make_immutable(debug => 0); } +coerce 'Foo' + => from 'ArrayRef' + => via { Foo->new(@{$_}) }; + { package Foo::Normal; use Moose; @@ -64,14 +61,16 @@ cmpthese(500, Foo::Normal->new( required => 'BAR', type_constraint => $foo, - #coercion => [], + coercion => [], + weak_ref => {}, ); }, 'immutable' => sub { Foo::Immutable->new( required => 'BAR', type_constraint => $foo, - #coercion => [], + coercion => [], + weak_ref => {}, ); }, } diff --git a/benchmarks/type_constraints.pl b/benchmarks/type_constraints.pl index 1c53e6e..2e87d83 100644 --- a/benchmarks/type_constraints.pl +++ b/benchmarks/type_constraints.pl @@ -23,10 +23,25 @@ all vs. a custom-created type. #has 'boo' => (is => 'rw', isa => type 'CustomFoo' => where { blessed($_) && $_->isa('Foo') }); } +{ + package Bar; + + sub new { bless {} => __PACKAGE__ } + sub bar { + my $self = shift; + $self->{bar} = shift if @_; + $self->{bar}; + } +} + my $foo = Foo->new; +my $bar = Bar->new; cmpthese(200_000, { + 'hand coded' => sub { + $bar->bar($bar); + }, 'w/out_constraint' => sub { $foo->baz($foo); }, diff --git a/lib/Moose.pm b/lib/Moose.pm index fa6b012..632ec6c 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -36,6 +36,7 @@ use Moose::Util::TypeConstraints; subtype $class => as 'Object' => where { $_->isa($class) } + => optimize_as { blessed($_[0]) && $_[0]->isa($class) } unless find_type_constraint($class); my $meta; @@ -248,6 +249,26 @@ sub _is_class_already_loaded { return 0; } +## make 'em all immutable + +$_->meta->make_immutable( + inline_constructor => 0, + inline_accessors => 0, +) for ( + 'Moose::Meta::Attribute', + 'Moose::Meta::Class', + 'Moose::Meta::Instance', + + 'Moose::Meta::TypeConstraint', + 'Moose::Meta::TypeConstraint::Union', + 'Moose::Meta::TypeCoercion', + + 'Moose::Meta::Method', + 'Moose::Meta::Method::Accessor', + 'Moose::Meta::Method::Constructor', + 'Moose::Meta::Method::Overriden', +); + 1; __END__ diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 1b4d052..a9f8915 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -212,13 +212,18 @@ sub _fix_metaclass_incompatability { foreach my $super (@superclasses) { # don't bother if it does not have a meta. next unless $super->can('meta'); + # get the name, make sure we take + # immutable classes into account + my $super_meta_name = ($super->meta->is_immutable + ? $super->meta->get_mutable_metaclass_name + : blessed($super->meta)); # if it's meta is a vanilla Moose, - # then we can safely ignore it. - next if blessed($super->meta) eq 'Moose::Meta::Class'; + # then we can safely ignore it. + next if $super_meta_name eq 'Moose::Meta::Class'; # but if we have anything else, # we need to check it out ... unless (# see if of our metaclass is incompatible - ($self->isa(blessed($super->meta)) && + ($self->isa($super_meta_name) && # and see if our instance metaclass is incompatible $self->instance_metaclass->isa($super->meta->instance_metaclass)) && # ... and if we are just a vanilla Moose diff --git a/lib/Moose/Meta/Method/Accessor.pm b/lib/Moose/Meta/Method/Accessor.pm index 0fa004c..57041a6 100644 --- a/lib/Moose/Meta/Method/Accessor.pm +++ b/lib/Moose/Meta/Method/Accessor.pm @@ -86,6 +86,10 @@ sub generate_reader_method_inline { return $sub; } +*generate_reader_method = \&generate_reader_method_inline; +*generate_writer_method = \&generate_writer_method_inline; +*generate_accessor_method = \&generate_accessor_method_inline; + ## ... private helpers sub _inline_check_constraint { @@ -222,6 +226,12 @@ role in the optimization strategy we are currently following. =over 4 +=item B + +=item B + +=item B + =item B =item B diff --git a/lib/Moose/Meta/Method/Constructor.pm b/lib/Moose/Meta/Method/Constructor.pm index d80a933..ffccd44 100644 --- a/lib/Moose/Meta/Method/Constructor.pm +++ b/lib/Moose/Meta/Method/Constructor.pm @@ -103,7 +103,7 @@ sub _generate_BUILDALL { my $self = shift; my @BUILD_calls; foreach my $method ($self->associated_metaclass->find_all_methods_by_name('BUILD')) { - push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params);'; + push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params)'; } return join "\n" => @BUILD_calls; } @@ -121,21 +121,22 @@ sub _generate_slot_initializer { '|| confess "Attribute (' . $attr->name . ') is required";'); } - push @source => 'if ($params{\'' . $attr->init_arg . '\'}) {'; - - push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};'); - if ($attr->has_type_constraint) { - push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;'); - - if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val'); - } - push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); - } - push @source => $self->_generate_slot_assignment($attr, '$val'); - if ($attr->has_default && !$attr->is_lazy) { + push @source => 'if (exists $params{\'' . $attr->init_arg . '\'}) {'; + + push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};'); + if ($attr->has_type_constraint) { + push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;'); + + if ($attr->should_coerce && $attr->type_constraint->has_coercion) { + push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val'); + } + push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); + } + push @source => $self->_generate_slot_assignment($attr, '$val'); + + push @source => "} else {"; my $default = $self->_generate_default_value($attr, $index); @@ -151,6 +152,19 @@ sub _generate_slot_initializer { push @source => "}"; } else { + push @source => '(exists $params{\'' . $attr->init_arg . '\'}) && do {'; + + push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};'); + if ($attr->has_type_constraint) { + push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;'); + + if ($attr->should_coerce && $attr->type_constraint->has_coercion) { + push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val'); + } + push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val'); + } + push @source => $self->_generate_slot_assignment($attr, '$val'); + push @source => "}"; } diff --git a/lib/Moose/Meta/TypeConstraint.pm b/lib/Moose/Meta/TypeConstraint.pm index 8d0f28a..fb85f4c 100644 --- a/lib/Moose/Meta/TypeConstraint.pm +++ b/lib/Moose/Meta/TypeConstraint.pm @@ -30,6 +30,12 @@ __PACKAGE__->meta->add_attribute('compiled_type_constraint' => ( accessor => '_compiled_type_constraint' )); +__PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => ( + init_arg => 'optimized', + accessor => 'hand_optimized_type_constraint', + predicate => 'has_hand_optimized_type_constraint', +)); + sub new { my $class = shift; my $self = $class->meta->new_object(@_); @@ -46,7 +52,7 @@ sub _collect_all_parents { my @parents; my $current = $self->parent; while (defined $current) { - unshift @parents => $current; + push @parents => $current; $current = $current->parent; } return @parents; @@ -54,6 +60,16 @@ sub _collect_all_parents { sub compile_type_constraint { my $self = shift; + + if ($self->has_hand_optimized_type_constraint) { + my $type_constraint = $self->hand_optimized_type_constraint; + $self->_compiled_type_constraint(sub { + return undef unless $type_constraint->($_[0]); + return 1; + }); + return; + } + my $check = $self->constraint; (defined $check) || confess "Could not compile type constraint '" . $self->name . "' because no constraint check"; @@ -62,7 +78,17 @@ sub compile_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; + my @parents; + foreach my $parent ($self->_collect_all_parents) { + if ($parent->has_hand_optimized_type_constraint) { + unshift @parents => $parent->hand_optimized_type_constraint; + last; + } + else { + unshift @parents => $parent->constraint; + } + } + # then we compile them to run without # having to recurse as we did before $self->_compiled_type_constraint(subname $self->name => sub { @@ -72,8 +98,7 @@ sub compile_type_constraint { } return undef unless $check->($_[0]); 1; - }); - + }); } else { # we have a type .... @@ -198,6 +223,10 @@ the C will be used to construct a custom error message. =item B +=item B + +=item B + =back =over 4 diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 8a18348..655894d 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -17,7 +17,7 @@ use Moose::Meta::TypeConstraint; use Moose::Meta::TypeCoercion; my @exports = qw/ - type subtype as where message + type subtype as where message optimize_as coerce from via enum find_type_constraint @@ -61,8 +61,17 @@ sub unimport { Data::Dumper::Dumper(\%TYPES); } - sub _create_type_constraint ($$$;$) { - my ($name, $parent, $check, $message) = @_; + sub _create_type_constraint ($$$;$$) { + my $name = shift; + my $parent = shift; + my $check = shift;; + + my ($message, $optimized); + for (@_) { + $message = $_->{message} if exists $_->{message}; + $optimized = $_->{optimized} if exists $_->{optimized}; + } + my $pkg_defined_in = scalar(caller(1)); ($TYPES{$name}->[0] eq $pkg_defined_in) || confess "The type constraint '$name' has already been created " @@ -73,6 +82,7 @@ sub unimport { parent => $parent, constraint => $check, message => $message, + optimized => $optimized, ); $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; return $constraint; @@ -115,8 +125,8 @@ sub type ($$) { _create_type_constraint($name, undef, $check); } -sub subtype ($$;$$) { - unshift @_ => undef if scalar @_ <= 2; +sub subtype ($$;$$$) { + unshift @_ => undef if scalar @_ <= 2; goto &_create_type_constraint; } @@ -129,7 +139,9 @@ sub as ($) { $_[0] } sub from ($) { $_[0] } sub where (&) { $_[0] } sub via (&) { $_[0] } -sub message (&) { $_[0] } + +sub message (&) { +{ message => $_[0] } } +sub optimize_as (&) { +{ optimized => $_[0] } } sub enum ($;@) { my ($type_name, @values) = @_; @@ -151,33 +163,61 @@ type 'Item' => where { 1 }; # base-type subtype 'Undef' => as 'Item' => where { !defined($_) }; subtype 'Defined' => as 'Item' => where { defined($_) }; -subtype 'Bool' => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; - -subtype 'Value' => as 'Defined' => where { !ref($_) }; -subtype 'Ref' => as 'Defined' => where { ref($_) }; +subtype 'Bool' + => as 'Item' + => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; -subtype 'Str' => as 'Value' => where { 1 }; - -subtype 'Num' => as 'Value' => where { Scalar::Util::looks_like_number($_) }; -subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ }; - -subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' }; -subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' }; -subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' }; -subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' }; -subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' }; -subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' }; +subtype 'Value' + => as 'Defined' + => where { !ref($_) } + => optimize_as { defined($_[0]) && !ref($_[0]) }; + +subtype 'Ref' + => as 'Defined' + => where { ref($_) } + => optimize_as { ref($_[0]) }; + +subtype 'Str' + => as 'Value' + => where { 1 } + => optimize_as { defined($_[0]) && !ref($_[0]) }; + +subtype 'Num' + => as 'Value' + => where { Scalar::Util::looks_like_number($_) } + => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) }; + +subtype 'Int' + => as 'Num' + => where { "$_" =~ /^-?[0-9]+$/ } + => optimize_as { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }; + +subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as { ref($_[0]) eq 'SCALAR' }; +subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' } => optimize_as { ref($_[0]) eq 'ARRAY' }; +subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' } => optimize_as { ref($_[0]) eq 'HASH' }; +subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => optimize_as { ref($_[0]) eq 'CODE' }; +subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as { ref($_[0]) eq 'Regexp' }; +subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => optimize_as { ref($_[0]) eq 'GLOB' }; # NOTE: # scalar filehandles are GLOB refs, # but a GLOB ref is not always a filehandle -subtype 'FileHandle' => as 'GlobRef' => where { Scalar::Util::openhandle($_) }; +subtype 'FileHandle' + => as 'GlobRef' + => where { Scalar::Util::openhandle($_) } + => optimize_as { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) }; # NOTE: # blessed(qr/.../) returns true,.. how odd -subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' }; +subtype 'Object' + => as 'Ref' + => where { blessed($_) && blessed($_) ne 'Regexp' } + => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }; -subtype 'Role' => as 'Object' => where { $_->can('does') }; +subtype 'Role' + => as 'Object' + => where { $_->can('does') } + => optimize_as { blessed($_[0]) && $_[0]->can('does') }; 1; @@ -349,6 +389,8 @@ This is just sugar for the type constraint construction syntax. This is just sugar for the type constraint construction syntax. +=item B + =back =head2 Type Coercion Constructors diff --git a/t/020_foreign_inheritence.t b/t/020_foreign_inheritence.t index 46454ed..b6ca603 100644 --- a/t/020_foreign_inheritence.t +++ b/t/020_foreign_inheritence.t @@ -34,6 +34,8 @@ BEGIN { my $super = $class->SUPER::new(@_); return $class->meta->new_object('__INSTANCE__' => $super, @_); } + + __PACKAGE__->meta->make_immutable(debug => 0); } my $foo_moose = Foo::Moose->new(); diff --git a/t/042_apply_role.t b/t/042_apply_role.t index fae8593..f94385e 100644 --- a/t/042_apply_role.t +++ b/t/042_apply_role.t @@ -27,11 +27,15 @@ BEGIN { 'FooRole::blau -> ' . $c->(); }; +}{ package BarClass; use Moose; sub boo { 'BarClass::boo' } sub foo { 'BarClass::foo' } # << the role overrides this ... + + __PACKAGE__->meta->make_immutable(debug => 0); +}{ package FooClass; use Moose; @@ -42,6 +46,8 @@ BEGIN { sub blau { 'FooClass::blau' } sub goo { 'FooClass::goo' } # << overrides the one from the role ... + + __PACKAGE__->meta->make_immutable(debug => 0); } my $foo_class_meta = FooClass->meta; diff --git a/t/202_example_Moose_POOP.t b/t/202_example_Moose_POOP.t index 1f3589f..20ab59e 100644 --- a/t/202_example_Moose_POOP.t +++ b/t/202_example_Moose_POOP.t @@ -123,7 +123,7 @@ BEGIN { } package Moose::POOP::Meta::Class; - use Moose; + use Moose; extends 'Moose::Meta::Class';