ext/B/B/C.pm

   1 #      C.pm
   2 #
   3 #      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
   4 #
   5 #      You may distribute under the terms of either the GNU General Public
   6 #      License or the Artistic License, as specified in the README file.
   7 #
   8 package B::C;
   9 use Exporter ();
  10 @ISA = qw(Exporter);
  11 @EXPORT_OK = qw(output_all output_boilerplate output_main
  12                 init_sections set_callback save_unused_subs objsym);
  13
  14 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
  15          class cstring cchar svref_2object compile_stats comppadlist hash
  16          threadsv_names main_cv );
  17 use B::Asmdata qw(@specialsv_name);
  18
  19 use FileHandle;
  20 use Carp;
  21 use strict;
  22
  23 my $hv_index = 0;
  24 my $gv_index = 0;
  25 my $re_index = 0;
  26 my $pv_index = 0;
  27 my $anonsub_index = 0;
  28
  29 my %symtable;
  30 my $warn_undefined_syms;
  31 my $verbose;
  32 my @unused_sub_packages;
  33 my $nullop_count;
  34 my $pv_copy_on_grow;
  35 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
  36
  37 my @threadsv_names;
  38 BEGIN {
  39     @threadsv_names = threadsv_names();
  40 }
  41
  42 # Code sections
  43 my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect, $cvopsect,
  44     $gvopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
  45     $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
  46     $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
  47     $xrvsect, $xpvbmsect, $xpviosect);
  48
  49 sub walk_and_save_optree;
  50 my $saveoptree_callback = \&walk_and_save_optree;
  51 sub set_callback { $saveoptree_callback = shift }
  52 sub saveoptree { &$saveoptree_callback(@_) }
  53
  54 sub walk_and_save_optree {
  55     my ($name, $root, $start) = @_;
  56     walkoptree($root, "save");
  57     return objsym($start);
  58 }
  59
  60 # Current workaround/fix for op_free() trying to free statically
  61 # defined OPs is to set op_seq = -1 and check for that in op_free().
  62 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
  63 # so that it can be changed back easily if necessary. In fact, to
  64 # stop compilers from moaning about a U16 being initialised with an
  65 # uncast -1 (the printf format is %d so we can't tweak it), we have
  66 # to "know" that op_seq is a U16 and use 65535. Ugh.
  67 my $op_seq = 65535;
  68
  69 sub AVf_REAL () { 1 }
  70
  71 # XXX This shouldn't really be hardcoded here but it saves
  72 # looking up the name of every BASEOP in B::OP
  73 sub OP_THREADSV () { 345 }
  74
  75 sub savesym {
  76     my ($obj, $value) = @_;
  77     my $sym = sprintf("s\\_%x", $$obj);
  78     $symtable{$sym} = $value;
  79 }
  80
  81 sub objsym {
  82     my $obj = shift;
  83     return $symtable{sprintf("s\\_%x", $$obj)};
  84 }
  85
  86 sub getsym {
  87     my $sym = shift;
  88     my $value;
  89
  90     return 0 if $sym eq "sym_0";        # special case
  91     $value = $symtable{$sym};
  92     if (defined($value)) {
  93         return $value;
  94     } else {
  95         warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
  96         return "UNUSED";
  97     }
  98 }
  99
 100 sub savepv {
 101     my $pv = shift;
 102     my $pvsym = 0;
 103     my $pvmax = 0;
 104     if ($pv_copy_on_grow) {
 105         my $cstring = cstring($pv);
 106         if ($cstring ne "0") { # sic
 107             $pvsym = sprintf("pv%d", $pv_index++);
 108             $decl->add(sprintf("static char %s[] = %s;", $pvsym, $cstring));
 109         }
 110     } else {
 111         $pvmax = length($pv) + 1;
 112     }
 113     return ($pvsym, $pvmax);
 114 }
 115
 116 sub B::OP::save {
 117     my ($op, $level) = @_;
 118     my $type = $op->type;
 119     $nullop_count++ unless $type;
 120     if ($type == OP_THREADSV) {
 121         # saves looking up ppaddr but it's a bit naughty to hard code this
 122         $init->add(sprintf("(void)find_threadsv(%s);",
 123                            cstring($threadsv_names[$op->targ])));
 124     }
 125     $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
 126                          ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ,
 127                          $type, $op_seq, $op->flags, $op->private));
 128     savesym($op, sprintf("&op_list[%d]", $opsect->index));
 129 }
 130
 131 sub B::FAKEOP::new {
 132     my ($class, %objdata) = @_;
 133     bless \%objdata, $class;
 134 }
 135
 136 sub B::FAKEOP::save {
 137     my ($op, $level) = @_;
 138     $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
 139                          $op->next, $op->sibling, $op->ppaddr, $op->targ,
 140                          $op->type, $op_seq, $op->flags, $op->private));
 141     return sprintf("&op_list[%d]", $opsect->index);
 142 }
 143
 144 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
 145 sub B::FAKEOP::type { $_[0]->{type} || 0}
 146 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
 147 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
 148 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
 149 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
 150 sub B::FAKEOP::private { $_[0]->{private} || 0 }
 151
 152 sub B::UNOP::save {
 153     my ($op, $level) = @_;
 154     $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
 155                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 156                            $op->targ, $op->type, $op_seq, $op->flags,
 157                            $op->private, ${$op->first}));
 158     savesym($op, sprintf("(OP*)&unop_list[%d]", $unopsect->index));
 159 }
 160
 161 sub B::BINOP::save {
 162     my ($op, $level) = @_;
 163     $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
 164                             ${$op->next}, ${$op->sibling}, $op->ppaddr,
 165                             $op->targ, $op->type, $op_seq, $op->flags,
 166                             $op->private, ${$op->first}, ${$op->last}));
 167     savesym($op, sprintf("(OP*)&binop_list[%d]", $binopsect->index));
 168 }
 169
 170 sub B::LISTOP::save {
 171     my ($op, $level) = @_;
 172     $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u",
 173                              ${$op->next}, ${$op->sibling}, $op->ppaddr,
 174                              $op->targ, $op->type, $op_seq, $op->flags,
 175                              $op->private, ${$op->first}, ${$op->last},
 176                              $op->children));
 177     savesym($op, sprintf("(OP*)&listop_list[%d]", $listopsect->index));
 178 }
 179
 180 sub B::LOGOP::save {
 181     my ($op, $level) = @_;
 182     $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
 183                             ${$op->next}, ${$op->sibling}, $op->ppaddr,
 184                             $op->targ, $op->type, $op_seq, $op->flags,
 185                             $op->private, ${$op->first}, ${$op->other}));
 186     savesym($op, sprintf("(OP*)&logop_list[%d]", $logopsect->index));
 187 }
 188
 189 sub B::CONDOP::save {
 190     my ($op, $level) = @_;
 191     $condopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x",
 192                              ${$op->next}, ${$op->sibling}, $op->ppaddr,
 193                              $op->targ, $op->type, $op_seq, $op->flags,
 194                              $op->private, ${$op->first}, ${$op->true},
 195                              ${$op->false}));
 196     savesym($op, sprintf("(OP*)&condop_list[%d]", $condopsect->index));
 197 }
 198
 199 sub B::LOOP::save {
 200     my ($op, $level) = @_;
 201     #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
 202     #            peekop($op->redoop), peekop($op->nextop),
 203     #            peekop($op->lastop)); # debug
 204     $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, s\\_%x, s\\_%x, s\\_%x",
 205                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 206                            $op->targ, $op->type, $op_seq, $op->flags,
 207                            $op->private, ${$op->first}, ${$op->last},
 208                            $op->children, ${$op->redoop}, ${$op->nextop},
 209                            ${$op->lastop}));
 210     savesym($op, sprintf("(OP*)&loop_list[%d]", $loopsect->index));
 211 }
 212
 213 sub B::PVOP::save {
 214     my ($op, $level) = @_;
 215     $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
 216                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 217                            $op->targ, $op->type, $op_seq, $op->flags,
 218                            $op->private, cstring($op->pv)));
 219     savesym($op, sprintf("(OP*)&pvop_list[%d]", $pvopsect->index));
 220 }
 221
 222 sub B::SVOP::save {
 223     my ($op, $level) = @_;
 224     my $svsym = $op->sv->save;
 225     $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
 226                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 227                            $op->targ, $op->type, $op_seq, $op->flags,
 228                            $op->private, "(SV*)$svsym"));
 229     savesym($op, sprintf("(OP*)&svop_list[%d]", $svopsect->index));
 230 }
 231
 232 sub B::GVOP::save {
 233     my ($op, $level) = @_;
 234     my $gvsym = $op->gv->save;
 235     $gvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
 236                            ${$op->next}, ${$op->sibling}, $op->ppaddr,
 237                            $op->targ, $op->type, $op_seq, $op->flags,
 238                            $op->private));
 239     $init->add(sprintf("gvop_list[%d].op_gv = %s;", $gvopsect->index, $gvsym));
 240     savesym($op, sprintf("(OP*)&gvop_list[%d]", $gvopsect->index));
 241 }
 242
 243 sub B::COP::save {
 244     my ($op, $level) = @_;
 245     my $gvsym = $op->filegv->save;
 246     my $stashsym = $op->stash->save;
 247     warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
 248         if $debug_cops;
 249     $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, Nullhv, Nullgv, %u, %d, %u",
 250                           ${$op->next}, ${$op->sibling}, $op->ppaddr,
 251                           $op->targ, $op->type, $op_seq, $op->flags,
 252                           $op->private, cstring($op->label), $op->cop_seq,
 253                           $op->arybase, $op->line));
 254     my $copix = $copsect->index;
 255     $init->add(sprintf("cop_list[%d].cop_filegv = %s;", $copix, $gvsym),
 256                sprintf("cop_list[%d].cop_stash = %s;", $copix, $stashsym));
 257     savesym($op, "(OP*)&cop_list[$copix]");
 258 }
 259
 260 sub B::PMOP::save {
 261     my ($op, $level) = @_;
 262     my $replroot = $op->pmreplroot;
 263     my $replstart = $op->pmreplstart;
 264     my $replrootfield = sprintf("s\\_%x", $$replroot);
 265     my $replstartfield = sprintf("s\\_%x", $$replstart);
 266     my $gvsym;
 267     my $ppaddr = $op->ppaddr;
 268     if ($$replroot) {
 269         # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
 270         # argument to a split) stores a GV in op_pmreplroot instead
 271         # of a substitution syntax tree. We don't want to walk that...
 272         if ($ppaddr eq "pp_pushre") {
 273             $gvsym = $replroot->save;
 274 #           warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
 275             $replrootfield = 0;
 276         } else {
 277             $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
 278         }
 279     }
 280     # pmnext handling is broken in perl itself, I think. Bad op_pmnext
 281     # fields aren't noticed in perl's runtime (unless you try reset) but we
 282     # segfault when trying to dereference it to find op->op_pmnext->op_type
 283     $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %u, %s, %s, 0, 0, 0x%x, 0x%x",
 284                            ${$op->next}, ${$op->sibling}, $ppaddr, $op->targ,
 285                            $op->type, $op_seq, $op->flags, $op->private,
 286                            ${$op->first}, ${$op->last}, $op->children,
 287                            $replrootfield, $replstartfield,
 288                            $op->pmflags, $op->pmpermflags,));
 289     my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
 290     my $re = $op->precomp;
 291     if (defined($re)) {
 292         my $resym = sprintf("re%d", $re_index++);
 293         $decl->add(sprintf("static char *$resym = %s;", cstring($re)));
 294         $init->add(sprintf("$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
 295                            length($re)));
 296     }
 297     if ($gvsym) {
 298         $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
 299     }
 300     savesym($op, sprintf("(OP*)&pmop_list[%d]", $pmopsect->index));
 301 }
 302
 303 sub B::SPECIAL::save {
 304     my ($sv) = @_;
 305     # special case: $$sv is not the address but an index into specialsv_list
 306 #   warn "SPECIAL::save specialsv $$sv\n"; # debug
 307     my $sym = $specialsv_name[$$sv];
 308     if (!defined($sym)) {
 309         confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
 310     }
 311     return $sym;
 312 }
 313
 314 sub B::OBJECT::save {}
 315
 316 sub B::NULL::save {
 317     my ($sv) = @_;
 318     my $sym = objsym($sv);
 319     return $sym if defined $sym;
 320 #   warn "Saving SVt_NULL SV\n"; # debug
 321     # debug
 322     #if ($$sv == 0) {
 323     #   warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
 324     #}
 325     $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
 326     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 327 }
 328
 329 sub B::IV::save {
 330     my ($sv) = @_;
 331     my $sym = objsym($sv);
 332     return $sym if defined $sym;
 333     $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
 334     $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
 335                          $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 336     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 337 }
 338
 339 sub B::NV::save {
 340     my ($sv) = @_;
 341     my $sym = objsym($sv);
 342     return $sym if defined $sym;
 343     $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
 344     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
 345                          $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 346     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 347 }
 348
 349 sub B::PVLV::save {
 350     my ($sv) = @_;
 351     my $sym = objsym($sv);
 352     return $sym if defined $sym;
 353     my $pv = $sv->PV;
 354     my $len = length($pv);
 355     my ($pvsym, $pvmax) = savepv($pv);
 356     my ($lvtarg, $lvtarg_sym);
 357     $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
 358                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
 359                             $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
 360     $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
 361                          $xpvlvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 362     if (!$pv_copy_on_grow) {
 363         $init->add(sprintf("xpvlv_list[%d].xpv_pv = savepvn(%s, %u);",
 364                            $xpvlvsect->index, cstring($pv), $len));
 365     }
 366     $sv->save_magic;
 367     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 368 }
 369
 370 sub B::PVIV::save {
 371     my ($sv) = @_;
 372     my $sym = objsym($sv);
 373     return $sym if defined $sym;
 374     my $pv = $sv->PV;
 375     my $len = length($pv);
 376     my ($pvsym, $pvmax) = savepv($pv);
 377     $xpvivsect->add(sprintf("%s, %u, %u, %d", $pvsym, $len, $pvmax, $sv->IVX));
 378     $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
 379                          $xpvivsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 380     if (!$pv_copy_on_grow) {
 381         $init->add(sprintf("xpviv_list[%d].xpv_pv = savepvn(%s, %u);",
 382                            $xpvivsect->index, cstring($pv), $len));
 383     }
 384     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 385 }
 386
 387 sub B::PVNV::save {
 388     my ($sv) = @_;
 389     my $sym = objsym($sv);
 390     return $sym if defined $sym;
 391     my $pv = $sv->PV;
 392     my $len = length($pv);
 393     my ($pvsym, $pvmax) = savepv($pv);
 394     $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
 395                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
 396     $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
 397                          $xpvnvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 398     if (!$pv_copy_on_grow) {
 399         $init->add(sprintf("xpvnv_list[%d].xpv_pv = savepvn(%s,%u);",
 400                            $xpvnvsect->index, cstring($pv), $len));
 401     }
 402     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 403 }
 404
 405 sub B::BM::save {
 406     my ($sv) = @_;
 407     my $sym = objsym($sv);
 408     return $sym if defined $sym;
 409     my $pv = $sv->PV . "\0" . $sv->TABLE;
 410     my $len = length($pv);
 411     $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
 412                             $len, $len + 258, $sv->IVX, $sv->NVX,
 413                             $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
 414     $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
 415                          $xpvbmsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 416     $sv->save_magic;
 417     $init->add(sprintf("xpvbm_list[%d].xpv_pv = savepvn(%s, %u);",
 418                        $xpvbmsect->index, cstring($pv), $len),
 419                sprintf("xpvbm_list[%d].xpv_cur = %u;",
 420                        $xpvbmsect->index, $len - 257));
 421     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 422 }
 423
 424 sub B::PV::save {
 425     my ($sv) = @_;
 426     my $sym = objsym($sv);
 427     return $sym if defined $sym;
 428     my $pv = $sv->PV;
 429     my $len = length($pv);
 430     my ($pvsym, $pvmax) = savepv($pv);
 431     $xpvsect->add(sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
 432     $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
 433                          $xpvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 434     if (!$pv_copy_on_grow) {
 435         $init->add(sprintf("xpv_list[%d].xpv_pv = savepvn(%s, %u);",
 436                            $xpvsect->index, cstring($pv), $len));
 437     }
 438     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 439 }
 440
 441 sub B::PVMG::save {
 442     my ($sv) = @_;
 443     my $sym = objsym($sv);
 444     return $sym if defined $sym;
 445     my $pv = $sv->PV;
 446     my $len = length($pv);
 447     my ($pvsym, $pvmax) = savepv($pv);
 448     $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
 449                             $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
 450     $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
 451                          $xpvmgsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 452     if (!$pv_copy_on_grow) {
 453         $init->add(sprintf("xpvmg_list[%d].xpv_pv = savepvn(%s, %u);",
 454                            $xpvmgsect->index, cstring($pv), $len));
 455     }
 456     $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 457     $sv->save_magic;
 458     return $sym;
 459 }
 460
 461 sub B::PVMG::save_magic {
 462     my ($sv) = @_;
 463     #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
 464     my $stash = $sv->SvSTASH;
 465     if ($$stash) {
 466         warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
 467             if $debug_mg;
 468         # XXX Hope stash is already going to be saved.
 469         $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
 470     }
 471     my @mgchain = $sv->MAGIC;
 472     my ($mg, $type, $obj, $ptr);
 473     foreach $mg (@mgchain) {
 474         $type = $mg->TYPE;
 475         $obj = $mg->OBJ;
 476         $ptr = $mg->PTR;
 477         my $len = defined($ptr) ? length($ptr) : 0;
 478         if ($debug_mg) {
 479             warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
 480                          class($sv), $$sv, class($obj), $$obj,
 481                          cchar($type), cstring($ptr));
 482         }
 483         $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
 484                            $$sv, $$obj, cchar($type),cstring($ptr),$len));
 485     }
 486 }
 487
 488 sub B::RV::save {
 489     my ($sv) = @_;
 490     my $sym = objsym($sv);
 491     return $sym if defined $sym;
 492     $xrvsect->add($sv->RV->save);
 493     $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
 494                          $xrvsect->index, $sv->REFCNT + 1, $sv->FLAGS));
 495     return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
 496 }
 497
 498 sub try_autoload {
 499     my ($cvstashname, $cvname) = @_;
 500     warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
 501     # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
 502     # use should be handled by the class itself.
 503     no strict 'refs';
 504     my $isa = \@{"$cvstashname\::ISA"};
 505     if (grep($_ eq "AutoLoader", @$isa)) {
 506         warn "Forcing immediate load of sub derived from AutoLoader\n";
 507         # Tweaked version of AutoLoader::AUTOLOAD
 508         my $dir = $cvstashname;
 509         $dir =~ s(::)(/)g;
 510         eval { require "auto/$dir/$cvname.al" };
 511         if ($@) {
 512             warn qq(failed require "auto/$dir/$cvname.al": $@\n);
 513             return 0;
 514         } else {
 515             return 1;
 516         }
 517     }
 518 }
 519
 520 sub B::CV::save {
 521     my ($cv) = @_;
 522     my $sym = objsym($cv);
 523     if (defined($sym)) {
 524 #       warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
 525         return $sym;
 526     }
 527     # Reserve a place in svsect and xpvcvsect and record indices
 528     my $sv_ix = $svsect->index + 1;
 529     $svsect->add("svix$sv_ix");
 530     my $xpvcv_ix = $xpvcvsect->index + 1;
 531     $xpvcvsect->add("xpvcvix$xpvcv_ix");
 532     # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
 533     $sym = savesym($cv, "&sv_list[$sv_ix]");
 534     warn sprintf("saving CV 0x%x as $sym\n", $$cv) if $debug_cv;
 535     my $gv = $cv->GV;
 536     my $cvstashname = $gv->STASH->NAME;
 537     my $cvname = $gv->NAME;
 538     my $root = $cv->ROOT;
 539     my $cvxsub = $cv->XSUB;
 540     if (!$$root && !$cvxsub) {
 541         if (try_autoload($cvstashname, $cvname)) {
 542             # Recalculate root and xsub
 543             $root = $cv->ROOT;
 544             $cvxsub = $cv->XSUB;
 545             if ($$root || $cvxsub) {
 546                 warn "Successful forced autoload\n";
 547             }
 548         }
 549     }
 550     my $startfield = 0;
 551     my $padlist = $cv->PADLIST;
 552     my $pv = $cv->PV;
 553     my $xsub = 0;
 554     my $xsubany = "Nullany";
 555     if ($$root) {
 556         warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
 557                      $$cv, $$root) if $debug_cv;
 558         my $ppname = "";
 559         if ($$gv) {
 560             my $stashname = $gv->STASH->NAME;
 561             my $gvname = $gv->NAME;
 562             if ($gvname ne "__ANON__") {
 563                 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
 564                 $ppname .= ($stashname eq "main") ?
 565                             $gvname : "$stashname\::$gvname";
 566                 $ppname =~ s/::/__/g;
 567             }
 568         }
 569         if (!$ppname) {
 570             $ppname = "pp_anonsub_$anonsub_index";
 571             $anonsub_index++;
 572         }
 573         $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
 574         warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
 575                      $$cv, $ppname, $$root) if $debug_cv;
 576         if ($$padlist) {
 577             warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
 578                          $$padlist, $$cv) if $debug_cv;
 579             $padlist->save;
 580             warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
 581                          $$padlist, $$cv) if $debug_cv;
 582         }
 583     }
 584     elsif ($cvxsub) {
 585         $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
 586         # Try to find out canonical name of XSUB function from EGV.
 587         # XXX Doesn't work for XSUBs with PREFIX set (or anyone who
 588         # calls newXS() manually with weird arguments).
 589         my $egv = $gv->EGV;
 590         my $stashname = $egv->STASH->NAME;
 591         $stashname =~ s/::/__/g;
 592         $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
 593         $decl->add("void $xsub _((CV*));");
 594     }
 595     else {
 596         warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
 597                      $cvstashname, $cvname); # debug
 598     }
 599     $symsect->add(sprintf("xpvcvix%d\t%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, s\\_%x, $xsub, $xsubany, Nullgv, Nullgv, %d, s\\_%x, (CV*)s\\_%x, 0x%x",
 600                           $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
 601                           $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
 602                         $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
 603
 604     if (${$cv->OUTSIDE} == ${main_cv()}){
 605         $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
 606     }
 607
 608     if ($$gv) {
 609         $gv->save;
 610         $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
 611         warn sprintf("done saving GV 0x%x for CV 0x%x\n",
 612                      $$gv, $$cv) if $debug_cv;
 613     }
 614     my $filegv = $cv->FILEGV;
 615     if ($$filegv) {
 616         $filegv->save;
 617         $init->add(sprintf("CvFILEGV(s\\_%x) = s\\_%x;", $$cv, $$filegv));
 618         warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
 619                      $$filegv, $$cv) if $debug_cv;
 620     }
 621     my $stash = $cv->STASH;
 622     if ($$stash) {
 623         $stash->save;
 624         $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
 625         warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
 626                      $$stash, $$cv) if $debug_cv;
 627     }
 628     $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
 629                           $sv_ix, $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS));
 630     return $sym;
 631 }
 632
 633 sub B::GV::save {
 634     my ($gv) = @_;
 635     my $sym = objsym($gv);
 636     if (defined($sym)) {
 637         #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
 638         return $sym;
 639     } else {
 640         my $ix = $gv_index++;
 641         $sym = savesym($gv, "gv_list[$ix]");
 642         #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
 643     }
 644     my $gvname = $gv->NAME;
 645     my $name = cstring($gv->STASH->NAME . "::" . $gvname);
 646     #warn "GV name is $name\n"; # debug
 647     my $egv = $gv->EGV;
 648     my $egvsym;
 649     if ($$gv != $$egv) {
 650         #warn(sprintf("EGV name is %s, saving it now\n",
 651         #            $egv->STASH->NAME . "::" . $egv->NAME)); # debug
 652         $egvsym = $egv->save;
 653     }
 654     $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
 655                sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
 656                sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
 657                sprintf("GvLINE($sym) = %u;", $gv->LINE));
 658     # Shouldn't need to do save_magic since gv_fetchpv handles that
 659     #$gv->save_magic;
 660     my $refcnt = $gv->REFCNT + 1;
 661     $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
 662     my $gvrefcnt = $gv->GvREFCNT;
 663     if ($gvrefcnt > 1) {
 664         $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
 665     }
 666     if (defined($egvsym)) {
 667         # Shared glob *foo = *bar
 668         $init->add("gp_free($sym);",
 669                    "GvGP($sym) = GvGP($egvsym);");
 670     } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
 671         # Don't save subfields of special GVs (*_, *1, *# and so on)
 672 #       warn "GV::save saving subfields\n"; # debug
 673         my $gvsv = $gv->SV;
 674         if ($$gvsv) {
 675             $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
 676 #           warn "GV::save \$$name\n"; # debug
 677             $gvsv->save;
 678         }
 679         my $gvav = $gv->AV;
 680         if ($$gvav) {
 681             $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
 682 #           warn "GV::save \@$name\n"; # debug
 683             $gvav->save;
 684         }
 685         my $gvhv = $gv->HV;
 686         if ($$gvhv) {
 687             $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
 688 #           warn "GV::save \%$name\n"; # debug
 689             $gvhv->save;
 690         }
 691         my $gvcv = $gv->CV;
 692         if ($$gvcv) {
 693             $init->add(sprintf("GvCV($sym) = (CV*)s\\_%x;", $$gvcv));
 694 #           warn "GV::save &$name\n"; # debug
 695             $gvcv->save;
 696         }
 697         my $gvfilegv = $gv->FILEGV;
 698         if ($$gvfilegv) {
 699             $init->add(sprintf("GvFILEGV($sym) = (GV*)s\\_%x;",$$gvfilegv));
 700 #           warn "GV::save GvFILEGV(*$name)\n"; # debug
 701             $gvfilegv->save;
 702         }
 703         my $gvform = $gv->FORM;
 704         if ($$gvform) {
 705             $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
 706 #           warn "GV::save GvFORM(*$name)\n"; # debug
 707             $gvform->save;
 708         }
 709         my $gvio = $gv->IO;
 710         if ($$gvio) {
 711             $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
 712 #           warn "GV::save GvIO(*$name)\n"; # debug
 713             $gvio->save;
 714         }
 715     }
 716     return $sym;
 717 }
 718 sub B::AV::save {
 719     my ($av) = @_;
 720     my $sym = objsym($av);
 721     return $sym if defined $sym;
 722     my $avflags = $av->AvFLAGS;
 723     $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
 724                             $avflags));
 725     $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
 726                          $xpvavsect->index, $av->REFCNT + 1, $av->FLAGS));
 727     my $sv_list_index = $svsect->index;
 728     my $fill = $av->FILL;
 729     $av->save_magic;
 730     warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
 731         if $debug_av;
 732     # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
 733     #if ($fill > -1 && ($avflags & AVf_REAL)) {
 734     if ($fill > -1) {
 735         my @array = $av->ARRAY;
 736         if ($debug_av) {
 737             my $el;
 738             my $i = 0;
 739             foreach $el (@array) {
 740                 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
 741                              $$av, $i++, class($el), $$el);
 742             }
 743         }
 744         my @names = map($_->save, @array);
 745         # XXX Better ways to write loop?
 746         # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
 747         # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
 748         $init->add("{",
 749                    "\tSV **svp;",
 750                    "\tAV *av = (AV*)&sv_list[$sv_list_index];",
 751                    "\tav_extend(av, $fill);",
 752                    "\tsvp = AvARRAY(av);",
 753                map("\t*svp++ = (SV*)$_;", @names),
 754                    "\tAvFILLp(av) = $fill;",
 755                    "}");
 756     } else {
 757         my $max = $av->MAX;
 758         $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
 759             if $max > -1;
 760     }
 761     return savesym($av, "(AV*)&sv_list[$sv_list_index]");
 762 }
 763
 764 sub B::HV::save {
 765     my ($hv) = @_;
 766     my $sym = objsym($hv);
 767     return $sym if defined $sym;
 768     my $name = $hv->NAME;
 769     if ($name) {
 770         # It's a stash
 771
 772         # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
 773         # the only symptom is that sv_reset tries to reset the PMf_USED flag of
 774         # a trashed op but we look at the trashed op_type and segfault.
 775         #my $adpmroot = ${$hv->PMROOT};
 776         my $adpmroot = 0;
 777         $decl->add("static HV *hv$hv_index;");
 778         # XXX Beware of weird package names containing double-quotes, \n, ...?
 779         $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
 780         if ($adpmroot) {
 781             $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
 782                                $adpmroot));
 783         }
 784         $sym = savesym($hv, "hv$hv_index");
 785         $hv_index++;
 786         return $sym;
 787     }
 788     # It's just an ordinary HV
 789     $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
 790                             $hv->MAX, $hv->RITER));
 791     $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
 792                          $xpvhvsect->index, $hv->REFCNT + 1, $hv->FLAGS));
 793     my $sv_list_index = $svsect->index;
 794     my @contents = $hv->ARRAY;
 795     if (@contents) {
 796         my $i;
 797         for ($i = 1; $i < @contents; $i += 2) {
 798             $contents[$i] = $contents[$i]->save;
 799         }
 800         $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
 801         while (@contents) {
 802             my ($key, $value) = splice(@contents, 0, 2);
 803             $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
 804                                cstring($key),length($key),$value, hash($key)));
 805         }
 806         $init->add("}");
 807     }
 808     return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
 809 }
 810
 811 sub B::IO::save {
 812     my ($io) = @_;
 813     my $sym = objsym($io);
 814     return $sym if defined $sym;
 815     my $pv = $io->PV;
 816     my $len = length($pv);
 817     $xpviosect->add(sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
 818                             $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
 819                             $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
 820                             cstring($io->TOP_NAME), cstring($io->FMT_NAME),
 821                             cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
 822                             cchar($io->IoTYPE), $io->IoFLAGS));
 823     $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
 824                          $xpviosect->index, $io->REFCNT + 1, $io->FLAGS));
 825     $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
 826     my ($field, $fsym);
 827     foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
 828         $fsym = $io->$field();
 829         if ($$fsym) {
 830             $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
 831             $fsym->save;
 832         }
 833     }
 834     $io->save_magic;
 835     return $sym;
 836 }
 837
 838 sub B::SV::save {
 839     my $sv = shift;
 840     # This is where we catch an honest-to-goodness Nullsv (which gets
 841     # blessed into B::SV explicitly) and any stray erroneous SVs.
 842     return 0 unless $$sv;
 843     confess sprintf("cannot save that type of SV: %s (0x%x)\n",
 844                     class($sv), $$sv);
 845 }
 846
 847 sub output_all {
 848     my $init_name = shift;
 849     my $section;
 850     my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
 851                     $listopsect, $pmopsect, $svopsect, $gvopsect, $pvopsect,
 852                     $cvopsect, $loopsect, $copsect, $svsect, $xpvsect,
 853                     $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
 854                     $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
 855     $symsect->output(\*STDOUT, "#define %s\n");
 856     print "\n";
 857     output_declarations();
 858     foreach $section (@sections) {
 859         my $lines = $section->index + 1;
 860         if ($lines) {
 861             my $name = $section->name;
 862             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 863             print "Static $typename ${name}_list[$lines];\n";
 864         }
 865     }
 866     $decl->output(\*STDOUT, "%s\n");
 867     print "\n";
 868     foreach $section (@sections) {
 869         my $lines = $section->index + 1;
 870         if ($lines) {
 871             my $name = $section->name;
 872             my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
 873             printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
 874             $section->output(\*STDOUT, "\t{ %s },\n");
 875             print "};\n\n";
 876         }
 877     }
 878
 879     print <<"EOT";
 880 static int $init_name()
 881 {
 882         dTHR;
 883 EOT
 884     $init->output(\*STDOUT, "\t%s\n");
 885     print "\treturn 0;\n}\n";
 886     if ($verbose) {
 887         warn compile_stats();
 888         warn "NULLOP count: $nullop_count\n";
 889     }
 890 }
 891
 892 sub output_declarations {
 893     print <<'EOT';
 894 #ifdef BROKEN_STATIC_REDECL
 895 #define Static extern
 896 #else
 897 #define Static static
 898 #endif /* BROKEN_STATIC_REDECL */
 899
 900 #ifdef BROKEN_UNION_INIT
 901 /*
 902  * Cribbed from cv.h with ANY (a union) replaced by void*.
 903  * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
 904  */
 905 typedef struct {
 906     char *      xpv_pv;         /* pointer to malloced string */
 907     STRLEN      xpv_cur;        /* length of xp_pv as a C string */
 908     STRLEN      xpv_len;        /* allocated size */
 909     IV          xof_off;        /* integer value */
 910     double      xnv_nv;         /* numeric value, if any */
 911     MAGIC*      xmg_magic;      /* magic for scalar array */
 912     HV*         xmg_stash;      /* class package */
 913
 914     HV *        xcv_stash;
 915     OP *        xcv_start;
 916     OP *        xcv_root;
 917     void      (*xcv_xsub) _((CV*));
 918     void *      xcv_xsubany;
 919     GV *        xcv_gv;
 920     GV *        xcv_filegv;
 921     long        xcv_depth;              /* >= 2 indicates recursive call */
 922     AV *        xcv_padlist;
 923     CV *        xcv_outside;
 924 #ifdef USE_THREADS
 925     perl_mutex *xcv_mutexp;
 926     struct perl_thread *xcv_owner;      /* current owner thread */
 927 #endif /* USE_THREADS */
 928     U8          xcv_flags;
 929 } XPVCV_or_similar;
 930 #define ANYINIT(i) i
 931 #else
 932 #define XPVCV_or_similar XPVCV
 933 #define ANYINIT(i) {i}
 934 #endif /* BROKEN_UNION_INIT */
 935 #define Nullany ANYINIT(0)
 936
 937 #define UNUSED 0
 938 #define sym_0 0
 939
 940 EOT
 941     print "static GV *gv_list[$gv_index];\n" if $gv_index;
 942     print "\n";
 943 }
 944
 945
 946 sub output_boilerplate {
 947     print <<'EOT';
 948 #include "EXTERN.h"
 949 #include "perl.h"
 950 #ifndef PATCHLEVEL
 951 #include "patchlevel.h"
 952 #endif
 953
 954 /* Workaround for mapstart: the only op which needs a different ppaddr */
 955 #undef pp_mapstart
 956 #define pp_mapstart pp_grepstart
 957
 958 static void xs_init _((void));
 959 static PerlInterpreter *my_perl;
 960 EOT
 961 }
 962
 963 sub output_main {
 964     print <<'EOT';
 965 int
 966 #ifndef CAN_PROTOTYPE
 967 main(argc, argv, env)
 968 int argc;
 969 char **argv;
 970 char **env;
 971 #else  /* def(CAN_PROTOTYPE) */
 972 main(int argc, char **argv, char **env)
 973 #endif  /* def(CAN_PROTOTYPE) */
 974 {
 975     int exitstatus;
 976     int i;
 977     char **fakeargv;
 978
 979     PERL_SYS_INIT(&argc,&argv);
 980
 981     perl_init_i18nl10n(1);
 982
 983     if (!PL_do_undump) {
 984         my_perl = perl_alloc();
 985         if (!my_perl)
 986             exit(1);
 987         perl_construct( my_perl );
 988     }
 989
 990 #ifdef CSH
 991     if (!PL_cshlen)
 992       PL_cshlen = strlen(PL_cshname);
 993 #endif
 994
 995 #ifdef ALLOW_PERL_OPTIONS
 996 #define EXTRA_OPTIONS 2
 997 #else
 998 #define EXTRA_OPTIONS 3
 999 #endif /* ALLOW_PERL_OPTIONS */
1000     New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1001     fakeargv[0] = argv[0];
1002     fakeargv[1] = "-e";
1003     fakeargv[2] = "";
1004 #ifndef ALLOW_PERL_OPTIONS
1005     fakeargv[3] = "--";
1006 #endif /* ALLOW_PERL_OPTIONS */
1007     for (i = 1; i < argc; i++)
1008         fakeargv[i + EXTRA_OPTIONS] = argv[i];
1009     fakeargv[argc + EXTRA_OPTIONS] = 0;
1010
1011     exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1012                             fakeargv, NULL);
1013     if (exitstatus)
1014         exit( exitstatus );
1015
1016     sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1017     PL_main_cv = PL_compcv;
1018     PL_compcv = 0;
1019
1020     exitstatus = perl_init();
1021     if (exitstatus)
1022         exit( exitstatus );
1023
1024     exitstatus = perl_run( my_perl );
1025
1026     perl_destruct( my_perl );
1027     perl_free( my_perl );
1028
1029     exit( exitstatus );
1030 }
1031
1032 static void
1033 xs_init()
1034 {
1035 }
1036 EOT
1037 }
1038
1039 sub dump_symtable {
1040     # For debugging
1041     my ($sym, $val);
1042     warn "----Symbol table:\n";
1043     while (($sym, $val) = each %symtable) {
1044         warn "$sym => $val\n";
1045     }
1046     warn "---End of symbol table\n";
1047 }
1048
1049 sub save_object {
1050     my $sv;
1051     foreach $sv (@_) {
1052         svref_2object($sv)->save;
1053     }
1054 }
1055
1056 sub B::GV::savecv {
1057     my $gv = shift;
1058     my $cv = $gv->CV;
1059     my $name = $gv->NAME;
1060     if ($$cv && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
1061         if ($debug_cv) {
1062             warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1063                          $gv->STASH->NAME, $name, $$cv, $$gv);
1064         }
1065       my $package=$gv->STASH->NAME;
1066       if ( ! grep(/^$package$/,@unused_sub_packages)){
1067           warn sprintf("omitting cv in superclass %s", $gv->STASH->NAME)
1068               if $debug_cv;
1069           return ;
1070       }
1071         $gv->save;
1072     }
1073     elsif ($name eq 'ISA')
1074      {
1075       $gv->save;
1076      }
1077
1078 }
1079
1080 sub save_unused_subs {
1081     my %search_pack;
1082     map { $search_pack{$_} = 1 } @_;
1083     @unused_sub_packages=@_;
1084     no strict qw(vars refs);
1085     walksymtable(\%{"main::"}, "savecv", sub {
1086         my $package = shift;
1087         $package =~ s/::$//;
1088         return 0 if ($package =~ /::::/);  # skip ::::ISA::CACHE etc.
1089         #warn "Considering $package\n";#debug
1090         return 1 if exists $search_pack{$package};
1091       #sub try for a partial match
1092       if (grep(/^$package\:\:/,@unused_sub_packages)){
1093           return 1;
1094       }
1095         #warn "    (nothing explicit)\n";#debug
1096         # Omit the packages which we use (and which cause grief
1097         # because of fancy "goto &$AUTOLOAD" stuff).
1098         # XXX Surely there must be a nicer way to do this.
1099         if ($package eq "FileHandle"
1100             || $package eq "Config"
1101             || $package eq "SelectSaver") {
1102             return 0;
1103         }
1104         foreach my $u (keys %search_pack) {
1105             if ($package =~ /^${u}::/) {
1106                 warn "$package starts with $u\n";
1107                 return 1
1108             }
1109             if ($package->isa($u)) {
1110                 warn "$package isa $u\n";
1111                 return 1
1112             }
1113             return 1 if $package->isa($u);
1114         }
1115         foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH)) {
1116             if (defined(&{$package."::$m"})) {
1117                 warn "$package has method $m: -u$package assumed\n";#debug
1118               push @unused_sub_package, $package;
1119                 return 1;
1120             }
1121         }
1122         return 0;
1123     });
1124 }
1125
1126 sub save_main {
1127     my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1128     my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1129     walkoptree(main_root, "save");
1130     warn "done main optree, walking symtable for extras\n" if $debug_cv;
1131     save_unused_subs(@unused_sub_packages);
1132
1133     $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1134                sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1135                "PL_curpad = AvARRAY($curpad_sym);",
1136                "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1137                "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));");
1138
1139     warn "Writing output\n";
1140     output_boilerplate();
1141     print "\n";
1142     output_all("perl_init");
1143     print "\n";
1144     output_main();
1145 }
1146
1147 sub init_sections {
1148     my @sections = (init => \$init, decl => \$decl, sym => \$symsect,
1149                     binop => \$binopsect, condop => \$condopsect,
1150                     cop => \$copsect, cvop => \$cvopsect, gvop => \$gvopsect,
1151                     listop => \$listopsect, logop => \$logopsect,
1152                     loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1153                     pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1154                     sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1155                     xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1156                     xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1157                     xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1158                     xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1159                     xpvio => \$xpviosect);
1160     my ($name, $sectref);
1161     while (($name, $sectref) = splice(@sections, 0, 2)) {
1162         $$sectref = new B::Section $name, \%symtable, 0;
1163     }
1164 }
1165
1166 sub compile {
1167     my @options = @_;
1168     my ($option, $opt, $arg);
1169   OPTION:
1170     while ($option = shift @options) {
1171         if ($option =~ /^-(.)(.*)/) {
1172             $opt = $1;
1173             $arg = $2;
1174         } else {
1175             unshift @options, $option;
1176             last OPTION;
1177         }
1178         if ($opt eq "-" && $arg eq "-") {
1179             shift @options;
1180             last OPTION;
1181         }
1182         if ($opt eq "w") {
1183             $warn_undefined_syms = 1;
1184         } elsif ($opt eq "D") {
1185             $arg ||= shift @options;
1186             foreach $arg (split(//, $arg)) {
1187                 if ($arg eq "o") {
1188                     B->debug(1);
1189                 } elsif ($arg eq "c") {
1190                     $debug_cops = 1;
1191                 } elsif ($arg eq "A") {
1192                     $debug_av = 1;
1193                 } elsif ($arg eq "C") {
1194                     $debug_cv = 1;
1195                 } elsif ($arg eq "M") {
1196                     $debug_mg = 1;
1197                 } else {
1198                     warn "ignoring unknown debug option: $arg\n";
1199                 }
1200             }
1201         } elsif ($opt eq "o") {
1202             $arg ||= shift @options;
1203             open(STDOUT, ">$arg") or return "$arg: $!\n";
1204         } elsif ($opt eq "v") {
1205             $verbose = 1;
1206         } elsif ($opt eq "u") {
1207             $arg ||= shift @options;
1208             push(@unused_sub_packages, $arg);
1209         } elsif ($opt eq "f") {
1210             $arg ||= shift @options;
1211             if ($arg eq "cog") {
1212                 $pv_copy_on_grow = 1;
1213             } elsif ($arg eq "no-cog") {
1214                 $pv_copy_on_grow = 0;
1215             }
1216         } elsif ($opt eq "O") {
1217             $arg = 1 if $arg eq "";
1218             $pv_copy_on_grow = 0;
1219             if ($arg >= 1) {
1220                 # Optimisations for -O1
1221                 $pv_copy_on_grow = 1;
1222             }
1223         }
1224     }
1225     init_sections();
1226     if (@options) {
1227         return sub {
1228             my $objname;
1229             foreach $objname (@options) {
1230                 eval "save_object(\\$objname)";
1231             }
1232             output_all();
1233         }
1234     } else {
1235         return sub { save_main() };
1236     }
1237 }
1238
1239 1;
1240
1241 __END__
1242
1243 =head1 NAME
1244
1245 B::C - Perl compiler's C backend
1246
1247 =head1 SYNOPSIS
1248
1249         perl -MO=C[,OPTIONS] foo.pl
1250
1251 =head1 DESCRIPTION
1252
1253 This compiler backend takes Perl source and generates C source code
1254 corresponding to the internal structures that perl uses to run
1255 your program. When the generated C source is compiled and run, it
1256 cuts out the time which perl would have taken to load and parse
1257 your program into its internal semi-compiled form. That means that
1258 compiling with this backend will not help improve the runtime
1259 execution speed of your program but may improve the start-up time.
1260 Depending on the environment in which your program runs this may be
1261 either a help or a hindrance.
1262
1263 =head1 OPTIONS
1264
1265 If there are any non-option arguments, they are taken to be
1266 names of objects to be saved (probably doesn't work properly yet).
1267 Without extra arguments, it saves the main program.
1268
1269 =over 4
1270
1271 =item B<-ofilename>
1272
1273 Output to filename instead of STDOUT
1274
1275 =item B<-v>
1276
1277 Verbose compilation (currently gives a few compilation statistics).
1278
1279 =item B<-->
1280
1281 Force end of options
1282
1283 =item B<-uPackname>
1284
1285 Force apparently unused subs from package Packname to be compiled.
1286 This allows programs to use eval "foo()" even when sub foo is never
1287 seen to be used at compile time. The down side is that any subs which
1288 really are never used also have code generated. This option is
1289 necessary, for example, if you have a signal handler foo which you
1290 initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
1291 to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1292 options. The compiler tries to figure out which packages may possibly
1293 have subs in which need compiling but the current version doesn't do
1294 it very well. In particular, it is confused by nested packages (i.e.
1295 of the form C<A::B>) where package C<A> does not contain any subs.
1296
1297 =item B<-D>
1298
1299 Debug options (concatenated or separate flags like C<perl -D>).
1300
1301 =item B<-Do>
1302
1303 OPs, prints each OP as it's processed
1304
1305 =item B<-Dc>
1306
1307 COPs, prints COPs as processed (incl. file & line num)
1308
1309 =item B<-DA>
1310
1311 prints AV information on saving
1312
1313 =item B<-DC>
1314
1315 prints CV information on saving
1316
1317 =item B<-DM>
1318
1319 prints MAGIC information on saving
1320
1321 =item B<-f>
1322
1323 Force optimisations on or off one at a time.
1324
1325 =item B<-fcog>
1326
1327 Copy-on-grow: PVs declared and initialised statically.
1328
1329 =item B<-fno-cog>
1330
1331 No copy-on-grow.
1332
1333 =item B<-On>
1334
1335 Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.  Currently,
1336 B<-O1> and higher set B<-fcog>.
1337
1338 =head1 EXAMPLES
1339
1340     perl -MO=C,-ofoo.c foo.pl
1341     perl cc_harness -o foo foo.c
1342
1343 Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1344 library directory. The utility called C<perlcc> may also be used to
1345 help make use of this compiler.
1346
1347     perl -MO=C,-v,-DcA bar.pl > /dev/null
1348
1349 =head1 BUGS
1350
1351 Plenty. Current status: experimental.
1352
1353 =head1 AUTHOR
1354
1355 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1356
1357 =cut