3 # Copyright (c) 1996 Malcolm Beattie
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.
11 @EXPORT_OK = qw(push_decl init_init push_init output_all output_boilerplate
12 output_main set_callback save_unused_subs objsym);
14 use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start
15 ad peekop class cstring cchar svref_2object compile_stats
17 use B::Asmdata qw(@specialsv_name);
27 my $anonsub_index = 0;
28 my (@binop_list, @condop_list, @cop_list, @cvop_list, @decl_list,
29 @gvop_list, @listop_list, @logop_list, @loop_list, @op_list, @pmop_list,
30 @pvop_list, @sv_list, @svop_list, @unop_list, @xpv_list,
31 @xpvav_list, @xpvhv_list, @xpvcv_list, @xpviv_list, @xpvnv_list,
32 @xpvmg_list, @xpvlv_list, @xrv_list, @xpvbm_list, @xpvio_list);
36 my $warn_undefined_syms;
38 my @unused_sub_packages;
41 my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
43 sub walk_and_save_optree;
44 my $saveoptree_callback = \&walk_and_save_optree;
45 sub set_callback { $saveoptree_callback = shift }
46 sub saveoptree { &$saveoptree_callback(@_) }
48 sub walk_and_save_optree {
49 my ($name, $root, $start) = @_;
50 walkoptree($root, "save");
51 return objsym($start);
59 $init_list_fh->close if defined $init_list_fh;
60 $init_list_fh = FileHandle->new_tmpfile;
61 return $init_list_fh ? 1 : 0;
65 map { print $init_list_fh $_, "\n" } @_;
68 # Current workaround/fix for op_free() trying to free statically
69 # defined OPs is to set op_seq = -1 and check for that in op_free().
70 # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
71 # so that it can be changed back easily if necessary. In fact, to
72 # stop compilers from moaning about a U16 being initialised with an
73 # uncast -1 (the printf format is %d so we can't tweak it), we have
74 # to "know" that op_seq is a U16 and use 65535. Ugh.
80 my ($obj, $value) = @_;
81 # warn(sprintf("savesym: sym_%x => %s\n", ad($obj), $value)); # debug
82 $symtable{sprintf("sym_%x", ad($obj))} = $value;
87 return $symtable{sprintf("sym_%x", ad($obj))};
94 return 0 if $sym eq "sym_0"; # special case
95 $value = $symtable{$sym};
96 if (defined($value)) {
99 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
105 $_[0] =~ s/(sym_[0-9a-f]+)/getsym($1)/ge;
112 if ($pv_copy_on_grow) {
113 my $cstring = cstring($pv);
114 if ($cstring ne "0") { # sic
115 $pvsym = sprintf("pv%d", $pv_index++);
116 push(@decl_list,sprintf("static char %s[] = %s;",$pvsym,$cstring));
119 $pvmax = length($pv) + 1;
121 return ($pvsym, $pvmax);
125 my ($op, $level) = @_;
126 my $type = $op->type;
127 $nullop_count++ unless $type;
129 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x",
130 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
131 $type, $op_seq, $op->flags, $op->private));
132 savesym($op, "&op_list[$#op_list]");
136 my ($class, %objdata) = @_;
137 bless \%objdata, $class;
140 sub B::FAKEOP::save {
141 my ($op, $level) = @_;
143 sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
144 $op->next, $op->sibling, $op->ppaddr, $op->targ,
145 $op->type, $op_seq, $op->flags, $op->private));
146 return "&op_list[$#op_list]";
149 sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
150 sub B::FAKEOP::type { $_[0]->{type} || 0}
151 sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
152 sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
153 sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
154 sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
155 sub B::FAKEOP::private { $_[0]->{private} || 0 }
158 my ($op, $level) = @_;
160 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x",
161 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
162 $op->type, $op_seq, $op->flags,$op->private,ad($op->first)));
163 savesym($op, "(OP*)&unop_list[$#unop_list]");
167 my ($op, $level) = @_;
169 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x",
170 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
171 $op->type, $op_seq, $op->flags, $op->private,
172 ad($op->first), ad($op->last)));
173 savesym($op, "(OP*)&binop_list[$#binop_list]");
176 sub B::LISTOP::save {
177 my ($op, $level) = @_;
178 push(@listop_list, sprintf(
179 "sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x, %u",
180 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
181 $op->type, $op_seq, $op->flags, $op->private, ad($op->first),
182 ad($op->last), $op->children));
183 savesym($op, "(OP*)&listop_list[$#listop_list]");
187 my ($op, $level) = @_;
189 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x",
190 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
191 $op->type, $op_seq, $op->flags, $op->private,
192 ad($op->first), ad($op->other)));
193 savesym($op, "(OP*)&logop_list[$#logop_list]");
196 sub B::CONDOP::save {
197 my ($op, $level) = @_;
198 push(@condop_list, sprintf(
199 "sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x, sym_%x",
200 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
201 $op->type, $op_seq, $op->flags, $op->private, ad($op->first),
202 ad($op->true), ad($op->false)));
203 savesym($op, "(OP*)&condop_list[$#condop_list]");
207 my ($op, $level) = @_;
208 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
209 # peekop($op->redoop), peekop($op->nextop),
210 # peekop($op->lastop)); # debug
211 push(@loop_list, sprintf(
212 "sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, "
213 ."sym_%x, sym_%x, %u, sym_%x, sym_%x, sym_%x",
214 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ, $op->type,
215 $op_seq, $op->flags, $op->private, ad($op->first), ad($op->last),
216 $op->children, ad($op->redoop), ad($op->nextop), ad($op->lastop)));
217 savesym($op, "(OP*)&loop_list[$#loop_list]");
221 my ($op, $level) = @_;
223 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
224 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
225 $op->type, $op_seq, $op->flags, $op->private,
227 savesym($op, "(OP*)&pvop_list[$#pvop_list]");
231 my ($op, $level) = @_;
233 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, (SV*)sym_%x",
234 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
235 $op->type, $op_seq, $op->flags, $op->private, ad($op->sv)));
236 savesym($op, "(OP*)&svop_list[$#svop_list]");
237 # warn sprintf("svop saving sv %s 0x%x\n", ref($op->sv), ad($op->sv));#debug
242 my ($op, $level) = @_;
243 my $gvsym = $op->gv->save;
245 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, Nullgv",
246 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
247 $op->type, $op_seq, $op->flags, $op->private));
248 push_init(sprintf("gvop_list[$#gvop_list].op_gv = %s;", $gvsym));
249 savesym($op, "(OP*)&gvop_list[$#gvop_list]");
253 my ($op, $level) = @_;
254 my $gvsym = $op->filegv->save;
255 my $stashsym = $op->stash->save;
256 warn sprintf("COP: line %d file %s\n", $op->line, $op->filegv->SV->PV)
259 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, "
260 ."Nullhv, Nullgv, %u, %d, %u",
261 ad($op->next), ad($op->sibling), $op->ppaddr, $op->targ,
262 $op->type, $op_seq, $op->flags, $op->private,
263 cstring($op->label), $op->cop_seq, $op->arybase, $op->line));
264 push_init(sprintf("cop_list[$#cop_list].cop_filegv = %s;", $gvsym),
265 sprintf("cop_list[$#cop_list].cop_stash = %s;", $stashsym));
266 savesym($op, "(OP*)&cop_list[$#cop_list]");
270 my ($op, $level) = @_;
271 my $shortsym = $op->pmshort->save;
272 my $replroot = $op->pmreplroot;
273 my $replstart = $op->pmreplstart;
274 my $replrootfield = sprintf("sym_%x", ad($replroot));
275 my $replstartfield = sprintf("sym_%x", ad($replstart));
277 my $ppaddr = $op->ppaddr;
279 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
280 # argument to a split) stores a GV in op_pmreplroot instead
281 # of a substitution syntax tree. We don't want to walk that...
282 if ($ppaddr eq "pp_pushre") {
283 $gvsym = $replroot->save;
284 # warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
287 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
290 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
291 # fields aren't noticed in perl's runtime (unless you try reset) but we
292 # segfault when trying to dereference it to find op->op_pmnext->op_type
294 sprintf("sym_%x, sym_%x, %s, %u, %u, %u, 0x%x, 0x%x, sym_%x, sym_%x,"
295 ." %u, %s, %s, 0, 0, %s, 0x%x, 0x%x, %u",
296 ad($op->next), ad($op->sibling), $ppaddr, $op->targ,
297 $op->type, $op_seq, $op->flags, $op->private,
298 ad($op->first), ad($op->last), $op->children,
299 $replrootfield, $replstartfield,
300 $shortsym, $op->pmflags, $op->pmpermflags, $op->pmslen));
301 my $pm = "pmop_list[$#pmop_list]";
302 my $re = $op->precomp;
304 my $resym = sprintf("re%d", $re_index++);
305 push(@decl_list, sprintf("static char *$resym = %s;", cstring($re)));
307 "$pm.op_pmregexp = pregcomp($resym, $resym + %u, &$pm);",
311 push_init("$pm.op_pmreplroot = (OP*)$gvsym;");
313 savesym($op, "(OP*)&pmop_list[$#pmop_list]");
316 sub B::SPECIAL::save {
318 # special case: $$sv is not the address but an index into specialsv_list
319 # warn "SPECIAL::save specialsv $$sv\n"; # debug
320 my $sym = $specialsv_name[$$sv];
321 if (!defined($sym)) {
322 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
327 sub B::OBJECT::save {}
331 my $sym = objsym($sv);
332 return $sym if defined $sym;
333 # warn "Saving SVt_NULL SV\n"; # debug
336 # warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
338 push(@sv_list, sprintf("0, %u, 0x%x", $sv->REFCNT + 1, $sv->FLAGS));
339 return savesym($sv, "&sv_list[$#sv_list]");
344 my $sym = objsym($sv);
345 return $sym if defined $sym;
346 push(@xpviv_list, sprintf("0, 0, 0, %d", $sv->IVX));
347 push(@sv_list, sprintf("&xpviv_list[$#xpviv_list], %lu, 0x%x",
348 $sv->REFCNT + 1, $sv->FLAGS));
349 return savesym($sv, "&sv_list[$#sv_list]");
354 my $sym = objsym($sv);
355 return $sym if defined $sym;
356 push(@xpvnv_list, sprintf("0, 0, 0, %d, %s", $sv->IVX, $sv->NVX));
357 push(@sv_list, sprintf("&xpvnv_list[$#xpvnv_list], %lu, 0x%x",
358 $sv->REFCNT + 1, $sv->FLAGS));
359 return savesym($sv, "&sv_list[$#sv_list]");
364 my $sym = objsym($sv);
365 return $sym if defined $sym;
367 my $len = length($pv);
368 my ($pvsym, $pvmax) = savepv($pv);
369 my ($lvtarg, $lvtarg_sym);
370 push(@xpvlv_list, sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
371 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
372 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
374 push(@sv_list, sprintf("&xpvlv_list[$#xpvlv_list], %lu, 0x%x",
375 $sv->REFCNT + 1, $sv->FLAGS));
376 if (!$pv_copy_on_grow) {
377 push_init(sprintf("xpvlv_list[$#xpvlv_list].xpv_pv = savepvn(%s, %u);",
378 cstring($pv), $len));
381 return savesym($sv, "&sv_list[$#sv_list]");
386 my $sym = objsym($sv);
387 return $sym if defined $sym;
389 my $len = length($pv);
390 my ($pvsym, $pvmax) = savepv($pv);
391 push(@xpviv_list, sprintf("%s, %u, %u, %d", $pvsym, $len,$pvmax,$sv->IVX));
392 push(@sv_list, sprintf("&xpviv_list[$#xpviv_list], %u, 0x%x",
393 $sv->REFCNT + 1, $sv->FLAGS));
394 if (!$pv_copy_on_grow) {
395 push_init(sprintf("xpviv_list[$#xpviv_list].xpv_pv = savepvn(%s, %u);",
396 cstring($pv), $len));
398 return savesym($sv, "&sv_list[$#sv_list]");
403 my $sym = objsym($sv);
404 return $sym if defined $sym;
406 my $len = length($pv);
407 my ($pvsym, $pvmax) = savepv($pv);
408 push(@xpvnv_list, sprintf("%s, %u, %u, %d, %s",
409 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
410 push(@sv_list, sprintf("&xpvnv_list[$#xpvnv_list], %lu, 0x%x",
411 $sv->REFCNT + 1, $sv->FLAGS));
412 if (!$pv_copy_on_grow) {
413 push_init(sprintf("xpvnv_list[$#xpvnv_list].xpv_pv = savepvn(%s, %u);",
414 cstring($pv), $len));
416 return savesym($sv, "&sv_list[$#sv_list]");
421 my $sym = objsym($sv);
422 return $sym if defined $sym;
423 my $pv = $sv->PV . "\0" . $sv->TABLE;
424 my $len = length($pv);
425 push(@xpvbm_list, sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
426 $len, $len + 258, $sv->IVX, $sv->NVX,
427 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
428 push(@sv_list, sprintf("&xpvbm_list[$#xpvbm_list], %lu, 0x%x",
429 $sv->REFCNT + 1, $sv->FLAGS));
431 push_init(sprintf("xpvbm_list[$#xpvbm_list].xpv_pv = savepvn(%s, %u);",
433 sprintf("xpvbm_list[$#xpvbm_list].xpv_cur = %u;", $len - 257));
434 # "sv_magic(&sv_list[$#sv_list], Nullsv, 'B', Nullch, 0);");
435 return savesym($sv, "&sv_list[$#sv_list]");
440 my $sym = objsym($sv);
441 return $sym if defined $sym;
443 my $len = length($pv);
444 my ($pvsym, $pvmax) = savepv($pv);
445 push(@xpv_list, sprintf("%s, %u, %u", $pvsym, $len, $pvmax));
446 push(@sv_list, sprintf("&xpv_list[$#xpv_list], %lu, 0x%x",
447 $sv->REFCNT + 1, $sv->FLAGS));
448 if (!$pv_copy_on_grow) {
449 push_init(sprintf("xpv_list[$#xpv_list].xpv_pv = savepvn(%s, %u);",
450 cstring($pv), $len));
452 return savesym($sv, "&sv_list[$#sv_list]");
457 my $sym = objsym($sv);
458 return $sym if defined $sym;
460 my $len = length($pv);
461 my ($pvsym, $pvmax) = savepv($pv);
462 push(@xpvmg_list, sprintf("%s, %u, %u, %d, %s, 0, 0",
463 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX));
464 push(@sv_list, sprintf("&xpvmg_list[$#xpvmg_list], %lu, 0x%x",
465 $sv->REFCNT + 1, $sv->FLAGS));
466 if (!$pv_copy_on_grow) {
467 push_init(sprintf("xpvmg_list[$#xpvmg_list].xpv_pv = savepvn(%s, %u);",
468 cstring($pv), $len));
470 $sym = savesym($sv, "&sv_list[$#sv_list]");
475 sub B::PVMG::save_magic {
477 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), ad($sv)); # debug
478 my $stash = $sv->SvSTASH;
480 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, ad($stash))
482 # XXX Hope stash is already going to be saved.
483 push_init(sprintf("SvSTASH(sym_%x) = sym_%x;", ad($sv), ad($stash)));
485 my @mgchain = $sv->MAGIC;
486 my ($mg, $type, $obj, $ptr);
487 foreach $mg (@mgchain) {
491 my $len = defined($ptr) ? length($ptr) : 0;
493 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
494 class($sv), ad($sv), class($obj), ad($obj),
495 cchar($type), cstring($ptr));
497 push_init(sprintf("sv_magic((SV*)sym_%x, (SV*)sym_%x, %s, %s, %d);",
498 ad($sv), ad($obj), cchar($type),cstring($ptr),$len));
504 my $sym = objsym($sv);
505 return $sym if defined $sym;
506 push(@xrv_list, $sv->RV->save);
507 push(@sv_list, sprintf("&xrv_list[$#xrv_list], %lu, 0x%x",
508 $sv->REFCNT + 1, $sv->FLAGS));
509 return savesym($sv, "&sv_list[$#sv_list]");
514 my $sym = objsym($cv);
516 # warn sprintf("CV 0x%x already saved as $sym\n", ad($cv)); # debug
519 # Reserve a place on sv_list and xpvcv_list and record indices
520 push(@sv_list, undef);
521 my $sv_ix = $#sv_list;
522 push(@xpvcv_list, undef);
523 my $xpvcv_ix = $#xpvcv_list;
524 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
525 $sym = savesym($cv, "&sv_list[$sv_ix]");
526 warn sprintf("saving CV 0x%x as $sym\n", ad($cv)) if $debug_cv;
528 my $root = $cv->ROOT;
530 my $padlist = $cv->PADLIST;
532 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
533 ad($cv), ad($root)) if $debug_cv;
536 my $stashname = $gv->STASH->NAME;
537 my $gvname = $gv->NAME;
539 $ppname .= $stashname eq "main" ? $gvname : "$stashname\::$gvname";
540 $ppname =~ s/::/__/g;
542 $ppname = "pp_anonsub_$anonsub_index";
545 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
546 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
547 ad($cv), $ppname, ad($root)) if $debug_cv;
550 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
551 ad($padlist), ad($cv)) if $debug_cv;
553 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
554 ad($padlist), ad($cv)) if $debug_cv;
558 my $xsubany = "Nullany";
560 $xsubany = sprintf("ANYINIT((void*)0x%x)", $cv->XSUBANY);
561 # Find out canonical name of XSUB function from EGV (I hope)
563 my $stashname = $egv->STASH->NAME;
564 $stashname =~ s/::/__/g;
565 $xsub = sprintf("XS_%s_%s", $stashname, $egv->NAME);
566 push(@decl_list, "void $xsub _((CV*));");
568 $xpvcv_list[$xpvcv_ix] = sprintf(
569 "%s, %u, 0, %d, %s, 0, Nullhv, Nullhv, %s, sym_%lx, $xsub, $xsubany,".
570 " Nullgv, Nullgv, %d, sym_%lx, (CV*)sym_%lx, 0",
571 cstring($pv), length($pv), $cv->IVX, $cv->NVX, $startfield,
572 ad($cv->ROOT), $cv->DEPTH, ad($padlist), ad($cv->OUTSIDE));
575 push_init(sprintf("CvGV(sym_%lx) = sym_%lx;",ad($cv),ad($gv)));
576 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
577 ad($gv), ad($cv)) if $debug_cv;
579 my $filegv = $cv->FILEGV;
582 push_init(sprintf("CvFILEGV(sym_%lx) = sym_%lx;",ad($cv),ad($filegv)));
583 warn sprintf("done saving FILEGV 0x%x for CV 0x%x\n",
584 ad($filegv), ad($cv)) if $debug_cv;
586 my $stash = $cv->STASH;
589 push_init(sprintf("CvSTASH(sym_%lx) = sym_%lx;", ad($cv), ad($stash)));
590 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
591 ad($stash), ad($cv)) if $debug_cv;
593 $sv_list[$sv_ix] = sprintf("(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
594 $xpvcv_ix, $cv->REFCNT + 1, $cv->FLAGS);
600 my $sym = objsym($gv);
602 #warn sprintf("GV 0x%x already saved as $sym\n", ad($gv)); # debug
605 my $ix = $gv_index++;
606 $sym = savesym($gv, "gv_list[$ix]");
607 #warn sprintf("Saving GV 0x%x as $sym\n", ad($gv)); # debug
609 my $gvname = $gv->NAME;
610 my $name = cstring($gv->STASH->NAME . "::" . $gvname);
611 #warn "GV name is $name\n"; # debug
614 if (ad($gv) != ad($egv)) {
615 #warn(sprintf("EGV name is %s, saving it now\n",
616 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
617 $egvsym = $egv->save;
619 push_init(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
620 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS),
621 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS),
622 sprintf("GvLINE($sym) = %u;", $gv->LINE));
623 # Shouldn't need to do save_magic since gv_fetchpv handles that
625 my $refcnt = $gv->REFCNT + 1;
626 push_init(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1)) if $refcnt > 1;
627 my $gvrefcnt = $gv->GvREFCNT;
629 push_init(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
631 if (defined($egvsym)) {
632 # Shared glob *foo = *bar
633 push_init("gp_free($sym);",
634 "GvGP($sym) = GvGP($egvsym);");
635 } elsif ($gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/) {
636 # Don't save subfields of special GVs (*_, *1, *# and so on)
637 # warn "GV::save saving subfields\n"; # debug
640 push_init(sprintf("GvSV($sym) = sym_%x;", ad($gvsv)));
641 # warn "GV::save \$$name\n"; # debug
646 push_init(sprintf("GvAV($sym) = sym_%x;", ad($gvav)));
647 # warn "GV::save \@$name\n"; # debug
652 push_init(sprintf("GvHV($sym) = sym_%x;", ad($gvhv)));
653 # warn "GV::save \%$name\n"; # debug
658 push_init(sprintf("GvCV($sym) = (CV*)sym_%x;", ad($gvcv)));
659 # warn "GV::save &$name\n"; # debug
662 my $gvfilegv = $gv->FILEGV;
664 push_init(sprintf("GvFILEGV($sym) = sym_%x;",ad($gvfilegv)));
665 # warn "GV::save GvFILEGV(*$name)\n"; # debug
668 my $gvform = $gv->FORM;
670 push_init(sprintf("GvFORM($sym) = (CV*)sym_%x;", ad($gvform)));
671 # warn "GV::save GvFORM(*$name)\n"; # debug
676 push_init(sprintf("GvIOp($sym) = sym_%x;", ad($gvio)));
677 # warn "GV::save GvIO(*$name)\n"; # debug
685 my $sym = objsym($av);
686 return $sym if defined $sym;
687 my $avflags = $av->AvFLAGS;
689 sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", $avflags));
690 push(@sv_list, sprintf("&xpvav_list[$#xpvav_list], %lu, 0x%x",
691 $av->REFCNT + 1, $av->FLAGS));
692 my $sv_list_index = $#sv_list;
693 my $fill = $av->FILL;
695 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", ad($av), $avflags)
697 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
698 #if ($fill > -1 && ($avflags & AVf_REAL)) {
700 my @array = $av->ARRAY;
704 foreach $el (@array) {
705 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
706 ad($av), $i++, class($el), ad($el));
709 my @names = map($_->save, @array);
710 # XXX Better ways to write loop?
711 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
712 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
715 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
716 "\tav_extend(av, $fill);",
717 "\tsvp = AvARRAY(av);",
718 map("\t*svp++ = (SV*)$_;", @names),
719 "\tAvFILL(av) = $fill;",
723 push_init("av_extend((AV*)&sv_list[$sv_list_index], $max);")
726 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
731 my $sym = objsym($hv);
732 return $sym if defined $sym;
733 my $name = $hv->NAME;
737 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
738 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
739 # a trashed op but we look at the trashed op_type and segfault.
740 #my $adpmroot = ad($hv->PMROOT);
742 push(@decl_list, "static HV *hv$hv_index;");
743 # XXX Beware of weird package names containing double-quotes, \n, ...?
744 push_init(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
746 push_init(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)sym_%x;",
749 $sym = savesym($hv, "hv$hv_index");
753 # It's just an ordinary HV
755 sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
756 $hv->MAX, $hv->RITER));
757 push(@sv_list, sprintf("&xpvhv_list[$#xpvhv_list], %lu, 0x%x",
758 $hv->REFCNT + 1, $hv->FLAGS));
759 my $sv_list_index = $#sv_list;
760 my @contents = $hv->ARRAY;
763 for ($i = 1; $i < @contents; $i += 2) {
764 $contents[$i] = $contents[$i]->save;
766 push_init("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
768 my ($key, $value) = splice(@contents, 0, 2);
769 push_init(sprintf("\thv_store(hv, %s, %u, %s, %s);",
770 cstring($key),length($key), $value, hash($key)));
774 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
779 my $sym = objsym($io);
780 return $sym if defined $sym;
782 my $len = length($pv);
784 sprintf("0, %u, %u, %d, %s, 0, 0, 0, 0, 0, %d, %d, %d, %d, %s, "
785 ."Nullgv, %s, Nullgv, %s, Nullgv, %d, %s, 0x%x",
786 $len, $len+1, $io->IVX, $io->NVX,
787 $io->LINES, $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
788 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
789 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
790 cchar($io->IoTYPE), $io->IoFLAGS));
791 push(@sv_list, sprintf("&xpvio_list[$#xpvio_list], %lu, 0x%x",
792 $io->REFCNT + 1, $io->FLAGS));
793 $sym = savesym($io, "(IO*)&sv_list[$#sv_list]");
795 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
796 $fsym = $io->$field();
798 push_init(sprintf("Io$field($sym) = (GV*)sym_%x;", ad($fsym)));
808 # This is where we catch an honest-to-goodness Nullsv (which gets
809 # blessed into B::SV explicitly) and any stray erroneous SVs.
810 return 0 unless ad($sv);
811 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
812 class($sv), ad($sv));
816 my $init_name = shift;
818 output_declarations();
819 print "$_\n" while $_ = shift @decl_list;
821 output_list("op", \@op_list) if @op_list;
822 output_list("unop", \@unop_list) if @unop_list;
823 output_list("binop", \@binop_list) if @binop_list;
824 output_list("logop", \@logop_list) if @logop_list;
825 output_list("condop", \@condop_list) if @condop_list;
826 output_list("listop", \@listop_list) if @listop_list;
827 output_list("pmop", \@pmop_list) if @pmop_list;
828 output_list("svop", \@svop_list) if @svop_list;
829 output_list("gvop", \@gvop_list) if @gvop_list;
830 output_list("pvop", \@pvop_list) if @pvop_list;
831 output_list("cvop", \@cvop_list) if @cvop_list;
832 output_list("loop", \@loop_list) if @loop_list;
833 output_list("cop", \@cop_list) if @cop_list;
835 output_list("sv", \@sv_list) if @sv_list;
836 output_list("xrv", \@xrv_list) if @xrv_list;
837 output_list("xpv", \@xpv_list) if @xpv_list;
838 output_list("xpviv", \@xpviv_list) if @xpviv_list;
839 output_list("xpvnv", \@xpvnv_list) if @xpvnv_list;
840 output_list("xpvmg", \@xpvmg_list) if @xpvmg_list;
841 output_list("xpvlv", \@xpvlv_list) if @xpvlv_list;
842 output_list("xpvbm", \@xpvbm_list) if @xpvbm_list;
843 output_list("xpvav", \@xpvav_list) if @xpvav_list;
844 output_list("xpvhv", \@xpvhv_list) if @xpvhv_list;
845 output_list("xpvio", \@xpvio_list) if @xpvio_list;
846 output_list("xpvcv", \@xpvcv_list) if @xpvcv_list;
848 output_init($init_name);
850 warn compile_stats();
851 warn "NULLOP count: $nullop_count\n";
857 print "static int $name()\n{\n";
858 seek($init_list_fh, 0, 0);
859 while (<$init_list_fh>) {
863 print "\treturn 0;\n}\n";
867 my ($name, $listref) = @_;
868 # Support pre-Standard C compilers which can't cope with static
869 # initialisation of union members. Sheesh.
870 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
871 printf "static %s %s_list[%u] = {\n", $typename, $name, scalar(@$listref);
872 while ($_ = shift @$listref) {
879 sub output_declarations {
881 #ifdef BROKEN_STATIC_REDECL
882 #define Static extern
884 #define Static static
885 #endif /* BROKEN_STATIC_REDECL */
887 #ifdef BROKEN_UNION_INIT
889 * Cribbed from cv.h with ANY (a union) replaced by void*.
890 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
893 char * xpv_pv; /* pointer to malloced string */
894 STRLEN xpv_cur; /* length of xp_pv as a C string */
895 STRLEN xpv_len; /* allocated size */
896 IV xof_off; /* integer value */
897 double xnv_nv; /* numeric value, if any */
898 MAGIC* xmg_magic; /* magic for scalar array */
899 HV* xmg_stash; /* class package */
904 void (*xcv_xsub) _((CV*));
908 long xcv_depth; /* >= 2 indicates recursive call */
915 #define XPVCV_or_similar XPVCV
916 #define ANYINIT(i) {i}
917 #endif /* BROKEN_UNION_INIT */
918 #define Nullany ANYINIT(0)
923 printf("Static OP op_list[%d];\n", scalar(@op_list)) if @op_list;
924 printf("Static UNOP unop_list[%d];\n", scalar(@unop_list)) if @unop_list;
925 printf("Static BINOP binop_list[%d];\n", scalar(@binop_list))
927 printf("Static LOGOP logop_list[%d];\n", scalar(@logop_list))
929 printf("Static CONDOP condop_list[%d];\n", scalar(@condop_list))
931 printf("Static LISTOP listop_list[%d];\n", scalar(@listop_list))
933 printf("Static PMOP pmop_list[%d];\n", scalar(@pmop_list)) if @pmop_list;
934 printf("Static SVOP svop_list[%d];\n", scalar(@svop_list)) if @svop_list;
935 printf("Static GVOP gvop_list[%d];\n", scalar(@gvop_list)) if @gvop_list;
936 printf("Static PVOP pvop_list[%d];\n", scalar(@pvop_list)) if @pvop_list;
937 printf("Static CVOP cvop_list[%d];\n", scalar(@cvop_list)) if @cvop_list;
938 printf("Static LOOP loop_list[%d];\n", scalar(@loop_list)) if @loop_list;
939 printf("Static COP cop_list[%d];\n", scalar(@cop_list)) if @cop_list;
941 printf("Static SV sv_list[%d];\n", scalar(@sv_list)) if @sv_list;
942 printf("Static XPV xpv_list[%d];\n", scalar(@xpv_list)) if @xpv_list;
943 printf("Static XRV xrv_list[%d];\n", scalar(@xrv_list)) if @xrv_list;
944 printf("Static XPVIV xpviv_list[%d];\n", scalar(@xpviv_list))
946 printf("Static XPVNV xpvnv_list[%d];\n", scalar(@xpvnv_list))
948 printf("Static XPVMG xpvmg_list[%d];\n", scalar(@xpvmg_list))
950 printf("Static XPVLV xpvlv_list[%d];\n", scalar(@xpvlv_list))
952 printf("Static XPVBM xpvbm_list[%d];\n", scalar(@xpvbm_list))
954 printf("Static XPVAV xpvav_list[%d];\n", scalar(@xpvav_list))
956 printf("Static XPVHV xpvhv_list[%d];\n", scalar(@xpvhv_list))
958 printf("Static XPVCV_or_similar xpvcv_list[%d];\n", scalar(@xpvcv_list))
960 printf("Static XPVIO xpvio_list[%d];\n", scalar(@xpvio_list))
962 print "static GV *gv_list[$gv_index];\n" if $gv_index;
967 sub output_boilerplate {
978 # define EXTERN_C extern "C"
980 # define EXTERN_C extern
983 /* Workaround for mapstart: the only op which needs a different ppaddr */
985 #define pp_mapstart pp_grepstart
987 static void xs_init _((void));
988 static PerlInterpreter *my_perl;
995 #ifndef CAN_PROTOTYPE
996 main(argc, argv, env)
1000 #else /* def(CAN_PROTOTYPE) */
1001 main(int argc, char **argv, char **env)
1002 #endif /* def(CAN_PROTOTYPE) */
1008 PERL_SYS_INIT(&argc,&argv);
1010 #if PATCHLEVEL > 3 || (PATCHLEVEL == 3 && SUBVERSION >= 1)
1011 perl_init_i18nl10n(1);
1013 perl_init_i18nl14n(1);
1017 my_perl = perl_alloc();
1020 perl_construct( my_perl );
1024 cshlen = strlen(cshname);
1026 #ifdef ALLOW_PERL_OPTIONS
1027 #define EXTRA_OPTIONS 2
1029 #define EXTRA_OPTIONS 3
1030 #endif /* ALLOW_PERL_OPTIONS */
1031 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1032 fakeargv[0] = argv[0];
1035 #ifndef ALLOW_PERL_OPTIONS
1037 #endif /* ALLOW_PERL_OPTIONS */
1038 for (i = 1; i < argc; i++)
1039 fakeargv[i + EXTRA_OPTIONS] = argv[i];
1040 fakeargv[argc + EXTRA_OPTIONS] = 0;
1042 exitstatus = perl_parse(my_perl, xs_init, argc + EXTRA_OPTIONS,
1047 sv_setpv(GvSV(gv_fetchpv("0", TRUE, SVt_PV)), argv[0]);
1051 exitstatus = perl_init();
1055 exitstatus = perl_run( my_perl );
1057 perl_destruct( my_perl );
1058 perl_free( my_perl );
1073 warn "----Symbol table:\n";
1074 while (($sym, $val) = each %symtable) {
1075 warn "$sym => $val\n";
1077 warn "---End of symbol table\n";
1083 svref_2object($sv)->save;
1090 my $name = $gv->NAME;
1091 if (ad($cv) && !objsym($cv) && !($name eq "bootstrap" && $cv->XSUB)) {
1093 warn sprintf("saving extra CV &%s::%s (0x%x) from GV 0x%x\n",
1094 $gv->STASH->NAME, $name, ad($cv), ad($gv));
1100 sub save_unused_subs {
1102 map { $search_pack{"$_\::"} = 1 } @_;
1103 no strict qw(vars refs);
1104 walksymtable(\%{"main::"}, "savecv", sub { exists($search_pack{$_[0]}) });
1108 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1109 walkoptree(main_root, "save");
1110 if (@unused_sub_packages) {
1111 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1112 save_unused_subs(@unused_sub_packages);
1114 push_init(sprintf("main_root = sym_%x;", ad(main_root)),
1115 sprintf("main_start = sym_%x;", ad(main_start)),
1116 "curpad = AvARRAY($curpad_sym);");
1117 output_boilerplate();
1119 output_all("perl_init");
1126 my ($option, $opt, $arg);
1128 while ($option = shift @options) {
1129 if ($option =~ /^-(.)(.*)/) {
1133 unshift @options, $option;
1136 if ($opt eq "-" && $arg eq "-") {
1141 $warn_undefined_syms = 1;
1142 } elsif ($opt eq "D") {
1143 $arg ||= shift @options;
1144 foreach $arg (split(//, $arg)) {
1147 } elsif ($arg eq "c") {
1149 } elsif ($arg eq "A") {
1151 } elsif ($arg eq "C") {
1153 } elsif ($arg eq "M") {
1156 warn "ignoring unknown debug option: $arg\n";
1159 } elsif ($opt eq "o") {
1160 $arg ||= shift @options;
1161 open(STDOUT, ">$arg") or return "$arg: $!\n";
1162 } elsif ($opt eq "v") {
1164 } elsif ($opt eq "u") {
1165 $arg ||= shift @options;
1166 push(@unused_sub_packages, $arg);
1167 } elsif ($opt eq "f") {
1168 $arg ||= shift @options;
1169 if ($arg eq "cog") {
1170 $pv_copy_on_grow = 1;
1171 } elsif ($arg eq "no-cog") {
1172 $pv_copy_on_grow = 0;
1174 } elsif ($opt eq "O") {
1175 $arg = 1 if $arg eq "";
1176 $pv_copy_on_grow = 0;
1178 # Optimisations for -O1
1179 $pv_copy_on_grow = 1;
1187 foreach $objname (@options) {
1188 eval "save_object(\\$objname)";
1193 return sub { save_main() };