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