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