From 47e6c6d93f57c4fc8d67fee6635d33d3bf768674 Mon Sep 17 00:00:00 2001 From: Nicolas R Date: Tue, 3 Nov 2020 15:28:04 -0700 Subject: [PATCH] Add a few helpers to B for INVLIST This commit provide some basic method to access to internal fields from one INVLIST: SVt_INVLIST - prev_index - is_offset - array_len - get_invlist_array This allows B::C to be walk and save invlists. --- MANIFEST | 1 + ext/B/B.pm | 34 ++++++++++++++++++++++---- ext/B/B.xs | 71 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- ext/B/t/invlist.t | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++ ext/B/typemap | 1 + perl.h | 1 + sv.h | 5 ++++ 7 files changed, 173 insertions(+), 5 deletions(-) create mode 100644 ext/B/t/invlist.t diff --git a/MANIFEST b/MANIFEST index 6a81fb5..003b220 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4117,6 +4117,7 @@ ext/B/t/f_map code from perldoc -f map ext/B/t/f_map.t converted to optreeCheck()s ext/B/t/f_sort optree test raw material ext/B/t/f_sort.t optree test raw material +ext/B/t/invlist.t test B::INVLIST ext/B/t/o.t See if O works ext/B/t/optree_check.t test OptreeCheck apparatus ext/B/t/optree_concise.t more B::Concise tests diff --git a/ext/B/B.pm b/ext/B/B.pm index 551f230..ef23af6 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -20,7 +20,7 @@ sub import { # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.81'; + $B::VERSION = '1.82'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -559,9 +559,9 @@ The inheritance hierarchy mimics the underlying C "inheritance": +------------+------------+ | | | B::PV B::IV B::NV - \ / / - \ / / - B::PVIV / + / \ / / + / \ / / + B::INVLIST B::PVIV / \ / \ / \ / @@ -735,6 +735,32 @@ in the MAGIC. =back +=head2 B::INVLIST Methods + +=over 4 + +=item prev_index + +Returns the cache result of previous invlist_search() (internal usage) + +=item is_offset + +Returns a boolean value (0 or 1) to know if the invlist is using an offset. +When false the list begins with the code point U+0000. +When true the list begins with the following elements. + +=item array_len + +Returns an integer with the size of the array used to define the invlist. + +=item get_invlist_array + +This method returns a list of integers representing the array used by the +invlist. +Note: this cannot be used while in middle of iterating on an invlist and croaks. + +=back + =head2 B::PVLV Methods =over 4 diff --git a/ext/B/B.xs b/ext/B/B.xs index ae2393e..e6e3fb8 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -13,6 +13,9 @@ #include "perl.h" #include "XSUB.h" +/* #include "invlist_inline.h" */ +#define FROM_INTERNAL_SIZE(x) ((x)/ sizeof(UV)) + #ifdef PerlIO typedef PerlIO * InputStream; #else @@ -472,6 +475,7 @@ typedef PADLIST *B__PADLIST; typedef PADNAMELIST *B__PADNAMELIST; typedef PADNAME *B__PADNAME; +typedef INVLIST *B__INVLIST; #ifdef MULTIPLICITY # define ASSIGN_COMMON_ALIAS(prefix, var) \ @@ -1631,6 +1635,71 @@ REGEX(sv) PUSHi(PTR2IV(sv)); } +MODULE = B PACKAGE = B::INVLIST PREFIX = Invlist + +int +prev_index(invlist) + B::INVLIST invlist + CODE: + RETVAL = ((XINVLIST*) SvANY(invlist))->prev_index; + OUTPUT: + RETVAL + +int +is_offset(invlist) + B::INVLIST invlist + CODE: + RETVAL = ((XINVLIST*) SvANY(invlist))->is_offset == TRUE ? 1 : 0; + OUTPUT: + RETVAL + +unsigned int +array_len(invlist) + B::INVLIST invlist + CODE: + { + if (SvCUR(invlist) > 0) + RETVAL = FROM_INTERNAL_SIZE(SvCUR(invlist)); /* - ((XINVLIST*) SvANY(invlist))->is_offset; */ /* <- for iteration */ + else + RETVAL = 0; + } + OUTPUT: + RETVAL + +void +get_invlist_array(invlist) + B::INVLIST invlist +PPCODE: + { + /* should use invlist_is_iterating but not public for now */ + bool is_iterating = ( (XINVLIST*) SvANY(invlist) )->iterator < (STRLEN) UV_MAX; + + if (is_iterating) { + croak( "Can't access inversion list: in middle of iterating" ); + } + + { + UV pos; + UV len; + + len = 0; + /* should use _invlist_len (or not) */ + if (SvCUR(invlist) > 0) + len = FROM_INTERNAL_SIZE(SvCUR(invlist)); /* - ((XINVLIST*) SvANY(invlist))->is_offset; */ /* <- for iteration */ + + if ( len > 0 ) { + UV *array = (UV*) SvPVX( invlist ); /* invlist_array */ + + EXTEND(SP, (int) len); + + for ( pos = 0; pos < len; ++pos ) { + PUSHs( sv_2mortal( newSVuv(array[pos]) ) ); + } + } + } + + } + MODULE = B PACKAGE = B::PV void @@ -2206,7 +2275,7 @@ PadnameTYPE(pn) B::PADLIST::outid = PL_outid_ix PREINIT: char *ptr; - SV *ret; + SV *ret = NULL; PPCODE: ptr = (ix & 0xFFFF) + (char *)pn; switch ((U8)(ix >> 16)) { diff --git a/ext/B/t/invlist.t b/ext/B/t/invlist.t new file mode 100644 index 0000000..a719d04 --- /dev/null +++ b/ext/B/t/invlist.t @@ -0,0 +1,65 @@ +#!./perl + +BEGIN { + unshift @INC, 't'; + require Config; + if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) { + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } +} + +use strict; +use warnings; +use Test::More; + +if ( $Config::Config{useithreads} ) { + plan( skip_all => "Perl compiled with ithreads... no invlist in the example"); +} + +use_ok('B'); + +# Somewhat minimal tests. + +my $found_invlist; + +# we are going to walk this sub +sub check { + "ABCD" !~ tr/\0-\377//c; # this is using the Latin1_invlist +} + +sub B::OP::visit { + my $op = shift; + + note ref($op) . " ; NAME: ", $op->name, " ; TYPE: ", $op->type; + + return unless ref $op eq 'B::SVOP' && $op->name eq 'trans'; + + my $sv = $op->sv; + + note "SV: ", ref $sv, " = " . $sv->LEN . " " . $sv->CUR; + foreach my $elt ( $sv->ARRAY ) { + next unless ref $elt eq 'B::INVLIST'; + $found_invlist = 1; + my $invlist = $elt; + + is $invlist->prev_index, 0, "prev_index=0"; + is $invlist->is_offset, 0, "is_offset = 0 (false)"; + + my @array = $invlist->get_invlist_array; + is scalar @array, 2, "invlist array size is 2" or diag explain \@array; + is $array[0], 0, "PL_Latin1 first value in the invlist array is 0" or diag explain \@array; + is $array[1], 256, "PL_Latin1 second value in the invlist array is 0" or diag explain \@array; + + is $invlist->array_len(), 2, "PL_Latin1 array length is 2"; + } + + return; +} + +my $op = B::svref_2object( \*main::check ); +B::walkoptree( $op->CV->ROOT, 'visit' ); + +ok $found_invlist, "visited one INVLIST"; + +done_testing(); diff --git a/ext/B/typemap b/ext/B/typemap index 045d6a0..d891f9d 100644 --- a/ext/B/typemap +++ b/ext/B/typemap @@ -27,6 +27,7 @@ B::HV T_SV_OBJ B::AV T_SV_OBJ B::IO T_SV_OBJ B::FM T_SV_OBJ +B::INVLIST T_SV_OBJ B::MAGIC T_MG_OBJ SSize_t T_IV diff --git a/perl.h b/perl.h index d0066f5..da05d96 100644 --- a/perl.h +++ b/perl.h @@ -2800,6 +2800,7 @@ typedef struct gv GV; typedef struct io IO; typedef struct context PERL_CONTEXT; typedef struct block BLOCK; +typedef struct invlist INVLIST; typedef struct magic MAGIC; typedef struct xpv XPV; diff --git a/sv.h b/sv.h index 3d906aa..2ad0a5c 100644 --- a/sv.h +++ b/sv.h @@ -265,6 +265,11 @@ struct p5rx { _SV_HEAD_UNION; }; +struct invlist { + _SV_HEAD(XINVLIST*); /* pointer to xpvinvlist body */ + _SV_HEAD_UNION; +}; + #undef _SV_HEAD #undef _SV_HEAD_UNION /* ensure no pollution */ -- 1.8.3.1