package Opcodes;
use 5.006_001;
use strict;
our($VERSION, @ISA, @EXPORT, @EXPORT_OK);
$VERSION = "0.12";
use Exporter ();
use XSLoader ();
BEGIN {
@ISA = qw(Exporter);
@EXPORT =
qw(opcodes opname opname2code opflags opaliases
opargs opclass opdesc opname
OA_CLASS_MASK
OA_MARK
OA_FOLDCONST
OA_RETSCALAR
OA_TARGET
OA_RETINTEGER
OA_OTHERINT
OA_DANGEROUS
OA_DEFGV
OA_TARGLEX
OA_BASEOP
OA_UNOP
OA_BINOP
OA_LOGOP
OA_LISTOP
OA_PMOP
OA_SVOP
OA_PADOP
OA_PVOP_OR_SVOP
OA_LOOP
OA_COP
OA_BASEOP_OR_UNOP
OA_FILESTATOP
OA_LOOPEXOP
OA_SCALAR
OA_LIST
OA_AVREF
OA_HVREF
OA_CVREF
OA_FILEREF
OA_SCALARREF
OA_OPTIONAL
OA_NOSTACK
OA_MAYSCALAR
OA_MAYARRAY
OA_MAYVOID
OA_RETFIXED
OA_MAYBRANCH
);
@EXPORT_OK = qw(ppaddr check argnum maybranch);
}
use subs @EXPORT_OK;
sub AUTOLOAD {
# 'autoload' constants from the constant() XS function.
my $constname;
our $AUTOLOAD;
($constname = $AUTOLOAD) =~ s/.*:://;
die "&Opcodes::constant not defined" if $constname eq 'constant';
my ($error, $val) = constant($constname);
if ($error) { die $error; }
{
no strict 'refs';
*$AUTOLOAD = sub { $val };
}
goto &$AUTOLOAD;
}
XSLoader::load 'Opcodes', $VERSION;
our @opcodes = opcodes();
sub opname ($) {
$opcodes[ $_[0] ]->[1];
}
sub ppaddr ($) {
$opcodes[ $_[0] ]->[2];
}
sub check ($) {
$opcodes[ $_[0] ]->[3];
}
sub opdesc ($) {
Opcode::opdesc( opname( $_[0] ));
}
sub opargs ($) {
$opcodes[ $_[0] ]->[4];
}
# n no_stack - A handcoded list of ops without any SP handling (Note: stack_base is allowed),
# i.e. no args + no return values.
# 'n' 512 is not encoded in opcode.pl. We could add it but then we would have to
# maintain it in CORE as well as here. Here its is needed for older perls. So
# keep it this way. Note that enter,entertry,leave indirectly use the stack.
our %no_stack = map{$_=>1}qw[null unstack scope lineseq
next redo goto break continue nextstate dbstate pushmark
regcmaybe regcreset];
# S retval may be scalar. s and i are automatically included
our %retval_scalar = map{$_=>1}qw[];
# A retval may be array
our %retval_array = map{$_=>1}qw[];
# V retval may be void
our %retval_void = map{$_=>1}qw[];
# F fixed retval type (S, A or V)
our %retval_fixed = map{$_=>1}qw[];
# N pp_* may return other than op_next
our %maybranch = map{$_=>1}
# LOGOP's which return op_other
qw[once cond_expr and or orassign andassign dor dorassign grepwhile mapwhile substcont
enterwhen entergiven range
],
# other OPs
qw[formline grepstart flip dbstate goto leaveeval
break
subst entersub
return last next redo require entereval entertry continue dump
];
sub opflags ($) {
# 0x1ff = 9 bits OCSHIFT
my $OCSHIFT = constant('OCSHIFT'); # 9
my $mask = (2 ** $OCSHIFT) - 1;
my $flags = opargs($_[0]) & $mask; # & 0x1ff
# now the extras
my $opname = opname($_[0]);
#$flags += 16 if $retint{$opname};
$flags += 512 if $no_stack{$opname};
$flags += 1024 if $retval_scalar{$opname} or $flags & 20; # 4|16
$flags += 2048 if $retval_array{$opname};
$flags += 4096 if $retval_void{$opname};
$flags += 8192 if $retval_fixed{$opname};
$flags += 16384 if maybranch($_[0]);
return $flags;
}
# See F<opcode.pl> for $OASHIFT and $OCSHIFT. For flags n 512 we
# would have to change that.
sub opclass ($) {
my $OCSHIFT = constant('OCSHIFT'); # 9
my $OASHIFT = constant('OASHIFT'); # 13
my $mask = (2 ** ($OASHIFT-$OCSHIFT)) - 1; # 0b1111 4bit 13-9=4 bits
$mask = $mask << $OCSHIFT; # 1e00: 4bit left-shifted by 9
(opargs($_[0]) & $mask) >> $OCSHIFT;
}
sub argnum ($) {
#my $ARGSHIFT = 4;
#my $ARGBITS = 32;
my $OASHIFT = constant('OASHIFT'); # 13
# ffffe000 = 32-13 bits left-shifted by 13
my $mask = ((2 ** (32-$OASHIFT)) - 1) << $OASHIFT;
(opargs($_[0]) & $mask) >> $OASHIFT;
}
sub opaliases ($) {
my $op = shift;
my @aliases = ();
my $ppaddr = ppaddr($op);
for (@opcodes) {
push @aliases, ($_->[0])
if $_->[2] == $ppaddr and $_->[0] != $op;
}
@aliases;
}
sub opname2code ($) {
my $name = shift;
for (0..$#opcodes) { return $_ if opname($_) eq $name; }
return undef;
}
# All LOGOPs: perl -Mblib -MOpcodes -e'$,=q( );print map {opname $_} grep {opclass($_) == 3} 1..opcodes' =>
# regcomp substcont grepwhile mapwhile range and or dor cond_expr andassign orassign dorassign entergiven
# enterwhen entertry once
# All pp which can return other then op_next (inspected pp*.c):
# once and cond_expr or defined grepwhile
# substcont formline grepstart mapwhile range flip dbstate goto leaveeval enterwhen break subst entersub
# return last next redo require entereval entertry continue
# + aliases: maybranch perl -MOpcodes -e'$,=q( );print map {opname $_} grep {opflags($_) & 16384} 1..opcodes'
# => subst substcont defined formline grepstart grepwhile mapwhile range and or dor cond_expr andassign
# orassign dorassign dbstate return last next redo dump goto entergiven enterwhen require entereval
# entertry once
sub maybranch ($) {
return undef if opclass($_[0]) <= 2; # NOT if lower than LOGOP
my $opname = opname($_[0]);
return 1 if $maybranch{$opname};
for (opaliases($_[0])) {
return 1 if $maybranch{opname($_)};
}
return undef;
}
1;
__END__
=head1 NAME
Opcodes - More Opcodes information from opnames.h and opcode.h
=head1 SYNOPSIS
use Opcodes;
print "Empty opcodes are null and ",
join ",", map {opname $_}, opaliases(opname2code('null'));
# All LOGOPs
perl -MOpcodes -e'$,=q( );print map {opname $_} grep {opclass($_) == 2} 1..opcodes'
# Ops which can return other than op->next
perl -MOpcodes -e'$,=q( );print map {opname $_} grep {Opcodes::maybranch $_} 1..opcodes'
=head1 DESCRIPTION
=head1 Operator Names and Operator Lists
The canonical list of operator names is the contents of the array
PL_op_name, defined and initialised in file F<opcode.h> of the Perl
source distribution (and installed into the perl library).
Each operator has both a terse name (its opname) and a more verbose or
recognisable descriptive name. The opdesc function can be used to
return a the description for an OP.
=over 8
=item an operator name (opname)
Operator names are typically small lowercase words like enterloop,
leaveloop, last, next, redo etc. Sometimes they are rather cryptic
like gv2cv, i_ncmp and ftsvtx.
=item an OP opcode
The opcode information functions all take the integer code, 0..MAX0,
MAXO being accessed by scalar @opcodes, the length of
the opcodes array.
=back
=head1 Opcode Information
Retrieve information of the Opcodes. All are available for export by the package.
Functions names starting with "op" are automatically exported.
=over 8
=item opcodes
In a scalar context opcodes returns the number of opcodes in this
version of perl (361 with perl-5.10).
In a list context it returns a list of all the operators with
its properties, a list of [ opcode opname ppaddr check opargs ].
=item opname (OP)
Returns the lowercase name without pp_ for the OP,
an integer between 0 and MAXO.
=item ppaddr (OP)
Returns the address of the ppaddr, which can be used to
get the aliases for each opcode.
=item check (OP)
Returns the address of the check function.
=item opdesc (OP)
Returns the string description of the OP.
=item opargs (OP)
Returns the opcode args encoded as integer of the opcode.
See below or F<opcode.pl> for the encoding details.
opflags 1-128 + opclass 1-13 << 9 + argnum 1-15.. << 13
=item argnum (OP)
Returns the arguments and types encoded as number acccording
to the following table, 4 bit for each argument.
'S', 1, # scalar
'L', 2, # list
'A', 3, # array value
'H', 4, # hash value
'C', 5, # code value
'F', 6, # file value
'R', 7, # scalar reference
+ '?', 8, # optional
Example:
argnum(opname2code('bless')) => 145
145 = 0b10010001 => S S?
first 4 bits 0001 => 1st arg is a Scalar,
next 4 bits 1001 => (bit 8+1) 2nd arg is an optional Scalar
=item opclass (OP)
Returns the op class as number according to the following table
from F<opcode.pl>:
'0', 0, # baseop
'1', 1, # unop
'2', 2, # binop
'|', 3, # logop
'@', 4, # listop
'/', 5, # pmop
'$', 6, # svop_or_padop
'#', 7, # padop
'"', 8, # pvop_or_svop
'{', 9, # loop
';', 10, # cop
'%', 11, # baseop_or_unop
'-', 12, # filestatop
'}', 13, # loopexop
=item opflags (OP)
Returns op flags as number according to the following table
from F<opcode.pl>. In doubt see your perl source.
I<Warning: There is currently an attempt to change that, but I posted a fix>
'm' => OA_MARK, # needs stack mark
'f' => OA_FOLDCONST, # fold constants
's' => OA_RETSCALAR, # always produces scalar
't' => OA_TARGET, # needs target scalar
'T' => OA_TARGET | OA_TARGLEX, # ... which may be lexical
'i' => OA_RETINTEGER, # always produces integer (this bit is in question)
'I' => OA_OTHERINT, # has corresponding int op
'd' => OA_DANGEROUS, # danger, unknown side effects
'u' => OA_DEFGV, # defaults to $_
plus not from F<opcode.pl>:
'n' => OA_NOSTACK, # nothing on the stack, no args and return
'N' => OA_MAYBRANCH # No next. may return other than PL_op->op_next, maybranch
These not yet:
'S' => OA_MAYSCALAR # retval may be scalar
'A' => OA_MAYARRAY # retval may be array
'V' => OA_MAYVOID # retval may be void
'F' => OA_RETFIXED # fixed retval type, either S or A or V
=item OA_* constants
All OA_ flag, class and argnum constants from F<op.h> are exported.
Addionally new OA_ flags have been created which are needed for L<B::CC>.
=item opaliases (OP)
Returns the opcodes for the aliased opcode functions for the given OP, the ops
with the same ppaddr.
=item opname2code (OPNAME)
Does a reverse lookup in the opcodes list to get the opcode for the given
name.
=item maybranch (OP)
Returns if the OP function may return not op->op_next.
Note that not all OP classes which have op->op_other, op->op_first or op->op_last
(higher then UNOP) are actually returning an other next op than op->op_next.
opflags(OP) & 16384
=back
=head1 SEE ALSO
L<Opcode> -- The Perl CORE Opcode module for handling sets of Opcodes used by L<Safe>.
L<Safe> -- Opcode and namespace limited execution compartments
L<B::CC> -- The optimizing perl compiler uses this module. L<Jit> also,
but only the static information
=head1 AUTHOR
Reini Urban C<rurban@cpan.org> 2010
=cut
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 78
# End:
# vim: expandtab shiftwidth=4: