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