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