File Coverage

blib/lib/Opcodes.pm

Criterion	Covered	Total	%
statement	69	72	95.8
branch	15	26	57.6
condition	4	6	66.6
subroutine	20	20	100.0
pod	7	7	100.0
total	115	131	87.7

package Opcodes;

use 5.006_001;
use strict;

our($VERSION, @ISA, @EXPORT, @EXPORT_OK);

$VERSION = "0.14";

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 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__