B::XSUB::Dumber - L<B::OPCheck> demo for microoptimizing XSUB invocation.

B-XSUB-Dumber documentation Contained in the B-XSUB-Dumber distribution.

Index

Code Index:

NAME

Top

B::XSUB::Dumber - B::OPCheck demo for microoptimizing XSUB invocation.

SYNOPSIS

Top

	use Scalar::Util qw(blessed reftype);

	{
		use B::XSUB::Dumber qw(blessed reftype);
		reftype($thingy);
	}

DESCRIPTION

Top

Certain XSUBs don't need lots of fluff from pp_entersub to be invoked since they don't do anything fancy. For XSUBs fitting this description this module lexically replaces the implementation of the entersub ops calling them with a much simpler version that doesn't do anything except invoke the XSUB function pointer from the CV.

This is meant mostly as a demo of the sort of thing B::OPCheck lets you do, so please don't take it too seriously or rely on it in any way.

VERSION CONTROL

Top

This module is maintained using Darcs. You can get the latest version from http://nothingmuch.woobling.org/code, and use darcs send to commit changes.

AUTHOR

Top

Yuval Kogman <nothingmuch@woobling.org>

COPYRIGHT

Top

	Copyright (c) 2008 Yuval Kogman. All rights reserved
	This program is free software; you can redistribute
	it and/or modify it under the same terms as Perl itself.
B-XSUB-Dumber documentation Contained in the B-XSUB-Dumber distribution. 
#!/usr/bin/perl

package B::XSUB::Dumber;

use strict;
use warnings;

use Carp qw(croak);
use B qw(svref_2object class);
use B::Generate;
use Scalar::Util qw(reftype);
use XSLoader;

our $VERSION = '0.01';

XSLoader::load __PACKAGE__, $VERSION;

use base qw(B::OPCheck);

sub null {
    my $op = shift;
    return class($op) eq "NULL";
}

sub import {
	my ( $class, @subs ) = @_;

	my $xsubs = $^H{$class} || do {
		my %xsubs;
		use B::Utils;
		$class->SUPER::import(entersub => check => sub {
			my $op = shift;

			# FIXME only if !hasargs

			return unless null $op->first->sibling; # method

			my $kid = $op->first;
			$kid = $kid->first->sibling; # skip ex-list, pushmark
			while ( not null $kid->sibling ) {
				$kid = $kid->sibling;
			}

			my $cvop = $kid->first;

			if ($cvop->name eq "gv") {
				my $gv = $cvop->gv;
				my $cv = $gv->CV;
				if ( my $xsub = $cv->XSUB ) {
					if ( $xsubs{$xsub} ) {
						$op->ppaddr(simple_xsub_ppaddr());
						#$op->ppaddr($xsub); # not possible, it's not a PP (returns an OP*)
					}
				}
			}
		});

		\%xsubs;
	};

	foreach my $sub ( @subs ) {
		my $ref;

		unless ( ref($sub) ) {
			$ref = eval 'package ' . caller(). '; no strict "refs"; \&{$sub}';
			warn $@ if $@;
		} elsif ( reftype($sub) eq 'CODE' ) {
			$ref = $sub;
		}

		unless ( ref($ref) && reftype($ref) eq 'CODE' ) {
			croak "Must supply a sub name or a code reference to an XSUB";
		}

		my $xsub = svref_2object($ref)->XSUB;

		unless ( $xsub ) {
			croak "$sub is not an XSUB";
		}

		$xsubs->{$xsub}++;
	}
}

sub unimport {
	my $class = shift;
	$class->SUPER::unimport(); # FIXME only call if really everything is removed, and with the right opname and callback sub
}

__PACKAGE__

__END__