From: Stevan Little Date: Mon, 3 Jul 2006 21:26:31 +0000 (+0000) Subject: buncha-stuff X-Git-Tag: 0_33~22 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c0cbf4d91fe34cb8a6863c6aa5dcf0a4812a5951;p=gitmo%2FClass-MOP.git buncha-stuff --- diff --git a/Changes b/Changes index 15a2be8..effc065 100644 --- a/Changes +++ b/Changes @@ -19,6 +19,10 @@ Revision history for Perl extension Class-MOP. and called *_package_symbol instead. This is because they are now more general purpose symbol table manipulation methods. + + * Class::MOP::Instance + - added an is_inlinable method to allow other + classes to check before they attempt to optimize. 0.29_02 Thurs. June 22, 2006 ++ DEVELOPER RELEASE ++ diff --git a/bench/all.yml b/bench/all.yml index 0ceb61d..c87fe93 100644 --- a/bench/all.yml +++ b/bench/all.yml @@ -2,26 +2,29 @@ - name: Point classes classes: - 'MOP::Point' - - 'MOP::Immutable::Point' - - 'MOP::Local::Point' + - 'MOP::Point3D' + - 'MOP::Immutable::Point' + - 'MOP::Immutable::Point3D' + - 'MOP::Installed::Point' + - 'MOP::Installed::Point3D' - 'Plain::Point' + - 'Plain::Point3D' benchmarks: - class: 'Bench::Construct' name: object construction args: - x: 7 y: 137 - - class: 'Bench::Accessor' - name: accessor get - construct: - x: 4 - y: 6 - accessor: x - - class: 'Bench::Accessor' - name: accessor set - construct: - x: 4 - y: 6 - accessor: x - accessor_args: [ 5 ] +# - class: 'Bench::Accessor' +# name: accessor get +# construct: +# x: 4 +# y: 6 +# accessor: x +# - class: 'Bench::Accessor' +# name: accessor set +# construct: +# x: 4 +# y: 6 +# accessor: x +# accessor_args: [ 5 ] diff --git a/bench/lib/MOP/Immutable/Point.pm b/bench/lib/MOP/Immutable/Point.pm index 0461bb8..7694f98 100644 --- a/bench/lib/MOP/Immutable/Point.pm +++ b/bench/lib/MOP/Immutable/Point.pm @@ -5,7 +5,7 @@ use strict; use warnings; use metaclass; -__PACKAGE__->meta->add_attribute('x' => (accessor => 'x')); +__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); sub new { diff --git a/bench/lib/MOP/Installed/Point.pm b/bench/lib/MOP/Installed/Point.pm index eb96573..4ad669a 100644 --- a/bench/lib/MOP/Installed/Point.pm +++ b/bench/lib/MOP/Installed/Point.pm @@ -1,11 +1,13 @@ -package MOP::Point; +use lib reverse @INC; + +package MOP::Installed::Point; use strict; use warnings; use metaclass; -__PACKAGE__->meta->add_attribute('x' => (accessor => 'x')); +__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); sub new { diff --git a/bench/lib/MOP/Installed/Point3D.pm b/bench/lib/MOP/Installed/Point3D.pm index 2bd544d..1a8bf03 100644 --- a/bench/lib/MOP/Installed/Point3D.pm +++ b/bench/lib/MOP/Installed/Point3D.pm @@ -1,5 +1,7 @@ -package MOP::Point3D; +use lib reverse @INC; + +package MOP::Installed::Point3D; use strict; use warnings; diff --git a/bench/lib/MOP/Point.pm b/bench/lib/MOP/Point.pm index eb96573..b07b8fd 100644 --- a/bench/lib/MOP/Point.pm +++ b/bench/lib/MOP/Point.pm @@ -5,7 +5,7 @@ use strict; use warnings; use metaclass; -__PACKAGE__->meta->add_attribute('x' => (accessor => 'x')); +__PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); sub new { diff --git a/bench/lib/Plain/Point.pm b/bench/lib/Plain/Point.pm index 276f493..fca27b0 100644 --- a/bench/lib/Plain/Point.pm +++ b/bench/lib/Plain/Point.pm @@ -9,7 +9,7 @@ sub new { my ( $class, %params ) = @_; return bless { - x => $params{x}, + x => $params{x} || 10, y => $params{y}, }, $class; } diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 21c5ef8..718436f 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -98,14 +98,18 @@ sub init_arg { $_[0]->{init_arg} } # end bootstrapped away method section. # (all methods below here are kept intact) +sub is_default_a_coderef { + (reftype($_[0]->{default}) && reftype($_[0]->{default}) eq 'CODE') +} + sub default { - my $self = shift; - if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') { + my ($self, $instance) = @_; + if ($instance && $self->is_default_a_coderef) { # if the default is a CODE ref, then # we pass in the instance and default # can return a value based on that # instance. Somewhat crude, but works. - return $self->{default}->(shift); + return $self->{default}->($instance); } $self->{default}; } @@ -140,6 +144,20 @@ sub generate_accessor_method { }; } +sub generate_accessor_method_inline { + my $self = shift; + my $attr_name = $self->name; + my $meta_instance = $self->associated_class->instance_metaclass; + + my $code = eval 'sub {' + . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') . ' if scalar(@_) == 2; ' + . $meta_instance->inline_get_slot_value('$_[0]', $attr_name) + . '}'; + confess "Could not generate inline accessor because : $@" if $@; + + return $code; +} + sub generate_reader_method { my $self = shift; my $attr_name = $self->name; @@ -151,6 +169,20 @@ sub generate_reader_method { }; } +sub generate_reader_method_inline { + my $self = shift; + my $attr_name = $self->name; + my $meta_instance = $self->associated_class->instance_metaclass; + + my $code = eval 'sub {' + . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;' + . $meta_instance->inline_get_slot_value('$_[0]', $attr_name) + . '}'; + confess "Could not generate inline accessor because : $@" if $@; + + return $code; +} + sub generate_writer_method { my $self = shift; my $attr_name = $self->name; @@ -161,6 +193,19 @@ sub generate_writer_method { }; } +sub generate_writer_method_inline { + my $self = shift; + my $attr_name = $self->name; + my $meta_instance = $self->associated_class->instance_metaclass; + + my $code = eval 'sub {' + . $meta_instance->inline_set_slot_value('$_[0]', $attr_name, '$_[1]') + . '}'; + confess "Could not generate inline accessor because : $@" if $@; + + return $code; +} + sub generate_predicate_method { my $self = shift; my $attr_name = $self->name; @@ -171,8 +216,21 @@ sub generate_predicate_method { }; } +sub generate_predicate_method_inline { + my $self = shift; + my $attr_name = $self->name; + my $meta_instance = $self->associated_class->instance_metaclass; + + my $code = eval 'sub {' + . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', $attr_name) . ' ? 1 : 0' + . '}'; + confess "Could not generate inline accessor because : $@" if $@; + + return $code; +} + sub process_accessors { - my ($self, $type, $accessor) = @_; + my ($self, $type, $accessor, $generate_as_inline_methods) = @_; if (reftype($accessor)) { (reftype($accessor) eq 'HASH') || confess "bad accessor/reader/writer/predicate format, must be a HASH ref"; @@ -180,7 +238,8 @@ sub process_accessors { return ($name, Class::MOP::Attribute::Accessor->wrap($method)); } else { - my $generator = $self->can('generate_' . $type . '_method'); + my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable); + my $generator = $self->can('generate_' . $type . '_method' . ($inline_me ? '_inline' : '')); ($generator) || confess "There is no method generator for the type='$type'"; if (my $method = $self->$generator($self->name)) { @@ -191,24 +250,26 @@ sub process_accessors { } sub install_accessors { - my $self = shift; - my $class = $self->associated_class; + my $self = shift; + my $inline = shift; + my $class = $self->associated_class; $class->add_method( - $self->process_accessors('accessor' => $self->accessor()) + $self->process_accessors('accessor' => $self->accessor(), $inline) ) if $self->has_accessor(); $class->add_method( - $self->process_accessors('reader' => $self->reader()) + $self->process_accessors('reader' => $self->reader(), $inline) ) if $self->has_reader(); $class->add_method( - $self->process_accessors('writer' => $self->writer()) + $self->process_accessors('writer' => $self->writer(), $inline) ) if $self->has_writer(); $class->add_method( - $self->process_accessors('predicate' => $self->predicate()) + $self->process_accessors('predicate' => $self->predicate(), $inline) ) if $self->has_predicate(); + return; } diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index bf3c0de..ceec1b4 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -628,8 +628,7 @@ sub is_mutable { 1 } sub is_immutable { 0 } sub make_immutable { - my ($class) = @_; - return Class::MOP::Class::Immutable->make_metaclass_immutable($class); + return Class::MOP::Class::Immutable->make_metaclass_immutable(@_); } 1; diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm index 5d69af6..cd066cf 100644 --- a/lib/Class/MOP/Class/Immutable.pm +++ b/lib/Class/MOP/Class/Immutable.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp 'confess'; -use Scalar::Util 'blessed'; +use Scalar::Util 'blessed', 'looks_like_number'; our $VERSION = '0.01'; @@ -43,26 +43,96 @@ sub is_immutable { 1 } sub make_immutable { () } sub make_metaclass_immutable { - my ($class, $metaclass) = @_; - $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ]; - $metaclass->{'___get_meta_instance'} = $metaclass->get_meta_instance; - $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ]; - $metaclass->{'___original_class'} = blessed($metaclass); + my ($class, $metaclass, %options) = @_; + + $options{inline_accessors} ||= 1; + $options{inline_constructor} ||= 1; + $options{constructor_name} ||= 'new'; + + my $meta_instance = $metaclass->get_meta_instance; + $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ]; + $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ]; + $metaclass->{'___get_meta_instance'} = $meta_instance; + $metaclass->{'___original_class'} = blessed($metaclass); + + if ($options{inline_accessors}) { + foreach my $attr_name ($metaclass->get_attribute_list) { + my $attr = $metaclass->get_attribute($attr_name); + $attr->install_accessors(1); # inline the accessors + } + } + + if ($options{inline_constructor}) { + $metaclass->add_method( + $options{constructor_name}, + $class->_generate_inline_constructor( + \%options, + $meta_instance, + $metaclass->{'___compute_all_applicable_attributes'} + ) + ); + } + bless $metaclass => $class; } -# cached methods - -sub get_meta_instance { (shift)->{'___get_meta_instance'} } - -sub class_precedence_list { - @{ (shift)->{'___class_precedence_list'} } +sub _generate_inline_constructor { + my ($class, $options, $meta_instance, $attrs) = @_; + # TODO: + # the %options should also include a both + # a call 'initializer' and call 'SUPER::' + # options, which should cover approx 90% + # of the possible use cases (even if it + # requires some adaption on the part of + # the author, after all, nothing is free) + my $source = 'sub {'; + $source .= "\n" . 'my ($class, %params) = @_;'; + $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class'); + $source .= ";\n" . (join ";\n" => map { + $class->_generate_slot_initializer($meta_instance, $attrs, $_) + } 0 .. (@$attrs - 1)); + $source .= ";\n" . 'return $instance'; + $source .= ";\n" . '}'; + warn $source; + my $code = eval $source; + confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; + return $code; } -sub compute_all_applicable_attributes { - @{ (shift)->{'___compute_all_applicable_attributes'} } +sub _generate_slot_initializer { + my ($class, $meta_instance, $attrs, $index) = @_; + my $attr = $attrs->[$index]; + my $default; + if ($attr->has_default) { + if ($attr->is_default_a_coderef) { + $default = '$attrs->[' . $index . ']->default($instance)'; + } + else { + $default = $attrs->[$index]->default; + unless (looks_like_number($default)) { + $default = "'$default'"; + } + # TODO: + # we should use Data::Dumper to + # output any ref's here, obviously + # we cannot handle Scalar refs, but + # it should work for Array and Hash + # refs pretty well. + } + } + $meta_instance->inline_set_slot_value( + '$instance', + $attr->name, + ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : '')) + ) } +# cached methods + +sub get_meta_instance { (shift)->{'___get_meta_instance'} } +sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} } +sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} } + 1; __END__ @@ -77,6 +147,22 @@ Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class =head1 DESCRIPTION +Class::MOP offers many benefits to object oriented development but it +comes at a cost. Pure Class::MOP classes can be quite a bit slower than +the typical hand coded Perl classes. This is because just about +I is recalculated on the fly, and nothing is cached. The +reason this is so, is because Perl itself allows you to modify virtually +everything at runtime. Class::MOP::Class::Immutable offers an alternative +to this. + +By making your class immutable, you are promising that you will not +modify your inheritence tree or the attributes of any classes in +that tree. Since runtime modifications like this are fairly atypical +(and usually recomended against), this is not usally a very hard promise +to make. For making this promise you are given a wide range of +optimization options which bring speed close to (and sometimes above) +those of typical hand coded Perl. + =head1 METHODS =over 4 diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm index 2ab4ec4..23be56a 100644 --- a/lib/Class/MOP/Instance.pm +++ b/lib/Class/MOP/Instance.pm @@ -100,6 +100,13 @@ sub strengthen_slot_value { # inlinable operation snippets +sub is_inlinable { 1 } + +sub inline_create_instance { + my ($self, $class_variable) = @_; + 'bless {} => ' . $class_variable; +} + sub inline_slot_access { my ($self, $instance, $slot_name) = @_; sprintf "%s->{%s}", $instance, $slot_name; @@ -256,6 +263,14 @@ ignore this for now. =over 4 +=item B + +Each meta-instance should override this method to tell Class::MOP if it's +possible to inline the slot access. + +This is currently only used by Class::MOP::Class::Immutable when performing +optimizations. + =item B =item B diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 61ce12d..d59cf63 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -33,98 +33,101 @@ sub name { $_[0]->{'$:package'} } # Class attributes -my %SIGIL_MAP = ( - '$' => 'SCALAR', - '@' => 'ARRAY', - '%' => 'HASH', - '&' => 'CODE', -); +{ + my %SIGIL_MAP = ( + '$' => 'SCALAR', + '@' => 'ARRAY', + '%' => 'HASH', + '&' => 'CODE', + ); -sub add_package_symbol { - my ($self, $variable, $initial_value) = @_; + sub add_package_symbol { + my ($self, $variable, $initial_value) = @_; - (defined $variable) - || confess "You must pass a variable name"; + (defined $variable) + || confess "You must pass a variable name"; - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - (defined $sigil) - || confess "The variable name must include a sigil"; + (defined $sigil) + || confess "The variable name must include a sigil"; - (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; + (exists $SIGIL_MAP{$sigil}) + || confess "I do not recognize that sigil '$sigil'"; - no strict 'refs'; - no warnings 'misc'; - *{$self->name . '::' . $name} = $initial_value; -} + no strict 'refs'; + no warnings 'misc'; + *{$self->name . '::' . $name} = $initial_value; + } -sub has_package_symbol { - my ($self, $variable) = @_; - (defined $variable) - || confess "You must pass a variable name"; + sub has_package_symbol { + my ($self, $variable) = @_; + (defined $variable) + || confess "You must pass a variable name"; - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - (defined $sigil) - || confess "The variable name must include a sigil"; + (defined $sigil) + || confess "The variable name must include a sigil"; - (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; + (exists $SIGIL_MAP{$sigil}) + || confess "I do not recognize that sigil '$sigil'"; - no strict 'refs'; - defined *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}} ? 1 : 0; + no strict 'refs'; + defined *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}} ? 1 : 0; -} + } -sub get_package_symbol { - my ($self, $variable) = @_; - (defined $variable) - || confess "You must pass a variable name"; + sub get_package_symbol { + my ($self, $variable) = @_; + (defined $variable) + || confess "You must pass a variable name"; - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - (defined $sigil) - || confess "The variable name must include a sigil"; + (defined $sigil) + || confess "The variable name must include a sigil"; - (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; + (exists $SIGIL_MAP{$sigil}) + || confess "I do not recognize that sigil '$sigil'"; - no strict 'refs'; - return *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}}; + no strict 'refs'; + return *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}}; -} + } -sub remove_package_symbol { - my ($self, $variable) = @_; + sub remove_package_symbol { + my ($self, $variable) = @_; - (defined $variable) - || confess "You must pass a variable name"; + (defined $variable) + || confess "You must pass a variable name"; - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - - (defined $sigil) - || confess "The variable name must include a sigil"; - - (exists $SIGIL_MAP{$sigil}) - || confess "I do not recognize that sigil '$sigil'"; - - no strict 'refs'; - if ($SIGIL_MAP{$sigil} eq 'SCALAR') { - undef ${$self->name . '::' . $name}; - } - elsif ($SIGIL_MAP{$sigil} eq 'ARRAY') { - undef @{$self->name . '::' . $name}; - } - elsif ($SIGIL_MAP{$sigil} eq 'HASH') { - undef %{$self->name . '::' . $name}; - } - elsif ($SIGIL_MAP{$sigil} eq 'CODE') { - undef &{$self->name . '::' . $name}; - } - else { - confess "This should never ever ever happen"; + my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); + + (defined $sigil) + || confess "The variable name must include a sigil"; + + (exists $SIGIL_MAP{$sigil}) + || confess "I do not recognize that sigil '$sigil'"; + + no strict 'refs'; + if ($SIGIL_MAP{$sigil} eq 'SCALAR') { + undef ${$self->name . '::' . $name}; + } + elsif ($SIGIL_MAP{$sigil} eq 'ARRAY') { + undef @{$self->name . '::' . $name}; + } + elsif ($SIGIL_MAP{$sigil} eq 'HASH') { + undef %{$self->name . '::' . $name}; + } + elsif ($SIGIL_MAP{$sigil} eq 'CODE') { + undef &{$self->name . '::' . $name}; + } + else { + confess "This should never ever ever happen"; + } } + } 1;