Index: perloptree.pod =================================================================== --- perloptree.pod (revision 443) +++ perloptree.pod (working copy) @@ -189,7 +189,7 @@ children. But the number and type of arguments is not so easy to declare as in C. F tries to declare some XS-prototype like arguments, but in lisp we would say most ops are "special" -functions, context-dependent, hard to parse. +functions, context-dependent, with special parsing and precedence rules. F L contains these classes and inheritance: @@ -210,8 +210,8 @@ I -F L -contains all the gory details. Let's check it out. +F L +contains all the gory details. Let's check it out: =head2 OP Class Declarations in opcode.pl @@ -425,6 +425,10 @@ getlogin getlogin ck_null st0 custom unknown custom operator ck_null 0 +=head3 null + +null ops are skipped during the runloop, and are created by the peephole optimizer. + =head2 UNOP The unary op class signifier is B<1>, for one child, pointed to Index: lib/B/C.pm =================================================================== --- lib/B/C.pm (revision 443) +++ lib/B/C.pm (working copy) @@ -10,7 +10,7 @@ package B::C; -our $VERSION = '1.26'; +our $VERSION = '1.27'; package B::C::Section; @@ -40,14 +40,27 @@ $section->[-1]{comment}; } +# print debugging info (stringified flags) on -DF +sub debug { + my $section = shift; + my $dbg = join( "", @_ ); + $section->[-1]{dbg}->[ $section->index ] = $dbg if $dbg; + $section->[-1]{dbg}; +} + sub output { my ( $section, $fh, $format ) = @_; my $sym = $section->symtable || {}; my $default = $section->default; my $i = 0; + my $dodbg = 1 if $B::C::debug{flags} and $section->[-1]{dbg}; foreach ( @{ $section->[-1]{values} } ) { + my $dbg = ""; s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge; - printf $fh $format, $_, $i; + if ($dodbg and $section->[-1]{dbg}->[$i]) { + $dbg = " /* ".$section->[-1]{dbg}->[$i]." */"; + } + printf $fh $format, $_, $i, $dbg; ++$i; } } @@ -1095,6 +1108,7 @@ return savesym( $sv, "(void*)Nullsv /* XXX */" ); } $svsect->add( sprintf( "0, %lu, 0x%x".($PERL510?', {0}':''), $sv->REFCNT, $sv->FLAGS ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) ); } @@ -1115,6 +1129,7 @@ $xpvuvsect->index, $sv->REFCNT, $sv->FLAGS ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; warn sprintf( "Saving IV(UV) 0x%x to xpvuv_list[%d], sv_list[%d], called from %s:%s\n", $sv->UVX, $xpvuvsect->index, $svsect->index, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} ) if $debug{sv}; @@ -1145,6 +1160,7 @@ $xpvivsect->index, $sv->REFCNT, $sv->FLAGS ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; warn sprintf( "Saving IV 0x%x to xpviv_list[%d], sv_list[%d], called from %s:%s\n", $sv->IVX, $xpvivsect->index, $svsect->index, @{[(caller(1))[3]]}, @{[(caller(0))[2]]} ) if $debug{sv}; @@ -1177,6 +1193,7 @@ $xpvnvsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {0}' : '' ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; warn sprintf( "Saving NV %s to xpvnv_list[%d], sv_list[%d]\n", $nv, $xpvnvsect->index, $svsect->index ) if $debug{sv}; @@ -1244,6 +1261,7 @@ $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x", $xpvlvsect->index, $sv->REFCNT, $sv->FLAGS)); } + $svsect->debug($sv->flagspv) if $debug{flags}; if ( !$B::C::pv_copy_on_grow ) { if ($PERL510) { @@ -1280,6 +1298,7 @@ $svsect->add( sprintf("&xpviv_list[%d], %u, 0x%x %s", $xpvivsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {0}' : '' ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; if ( defined($pv) && !$B::C::pv_copy_on_grow ) { if ($PERL510) { $init->add( @@ -1345,6 +1364,7 @@ $svsect->add( sprintf("&xpvnv_list[%d], %lu, 0x%x %s", $xpvnvsect->index, $sv->REFCNT, $sv->FLAGS, $PERL510 ? ', {0}' : '' ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; if ( defined($pv) && !$B::C::pv_copy_on_grow ) { if ($PERL510) { $init->add( @@ -1368,7 +1388,8 @@ if ($PERL510) { warn "Saving FBM for GV $sym\n" if $debug{gv}; $init->add( sprintf( "$sym = (GV*)newSV_type(SVt_PVGV);" ), - sprintf( "SvFLAGS($sym) = 0x%x;", $sv->FLAGS ), + sprintf( "SvFLAGS($sym) = 0x%x;%s", $sv->FLAGS, + $debug{flags} ? " /* ".$sv->flagspv." */" : ""), sprintf( "SvREFCNT($sym) = %u;", $sv->REFCNT + 1 ), sprintf( "SvPVX($sym) = %s;", cstring($pv) ), sprintf( "SvLEN_set($sym, %d);", $len ), @@ -1386,6 +1407,7 @@ )); $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x", $xpvbmsect->index, $sv->REFCNT, $sv->FLAGS)); + $svsect->debug($sv->flagspv) if $debug{flags}; $init->add(savepvn( sprintf( "xpvbm_list[%d].xpv_pv", $xpvbmsect->index ), $pv ) ) unless $B::C::pv_copy_on_grow; } @@ -1437,6 +1459,7 @@ $init->add( savepvn( sprintf( "xpv_list[%d].xpv_pv", $xpvsect->index ), $pv ) ); } } + $svsect->debug($sv->flagspv) if $debug{flags}; return savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) ); } @@ -1490,6 +1513,7 @@ $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x", $xpvmgsect->index, $sv->REFCNT, $sv->FLAGS)); } + $svsect->debug($sv->flagspv) if $debug{flags}; if ( !$B::C::pv_copy_on_grow ) { # comppadnames need &PL_sv_undef instead of 0 if ($PERL510) { @@ -1654,6 +1678,7 @@ # 5.10 has no struct xrv anymore, just sv_u.svu_rv. static or dynamic? # initializer element is not computable at load time $svsect->add( sprintf( "0, %lu, 0x%x, {0}", $sv->REFCNT, $sv->FLAGS ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; $init->add( sprintf( "sv_list[%d].sv_u.svu_rv = (SV*)%s;\n", $svsect->index, $rv ) ); return savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) ); } @@ -1688,6 +1713,7 @@ $xrvsect->index, $sv->REFCNT, $sv->FLAGS ) ); + $svsect->debug($sv->flagspv) if $debug{flags}; return savesym( $sv, sprintf( "&sv_list[%d]", $svsect->index ) ); } } @@ -1831,6 +1857,7 @@ # Reserve a place in svsect and xpvcvsect and record indices my $sv_ix = $svsect->index + 1; $svsect->add("SVIX$sv_ix"); + $svsect->debug($cv->flagspv) if $debug{flags}; my $xpvcv_ix = $xpvcvsect->index + 1; $xpvcvsect->add("XPVCVIX$xpvcv_ix"); @@ -2104,8 +2131,9 @@ if ( $gp and !$is_empty ) { warn( sprintf( - "New GvGP for $name: 0x%x %s 0x%x 0x%x\n", - $svflags, $gv->FILE, ${ $gv->FILEGV }, $gp + "New GvGP for $name: 0x%x%s %s 0x%x 0x%x\n", + $svflags, $debug{flags} ? "(".$gv->flagspv.")" : "", + $gv->FILE, ${ $gv->FILEGV }, $gp ) ) if $debug{gv}; $init->add( sprintf("GvGP($sym) = Perl_newGP(aTHX_ $sym);") ); @@ -2116,7 +2144,8 @@ } } } - $init->add(sprintf( "SvFLAGS($sym) = 0x%x;", $svflags )); + $init->add(sprintf( "SvFLAGS($sym) = 0x%x;%s", $svflags, + $debug{flags}?" /* ".$gv->flagspv." */":"" )); my $gvflags = $gv->GvFLAGS; if ($gvflags > 256) { $gvflags = $gvflags && 256 }; # $gv->GvFLAGS as U8 $init->add(sprintf( "GvFLAGS($sym) = %d;", $gvflags )); @@ -2316,6 +2345,7 @@ $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x", $xpvavsect->index, $av->REFCNT, $av->FLAGS)); } + $svsect->debug($av->flagspv) if $debug{flags}; my $sv_list_index = $svsect->index; # protect against recursive self-references (Getopt::Long) $sym = savesym( $av, "(AV*)&sv_list[$sv_list_index]" ); @@ -2531,6 +2561,7 @@ $svsect->add(sprintf( "&xpvhv_list[%d], %lu, 0x%x", $xpvhvsect->index, $hv->REFCNT, $hv->FLAGS)); } + $svsect->debug($hv->flagspv) if $debug{flags}; warn sprintf( "saving HV 0x%x MAX=%d\n", $$hv, $hv->MAX ) if $debug{hv}; my $sv_list_index = $svsect->index; @@ -2679,6 +2710,7 @@ $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", $xpviosect->index, $io->REFCNT, $io->FLAGS)); } + $svsect->debug($io->flagspv) if $debug{flags}; $sym = savesym( $io, sprintf( "(IO*)&sv_list[%d]", $svsect->index ) ); if ($PERL510 and !$B::C::pv_copy_on_grow and $len) { @@ -2738,7 +2770,7 @@ $xpvuvsect, $xpvnvsect, $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect ); - printf "\t/* %s */\n", $symsect->comment if $symsect->comment and $verbose; + printf "\t/* %s */", $symsect->comment if $symsect->comment and $verbose; $symsect->output( \*STDOUT, "#define %s\n" ); print "\n"; output_declarations(); @@ -2772,7 +2804,7 @@ printf "static %s %s_list[%u] = {\n", $typename, $name, $lines; printf "\t/* %s */\n", $section->comment if $section->comment and $verbose; - $section->output( \*STDOUT, "\t{ %s }, /* %d */\n" ); + $section->output( \*STDOUT, "\t{ %s }, /* %d */%s\n" ); print "};\n\n"; } } @@ -3753,6 +3785,9 @@ elsif ( $arg eq "p" ) { $debug{pkg}++; } + elsif ( $arg eq "F" ) { + $debug{flags}++ if eval "require B::Flags;"; + } elsif ( $arg eq "W" ) { $debug{walk}++; } @@ -3947,6 +3982,10 @@ prints cached B information, if used or not. +=item B<-DF> + +Add Flags info to the code. + =item B<-DW> Together with B<-Dp> also prints every B package symbol. Index: Changes =================================================================== --- Changes (revision 443) +++ Changes (working copy) @@ -3,6 +3,9 @@ The Perl compiler was in CORE from alpha4 until Perl 5.9.4 and worked quite fine with Perl 5.6 and 5.8 +1.27 + * C.pm: add -DF print stringified sv and op flags + 1.26 2010-07-26 rurban Start of 5.14 support, CVs broken. Index: log.modules-5.010001 =================================================================== --- log.modules-5.010001 (revision 443) +++ log.modules-5.010001 (working copy) @@ -1,6 +1,6 @@ # B::C::VERSION = 1.26 # perlversion = 5.010001 -# path = /usr/bin/perl5.10.1 +# path = /usr/bin/perl # platform = cygwin # threaded perl pass Exporter