B/Debug.pm

   1 package B::Debug;
   2 use strict;
   3 use B qw(peekop class walkoptree walkoptree_exec
   4          main_start main_root cstring sv_undef);
   5 use B::Asmdata qw(@specialsv_name);
   6
   7 my %done_gv;
   8
   9 sub B::OP::debug {
  10     my ($op) = @_;
  11     printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;
  12 %s (0x%lx)
  13         op_next         0x%x
  14         op_sibling      0x%x
  15         op_ppaddr       %s
  16         op_targ         %d
  17         op_type         %d
  18         op_seq          %d
  19         op_flags        %d
  20         op_private      %d
  21 EOT
  22 }
  23
  24 sub B::UNOP::debug {
  25     my ($op) = @_;
  26     $op->B::OP::debug();
  27     printf "\top_first\t0x%x\n", ${$op->first};
  28 }
  29
  30 sub B::BINOP::debug {
  31     my ($op) = @_;
  32     $op->B::UNOP::debug();
  33     printf "\top_last\t\t0x%x\n", ${$op->last};
  34 }
  35
  36 sub B::LOGOP::debug {
  37     my ($op) = @_;
  38     $op->B::UNOP::debug();
  39     printf "\top_other\t0x%x\n", ${$op->other};
  40 }
  41
  42 sub B::CONDOP::debug {
  43     my ($op) = @_;
  44     $op->B::UNOP::debug();
  45     printf "\top_true\t0x%x\n", ${$op->true};
  46     printf "\top_false\t0x%x\n", ${$op->false};
  47 }
  48
  49 sub B::LISTOP::debug {
  50     my ($op) = @_;
  51     $op->B::BINOP::debug();
  52     printf "\top_children\t%d\n", $op->children;
  53 }
  54
  55 sub B::PMOP::debug {
  56     my ($op) = @_;
  57     $op->B::LISTOP::debug();
  58     printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
  59     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
  60     printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
  61     printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
  62     printf "\top_pmshort\t0x%x\n", ${$op->pmshort};
  63     printf "\top_pmflags\t0x%x\n", $op->pmflags;
  64     printf "\top_pmslen\t%d\n", $op->pmslen;
  65     $op->pmshort->debug;
  66     $op->pmreplroot->debug;
  67 }
  68
  69 sub B::COP::debug {
  70     my ($op) = @_;
  71     $op->B::OP::debug();
  72     my ($filegv) = $op->filegv;
  73     printf <<'EOT', $op->label, ${$op->stash}, $$filegv, $op->seq, $op->arybase, $op->line;
  74         cop_label       %s
  75         cop_stash       0x%x
  76         cop_filegv      0x%x
  77         cop_seq         %d
  78         cop_arybase     %d
  79         cop_line        %d
  80 EOT
  81     $filegv->debug;
  82 }
  83
  84 sub B::SVOP::debug {
  85     my ($op) = @_;
  86     $op->B::OP::debug();
  87     printf "\top_sv\t\t0x%x\n", ${$op->sv};
  88     $op->sv->debug;
  89 }
  90
  91 sub B::PVOP::debug {
  92     my ($op) = @_;
  93     $op->B::OP::debug();
  94     printf "\top_pv\t\t0x%x\n", $op->pv;
  95 }
  96
  97 sub B::GVOP::debug {
  98     my ($op) = @_;
  99     $op->B::OP::debug();
 100     printf "\top_gv\t\t0x%x\n", ${$op->gv};
 101     $op->gv->debug;
 102 }
 103
 104 sub B::CVOP::debug {
 105     my ($op) = @_;
 106     $op->B::OP::debug();
 107     printf "\top_cv\t\t0x%x\n", ${$op->cv};
 108 }
 109
 110 sub B::NULL::debug {
 111     my ($sv) = @_;
 112     if ($$sv == ${sv_undef()}) {
 113         print "&sv_undef\n";
 114     } else {
 115         printf "NULL (0x%x)\n", $$sv;
 116     }
 117 }
 118
 119 sub B::SV::debug {
 120     my ($sv) = @_;
 121     if (!$$sv) {
 122         print class($sv), " = NULL\n";
 123         return;
 124     }
 125     printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
 126 %s (0x%x)
 127         REFCNT          %d
 128         FLAGS           0x%x
 129 EOT
 130 }
 131
 132 sub B::PV::debug {
 133     my ($sv) = @_;
 134     $sv->B::SV::debug();
 135     my $pv = $sv->PV();
 136     printf <<'EOT', cstring($pv), length($pv);
 137         xpv_pv          %s
 138         xpv_cur         %d
 139 EOT
 140 }
 141
 142 sub B::IV::debug {
 143     my ($sv) = @_;
 144     $sv->B::SV::debug();
 145     printf "\txiv_iv\t\t%d\n", $sv->IV;
 146 }
 147
 148 sub B::NV::debug {
 149     my ($sv) = @_;
 150     $sv->B::IV::debug();
 151     printf "\txnv_nv\t\t%s\n", $sv->NV;
 152 }
 153
 154 sub B::PVIV::debug {
 155     my ($sv) = @_;
 156     $sv->B::PV::debug();
 157     printf "\txiv_iv\t\t%d\n", $sv->IV;
 158 }
 159
 160 sub B::PVNV::debug {
 161     my ($sv) = @_;
 162     $sv->B::PVIV::debug();
 163     printf "\txnv_nv\t\t%s\n", $sv->NV;
 164 }
 165
 166 sub B::PVLV::debug {
 167     my ($sv) = @_;
 168     $sv->B::PVNV::debug();
 169     printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
 170     printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
 171     printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
 172 }
 173
 174 sub B::BM::debug {
 175     my ($sv) = @_;
 176     $sv->B::PVNV::debug();
 177     printf "\txbm_useful\t%d\n", $sv->USEFUL;
 178     printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
 179     printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
 180 }
 181
 182 sub B::CV::debug {
 183     my ($sv) = @_;
 184     $sv->B::PVNV::debug();
 185     my ($stash) = $sv->STASH;
 186     my ($start) = $sv->START;
 187     my ($root) = $sv->ROOT;
 188     my ($padlist) = $sv->PADLIST;
 189     my ($gv) = $sv->GV;
 190     my ($filegv) = $sv->FILEGV;
 191     printf <<'EOT', $$stash, $$start, $$root, $$gv, $$filegv, $sv->DEPTH, $padlist, ${$sv->OUTSIDE};
 192         STASH           0x%x
 193         START           0x%x
 194         ROOT            0x%x
 195         GV              0x%x
 196         FILEGV          0x%x
 197         DEPTH           %d
 198         PADLIST         0x%x
 199         OUTSIDE         0x%x
 200 EOT
 201     $start->debug if $start;
 202     $root->debug if $root;
 203     $gv->debug if $gv;
 204     $filegv->debug if $filegv;
 205     $padlist->debug if $padlist;
 206 }
 207
 208 sub B::AV::debug {
 209     my ($av) = @_;
 210     $av->B::SV::debug;
 211     my(@array) = $av->ARRAY;
 212     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
 213     printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;
 214         FILL            %d
 215         MAX             %d
 216         OFF             %d
 217         AvFLAGS         %d
 218 EOT
 219 }
 220
 221 sub B::GV::debug {
 222     my ($gv) = @_;
 223     if ($done_gv{$$gv}++) {
 224         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->NAME;
 225         return;
 226     }
 227     my ($sv) = $gv->SV;
 228     my ($av) = $gv->AV;
 229     my ($cv) = $gv->CV;
 230     $gv->B::SV::debug;
 231     printf <<'EOT', $gv->NAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILEGV, $gv->GvFLAGS;
 232         NAME            %s
 233         STASH           %s (0x%x)
 234         SV              0x%x
 235         GvREFCNT        %d
 236         FORM            0x%x
 237         AV              0x%x
 238         HV              0x%x
 239         EGV             0x%x
 240         CV              0x%x
 241         CVGEN           %d
 242         LINE            %d
 243         FILEGV          0x%x
 244         GvFLAGS         0x%x
 245 EOT
 246     $sv->debug if $sv;
 247     $av->debug if $av;
 248     $cv->debug if $cv;
 249 }
 250
 251 sub B::SPECIAL::debug {
 252     my $sv = shift;
 253     print $specialsv_name[$$sv], "\n";
 254 }
 255
 256 sub compile {
 257     my $order = shift;
 258     if ($order eq "exec") {
 259         return sub { walkoptree_exec(main_start, "debug") }
 260     } else {
 261         return sub { walkoptree(main_root, "debug") }
 262     }
 263 }
 264
 265 1;