projects / OpenSPARC-T2-DV / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Initial commit of OpenSPARC T2 design and verification files.
[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / 5.8.0 / sun4-solaris / B / C.pm
CommitLineData
86530b38
AT		 1# C.pm
2#
3# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
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#
8package B::C::Section;
9
10our $VERSION = '1.01';
11
12use B ();
13use base B::Section;
14
15sub new
16{
17 my $class = shift;
18 my $o = $class->SUPER::new(@_);
19 push @$o, { values => [] };
20 return $o;
21}
22
23sub add
24{
25 my $section = shift;
26 push(@{$section->[-1]{values}},@_);
27}
28
29sub index
30{
31 my $section = shift;
32 return scalar(@{$section->[-1]{values}})-1;
33}
34
35sub output
36{
37 my ($section, $fh, $format) = @_;
38 my $sym = $section->symtable || {};
39 my $default = $section->default;
40 my $i;
41 foreach (@{$section->[-1]{values}})
42 {
43 s{(s\\_[0-9a-f]+)}{ exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
44 printf $fh $format, $_, $i;
45 ++$i;
46 }
47}
48
49package B::C::InitSection;
50
51# avoid use vars
52@B::C::InitSection::ISA = qw(B::C::Section);
53
54sub new {
55 my $class = shift;
56 my $max_lines = 10000; #pop;
57 my $section = $class->SUPER::new( @_ );
58
59 $section->[-1]{evals} = [];
60 $section->[-1]{chunks} = [];
61 $section->[-1]{nosplit} = 0;
62 $section->[-1]{current} = [];
63 $section->[-1]{count} = 0;
64 $section->[-1]{max_lines} = $max_lines;
65
66 return $section;
67}
68
69sub split {
70 my $section = shift;
71 $section->[-1]{nosplit}--
72 if $section->[-1]{nosplit} > 0;
73}
74
75sub no_split {
76 shift->[-1]{nosplit}++;
77}
78
79sub inc_count {
80 my $section = shift;
81
82 $section->[-1]{count} += $_[0];
83 # this is cheating
84 $section->add();
85}
86
87sub add {
88 my $section = shift->[-1];
89 my $current = $section->{current};
90 my $nosplit = $section->{nosplit};
91
92 push @$current, @_;
93 $section->{count} += scalar(@_);
94 if( !$nosplit && $section->{count} >= $section->{max_lines} ) {
95 push @{$section->{chunks}}, $current;
96 $section->{current} = [];
97 $section->{count} = 0;
98 }
99}
100
101sub add_eval {
102 my $section = shift;
103 my @strings = @_;
104
105 foreach my $i ( @strings ) {
106 $i =~ s/\"/\\\"/g;
107 }
108 push @{$section->[-1]{evals}}, @strings;
109}
110
111sub output {
112 my( $section, $fh, $format, $init_name ) = @_;
113 my $sym = $section->symtable || {};
114 my $default = $section->default;
115 push @{$section->[-1]{chunks}}, $section->[-1]{current};
116
117 my $name = "aaaa";
118 foreach my $i ( @{$section->[-1]{chunks}} ) {
119 print $fh <<"EOT";
120static int perl_init_${name}()
121{
122 dTARG;
123 dSP;
124EOT
125 foreach my $j ( @$i ) {
126 $j =~ s{(s\\_[0-9a-f]+)}
127 { exists($sym->{$1}) ? $sym->{$1} : $default; }ge;
128 print $fh "\t$j\n";
129 }
130 print $fh "\treturn 0;\n}\n";
131
132 $section->SUPER::add( "perl_init_${name}();" );
133 ++$name;
134 }
135 foreach my $i ( @{$section->[-1]{evals}} ) {
136 $section->SUPER::add( sprintf q{eval_pv("%s",1);}, $i );
137 }
138
139 print $fh <<"EOT";
140static int ${init_name}()
141{
142 dTARG;
143 dSP;
144EOT
145 $section->SUPER::output( $fh, $format );
146 print $fh "\treturn 0;\n}\n";
147}
148
149
150package B::C;
151use Exporter ();
152our %REGEXP;
153
154{ # block necessary for caller to work
155 my $caller = caller;
156 if( $caller eq 'O' ) {
157 require XSLoader;
158 XSLoader::load( 'B::C' );
159 }
160}
161
162@ISA = qw(Exporter);
163@EXPORT_OK = qw(output_all output_boilerplate output_main mark_unused
164 init_sections set_callback save_unused_subs objsym save_context);
165
166use B qw(minus_c sv_undef walkoptree walksymtable main_root main_start peekop
167 class cstring cchar svref_2object compile_stats comppadlist hash
168 threadsv_names main_cv init_av end_av regex_padav opnumber amagic_generation
169 AVf_REAL HEf_SVKEY SVf_POK SVf_ROK CVf_CONST);
170use B::Asmdata qw(@specialsv_name);
171
172use FileHandle;
173use Carp;
174use strict;
175use Config;
176
177my $hv_index = 0;
178my $gv_index = 0;
179my $re_index = 0;
180my $pv_index = 0;
181my $cv_index = 0;
182my $anonsub_index = 0;
183my $initsub_index = 0;
184
185my %symtable;
186my %xsub;
187my $warn_undefined_syms;
188my $verbose;
189my %unused_sub_packages;
190my $use_xsloader;
191my $nullop_count;
192my $pv_copy_on_grow = 0;
193my $optimize_ppaddr = 0;
194my $optimize_warn_sv = 0;
195my $use_perl_script_name = 0;
196my $save_data_fh = 0;
197my $save_sig = 0;
198my ($debug_cops, $debug_av, $debug_cv, $debug_mg);
199my $max_string_len;
200
201my $ithreads = $Config{useithreads} eq 'define';
202
203my @threadsv_names;
204BEGIN {
205 @threadsv_names = threadsv_names();
206}
207
208# Code sections
209my ($init, $decl, $symsect, $binopsect, $condopsect, $copsect,
210 $padopsect, $listopsect, $logopsect, $loopsect, $opsect, $pmopsect,
211 $pvopsect, $svopsect, $unopsect, $svsect, $xpvsect, $xpvavsect,
212 $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, $xpvmgsect, $xpvlvsect,
213 $xrvsect, $xpvbmsect, $xpviosect );
214my @op_sections = \( $binopsect, $condopsect, $copsect, $padopsect, $listopsect,
215 $logopsect, $loopsect, $opsect, $pmopsect, $pvopsect, $svopsect,
216 $unopsect );
217
218sub walk_and_save_optree;
219my $saveoptree_callback = \&walk_and_save_optree;
220sub set_callback { $saveoptree_callback = shift }
221sub saveoptree { &$saveoptree_callback(@_) }
222
223sub walk_and_save_optree {
224 my ($name, $root, $start) = @_;
225 walkoptree($root, "save");
226 return objsym($start);
227}
228
229# Current workaround/fix for op_free() trying to free statically
230# defined OPs is to set op_seq = -1 and check for that in op_free().
231# Instead of hardwiring -1 in place of $op->seq, we use $op_seq
232# so that it can be changed back easily if necessary. In fact, to
233# stop compilers from moaning about a U16 being initialised with an
234# uncast -1 (the printf format is %d so we can't tweak it), we have
235# to "know" that op_seq is a U16 and use 65535. Ugh.
236my $op_seq = 65535;
237
238# Look this up here so we can do just a number compare
239# rather than looking up the name of every BASEOP in B::OP
240my $OP_THREADSV = opnumber('threadsv');
241
242sub savesym {
243 my ($obj, $value) = @_;
244 my $sym = sprintf("s\\_%x", $$obj);
245 $symtable{$sym} = $value;
246}
247
248sub objsym {
249 my $obj = shift;
250 return $symtable{sprintf("s\\_%x", $$obj)};
251}
252
253sub getsym {
254 my $sym = shift;
255 my $value;
256
257 return 0 if $sym eq "sym_0"; # special case
258 $value = $symtable{$sym};
259 if (defined($value)) {
260 return $value;
261 } else {
262 warn "warning: undefined symbol $sym\n" if $warn_undefined_syms;
263 return "UNUSED";
264 }
265}
266
267sub savere {
268 my $re = shift;
269 my $sym = sprintf("re%d", $re_index++);
270 $decl->add(sprintf("static char *$sym = %s;", cstring($re)));
271
272 return ($sym,length(pack "a*",$re));
273}
274
275sub savepv {
276 my $pv = pack "a*", shift;
277 my $pvsym = 0;
278 my $pvmax = 0;
279 if ($pv_copy_on_grow) {
280 $pvsym = sprintf("pv%d", $pv_index++);
281
282 if( defined $max_string_len && length($pv) > $max_string_len ) {
283 my $chars = join ', ', map { cchar $_ } split //, $pv;
284 $decl->add(sprintf("static char %s[] = { %s };", $pvsym, $chars));
285 }
286 else {
287 my $cstring = cstring($pv);
288 if ($cstring ne "0") { # sic
289 $decl->add(sprintf("static char %s[] = %s;",
290 $pvsym, $cstring));
291 }
292 }
293 } else {
294 $pvmax = length(pack "a*",$pv) + 1;
295 }
296 return ($pvsym, $pvmax);
297}
298
299sub save_rv {
300 my $sv = shift;
301# confess "Can't save RV: not ROK" unless $sv->FLAGS & SVf_ROK;
302 my $rv = $sv->RV->save;
303
304 $rv =~ s/^\(([AGHS]V|IO)\s*\*\)\s*(\&sv_list.*)$/$2/;
305
306 return $rv;
307}
308
309# savesym, pvmax, len, pv
310sub save_pv_or_rv {
311 my $sv = shift;
312
313 my $rok = $sv->FLAGS & SVf_ROK;
314 my $pok = $sv->FLAGS & SVf_POK;
315 my( $len, $pvmax, $savesym, $pv ) = ( 0, 0 );
316 if( $rok ) {
317 $savesym = '(char*)' . save_rv( $sv );
318 }
319 else {
320 $pv = $pok ? (pack "a*", $sv->PV) : undef;
321 $len = $pok ? length($pv) : 0;
322 ($savesym, $pvmax) = $pok ? savepv($pv) : ( 'NULL', 0 );
323 }
324
325 return ( $savesym, $pvmax, $len, $pv );
326}
327
328# see also init_op_ppaddr below; initializes the ppaddt to the
329# OpTYPE; init_op_ppaddr iterates over the ops and sets
330# op_ppaddr to PL_ppaddr[op_ppaddr]; this avoids an explicit assignmente
331# in perl_init ( ~10 bytes/op with GCC/i386 )
332sub B::OP::fake_ppaddr {
333 return $optimize_ppaddr ?
334 sprintf("INT2PTR(void*,OP_%s)", uc( $_[0]->name ) ) :
335 'NULL';
336}
337
338sub B::OP::save {
339 my ($op, $level) = @_;
340 my $sym = objsym($op);
341 return $sym if defined $sym;
342 my $type = $op->type;
343 $nullop_count++ unless $type;
344 if ($type == $OP_THREADSV) {
345 # saves looking up ppaddr but it's a bit naughty to hard code this
346 $init->add(sprintf("(void)find_threadsv(%s);",
347 cstring($threadsv_names[$op->targ])));
348 }
349 $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x",
350 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
351 $type, $op_seq, $op->flags, $op->private));
352 my $ix = $opsect->index;
353 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
354 unless $optimize_ppaddr;
355 savesym($op, "&op_list[$ix]");
356}
357
358sub B::FAKEOP::new {
359 my ($class, %objdata) = @_;
360 bless \%objdata, $class;
361}
362
363sub B::FAKEOP::save {
364 my ($op, $level) = @_;
365 $opsect->add(sprintf("%s, %s, %s, %u, %u, %u, 0x%x, 0x%x",
366 $op->next, $op->sibling, $op->fake_ppaddr, $op->targ,
367 $op->type, $op_seq, $op->flags, $op->private));
368 my $ix = $opsect->index;
369 $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
370 unless $optimize_ppaddr;
371 return "&op_list[$ix]";
372}
373
374sub B::FAKEOP::next { $_[0]->{"next"} || 0 }
375sub B::FAKEOP::type { $_[0]->{type} || 0}
376sub B::FAKEOP::sibling { $_[0]->{sibling} || 0 }
377sub B::FAKEOP::ppaddr { $_[0]->{ppaddr} || 0 }
378sub B::FAKEOP::targ { $_[0]->{targ} || 0 }
379sub B::FAKEOP::flags { $_[0]->{flags} || 0 }
380sub B::FAKEOP::private { $_[0]->{private} || 0 }
381
382sub B::UNOP::save {
383 my ($op, $level) = @_;
384 my $sym = objsym($op);
385 return $sym if defined $sym;
386 $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x",
387 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
388 $op->targ, $op->type, $op_seq, $op->flags,
389 $op->private, ${$op->first}));
390 my $ix = $unopsect->index;
391 $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
392 unless $optimize_ppaddr;
393 savesym($op, "(OP*)&unop_list[$ix]");
394}
395
396sub B::BINOP::save {
397 my ($op, $level) = @_;
398 my $sym = objsym($op);
399 return $sym if defined $sym;
400 $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
401 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
402 $op->targ, $op->type, $op_seq, $op->flags,
403 $op->private, ${$op->first}, ${$op->last}));
404 my $ix = $binopsect->index;
405 $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
406 unless $optimize_ppaddr;
407 savesym($op, "(OP*)&binop_list[$ix]");
408}
409
410sub B::LISTOP::save {
411 my ($op, $level) = @_;
412 my $sym = objsym($op);
413 return $sym if defined $sym;
414 $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
415 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
416 $op->targ, $op->type, $op_seq, $op->flags,
417 $op->private, ${$op->first}, ${$op->last}));
418 my $ix = $listopsect->index;
419 $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
420 unless $optimize_ppaddr;
421 savesym($op, "(OP*)&listop_list[$ix]");
422}
423
424sub B::LOGOP::save {
425 my ($op, $level) = @_;
426 my $sym = objsym($op);
427 return $sym if defined $sym;
428 $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x",
429 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
430 $op->targ, $op->type, $op_seq, $op->flags,
431 $op->private, ${$op->first}, ${$op->other}));
432 my $ix = $logopsect->index;
433 $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
434 unless $optimize_ppaddr;
435 savesym($op, "(OP*)&logop_list[$ix]");
436}
437
438sub B::LOOP::save {
439 my ($op, $level) = @_;
440 my $sym = objsym($op);
441 return $sym if defined $sym;
442 #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
443 # peekop($op->redoop), peekop($op->nextop),
444 # peekop($op->lastop)); # debug
445 $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
446 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
447 $op->targ, $op->type, $op_seq, $op->flags,
448 $op->private, ${$op->first}, ${$op->last},
449 ${$op->redoop}, ${$op->nextop},
450 ${$op->lastop}));
451 my $ix = $loopsect->index;
452 $init->add(sprintf("loop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
453 unless $optimize_ppaddr;
454 savesym($op, "(OP*)&loop_list[$ix]");
455}
456
457sub B::PVOP::save {
458 my ($op, $level) = @_;
459 my $sym = objsym($op);
460 return $sym if defined $sym;
461 $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
462 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
463 $op->targ, $op->type, $op_seq, $op->flags,
464 $op->private, cstring($op->pv)));
465 my $ix = $pvopsect->index;
466 $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
467 unless $optimize_ppaddr;
468 savesym($op, "(OP*)&pvop_list[$ix]");
469}
470
471sub B::SVOP::save {
472 my ($op, $level) = @_;
473 my $sym = objsym($op);
474 return $sym if defined $sym;
475 my $sv = $op->sv;
476 my $svsym = '(SV*)' . $sv->save;
477 my $is_const_addr = $svsym =~ m/Null|\&/;
478 $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s",
479 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
480 $op->targ, $op->type, $op_seq, $op->flags,
481 $op->private,
482 ( $is_const_addr ? $svsym : 'Nullsv' )));
483 my $ix = $svopsect->index;
484 $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
485 unless $optimize_ppaddr;
486 $init->add("svop_list[$ix].op_sv = $svsym;")
487 unless $is_const_addr;
488 savesym($op, "(OP*)&svop_list[$ix]");
489}
490
491sub B::PADOP::save {
492 my ($op, $level) = @_;
493 my $sym = objsym($op);
494 return $sym if defined $sym;
495 $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %d",
496 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
497 $op->targ, $op->type, $op_seq, $op->flags,
498 $op->private,$op->padix));
499 my $ix = $padopsect->index;
500 $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
501 unless $optimize_ppaddr;
502# $init->add(sprintf("padop_list[$ix].op_padix = %ld;", $op->padix));
503 savesym($op, "(OP*)&padop_list[$ix]");
504}
505
506sub B::COP::save {
507 my ($op, $level) = @_;
508 my $sym = objsym($op);
509 return $sym if defined $sym;
510 warn sprintf("COP: line %d file %s\n", $op->line, $op->file)
511 if $debug_cops;
512 # shameless cut'n'paste from B::Deparse
513 my $warn_sv;
514 my $warnings = $op->warnings;
515 my $is_special = $warnings->isa("B::SPECIAL");
516 if ($is_special && $$warnings == 4) {
517 # use warnings 'all';
518 $warn_sv = $optimize_warn_sv ?
519 'INT2PTR(SV*,1)' :
520 'pWARN_ALL';
521 }
522 elsif ($is_special && $$warnings == 5) {
523 # no warnings 'all';
524 $warn_sv = $optimize_warn_sv ?
525 'INT2PTR(SV*,2)' :
526 'pWARN_NONE';
527 }
528 elsif ($is_special) {
529 # use warnings;
530 $warn_sv = $optimize_warn_sv ?
531 'INT2PTR(SV*,3)' :
532 'pWARN_STD';
533 }
534 else {
535 # something else
536 $warn_sv = $warnings->save;
537 }
538
539 $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s",
540 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
541 $op->targ, $op->type, $op_seq, $op->flags,
542 $op->private, cstring($op->label), $op->cop_seq,
543 $op->arybase, $op->line,
544 ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
545 my $ix = $copsect->index;
546 $init->add(sprintf("cop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
547 unless $optimize_ppaddr;
548 $init->add(sprintf("cop_list[$ix].cop_warnings = %s;", $warn_sv ))
549 unless $optimize_warn_sv;
550 $init->add(sprintf("CopFILE_set(&cop_list[$ix], %s);", cstring($op->file)),
551 sprintf("CopSTASHPV_set(&cop_list[$ix], %s);", cstring($op->stashpv)));
552
553 savesym($op, "(OP*)&cop_list[$ix]");
554}
555
556sub B::PMOP::save {
557 my ($op, $level) = @_;
558 my $sym = objsym($op);
559 return $sym if defined $sym;
560 my $replroot = $op->pmreplroot;
561 my $replstart = $op->pmreplstart;
562 my $replrootfield;
563 my $replstartfield = sprintf("s\\_%x", $$replstart);
564 my $gvsym;
565 my $ppaddr = $op->ppaddr;
566 # under ithreads, OP_PUSHRE.op_replroot is an integer
567 $replrootfield = sprintf("s\\_%x", $$replroot) if ref $replroot;
568 if($ithreads && $op->name eq "pushre") {
569 $replrootfield = "INT2PTR(OP*,${replroot})";
570 } elsif ($$replroot) {
571 # OP_PUSHRE (a mutated version of OP_MATCH for the regexp
572 # argument to a split) stores a GV in op_pmreplroot instead
573 # of a substitution syntax tree. We don't want to walk that...
574 if ($op->name eq "pushre") {
575 $gvsym = $replroot->save;
576# warn "PMOP::save saving a pp_pushre with GV $gvsym\n"; # debug
577 $replrootfield = 0;
578 } else {
579 $replstartfield = saveoptree("*ignore*", $replroot, $replstart);
580 }
581 }
582 # pmnext handling is broken in perl itself, I think. Bad op_pmnext
583 # fields aren't noticed in perl's runtime (unless you try reset) but we
584 # segfault when trying to dereference it to find op->op_pmnext->op_type
585 $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, %u, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
586 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
587 $op->type, $op_seq, $op->flags, $op->private,
588 ${$op->first}, ${$op->last},
589 $replrootfield, $replstartfield,
590 ( $ithreads ? $op->pmoffset : 0 ),
591 $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
592 my $pm = sprintf("pmop_list[%d]", $pmopsect->index);
593 $init->add(sprintf("$pm.op_ppaddr = %s;", $ppaddr))
594 unless $optimize_ppaddr;
595 my $re = $op->precomp;
596 if (defined($re)) {
597 my( $resym, $relen ) = savere( $re );
598 $init->add(sprintf("PM_SETRE(&$pm,pregcomp($resym, $resym + %u, &$pm));",
599 $relen));
600 }
601 if ($gvsym) {
602 $init->add("$pm.op_pmreplroot = (OP*)$gvsym;");
603 }
604 savesym($op, "(OP*)&$pm");
605}
606
607sub B::SPECIAL::save {
608 my ($sv) = @_;
609 # special case: $$sv is not the address but an index into specialsv_list
610# warn "SPECIAL::save specialsv $$sv\n"; # debug
611 my $sym = $specialsv_name[$$sv];
612 if (!defined($sym)) {
613 confess "unknown specialsv index $$sv passed to B::SPECIAL::save";
614 }
615 return $sym;
616}
617
618sub B::OBJECT::save {}
619
620sub B::NULL::save {
621 my ($sv) = @_;
622 my $sym = objsym($sv);
623 return $sym if defined $sym;
624# warn "Saving SVt_NULL SV\n"; # debug
625 # debug
626 if ($$sv == 0) {
627 warn "NULL::save for sv = 0 called from @{[(caller(1))[3]]}\n";
628 return savesym($sv, "(void*)Nullsv /* XXX */");
629 }
630 $svsect->add(sprintf("0, %u, 0x%x", $sv->REFCNT , $sv->FLAGS));
631 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
632}
633
634sub B::IV::save {
635 my ($sv) = @_;
636 my $sym = objsym($sv);
637 return $sym if defined $sym;
638 $xpvivsect->add(sprintf("0, 0, 0, %d", $sv->IVX));
639 $svsect->add(sprintf("&xpviv_list[%d], %lu, 0x%x",
640 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
641 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
642}
643
644sub B::NV::save {
645 my ($sv) = @_;
646 my $sym = objsym($sv);
647 return $sym if defined $sym;
648 my $val= $sv->NVX;
649 $val .= '.00' if $val =~ /^-?\d+$/;
650 $xpvnvsect->add(sprintf("0, 0, 0, %d, %s", $sv->IVX, $val));
651 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
652 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
653 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
654}
655
656sub savepvn {
657 my ($dest,$pv) = @_;
658 my @res;
659 # work with byte offsets/lengths
660 my $pv = pack "a*", $pv;
661 if (defined $max_string_len && length($pv) > $max_string_len) {
662 push @res, sprintf("New(0,%s,%u,char);", $dest, length($pv)+1);
663 my $offset = 0;
664 while (length $pv) {
665 my $str = substr $pv, 0, $max_string_len, '';
666 push @res, sprintf("Copy(%s,$dest+$offset,%u,char);",
667 cstring($str), length($str));
668 $offset += length $str;
669 }
670 push @res, sprintf("%s[%u] = '\\0';", $dest, $offset);
671 }
672 else {
673 push @res, sprintf("%s = savepvn(%s, %u);", $dest,
674 cstring($pv), length($pv));
675 }
676 return @res;
677}
678
679sub B::PVLV::save {
680 my ($sv) = @_;
681 my $sym = objsym($sv);
682 return $sym if defined $sym;
683 my $pv = $sv->PV;
684 my $len = length($pv);
685 my ($pvsym, $pvmax) = savepv($pv);
686 my ($lvtarg, $lvtarg_sym);
687 $xpvlvsect->add(sprintf("%s, %u, %u, %d, %g, 0, 0, %u, %u, 0, %s",
688 $pvsym, $len, $pvmax, $sv->IVX, $sv->NVX,
689 $sv->TARGOFF, $sv->TARGLEN, cchar($sv->TYPE)));
690 $svsect->add(sprintf("&xpvlv_list[%d], %lu, 0x%x",
691 $xpvlvsect->index, $sv->REFCNT , $sv->FLAGS));
692 if (!$pv_copy_on_grow) {
693 $init->add(savepvn(sprintf("xpvlv_list[%d].xpv_pv",
694 $xpvlvsect->index), $pv));
695 }
696 $sv->save_magic;
697 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
698}
699
700sub B::PVIV::save {
701 my ($sv) = @_;
702 my $sym = objsym($sv);
703 return $sym if defined $sym;
704 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
705 $xpvivsect->add(sprintf("%s, %u, %u, %d", $savesym, $len, $pvmax, $sv->IVX));
706 $svsect->add(sprintf("&xpviv_list[%d], %u, 0x%x",
707 $xpvivsect->index, $sv->REFCNT , $sv->FLAGS));
708 if (defined($pv) && !$pv_copy_on_grow) {
709 $init->add(savepvn(sprintf("xpviv_list[%d].xpv_pv",
710 $xpvivsect->index), $pv));
711 }
712 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
713}
714
715sub B::PVNV::save {
716 my ($sv) = @_;
717 my $sym = objsym($sv);
718 return $sym if defined $sym;
719 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
720 my $val= $sv->NVX;
721 $val .= '.00' if $val =~ /^-?\d+$/;
722 $xpvnvsect->add(sprintf("%s, %u, %u, %d, %s",
723 $savesym, $len, $pvmax, $sv->IVX, $val));
724 $svsect->add(sprintf("&xpvnv_list[%d], %lu, 0x%x",
725 $xpvnvsect->index, $sv->REFCNT , $sv->FLAGS));
726 if (defined($pv) && !$pv_copy_on_grow) {
727 $init->add(savepvn(sprintf("xpvnv_list[%d].xpv_pv",
728 $xpvnvsect->index), $pv));
729 }
730 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
731}
732
733sub B::BM::save {
734 my ($sv) = @_;
735 my $sym = objsym($sv);
736 return $sym if defined $sym;
737 my $pv = pack "a*", ($sv->PV . "\0" . $sv->TABLE);
738 my $len = length($pv);
739 $xpvbmsect->add(sprintf("0, %u, %u, %d, %s, 0, 0, %d, %u, 0x%x",
740 $len, $len + 258, $sv->IVX, $sv->NVX,
741 $sv->USEFUL, $sv->PREVIOUS, $sv->RARE));
742 $svsect->add(sprintf("&xpvbm_list[%d], %lu, 0x%x",
743 $xpvbmsect->index, $sv->REFCNT , $sv->FLAGS));
744 $sv->save_magic;
745 $init->add(savepvn(sprintf("xpvbm_list[%d].xpv_pv",
746 $xpvbmsect->index), $pv),
747 sprintf("xpvbm_list[%d].xpv_cur = %u;",
748 $xpvbmsect->index, $len - 257));
749 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
750}
751
752sub B::PV::save {
753 my ($sv) = @_;
754 my $sym = objsym($sv);
755 return $sym if defined $sym;
756 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
757 $xpvsect->add(sprintf("%s, %u, %u", $savesym, $len, $pvmax));
758 $svsect->add(sprintf("&xpv_list[%d], %lu, 0x%x",
759 $xpvsect->index, $sv->REFCNT , $sv->FLAGS));
760 if (defined($pv) && !$pv_copy_on_grow) {
761 $init->add(savepvn(sprintf("xpv_list[%d].xpv_pv",
762 $xpvsect->index), $pv));
763 }
764 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
765}
766
767sub B::PVMG::save {
768 my ($sv) = @_;
769 my $sym = objsym($sv);
770 return $sym if defined $sym;
771 my( $savesym, $pvmax, $len, $pv ) = save_pv_or_rv( $sv );
772
773 $xpvmgsect->add(sprintf("%s, %u, %u, %d, %s, 0, 0",
774 $savesym, $len, $pvmax,
775 $sv->IVX, $sv->NVX));
776 $svsect->add(sprintf("&xpvmg_list[%d], %lu, 0x%x",
777 $xpvmgsect->index, $sv->REFCNT , $sv->FLAGS));
778 if (defined($pv) && !$pv_copy_on_grow) {
779 $init->add(savepvn(sprintf("xpvmg_list[%d].xpv_pv",
780 $xpvmgsect->index), $pv));
781 }
782 $sym = savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
783 $sv->save_magic;
784 return $sym;
785}
786
787sub B::PVMG::save_magic {
788 my ($sv) = @_;
789 #warn sprintf("saving magic for %s (0x%x)\n", class($sv), $$sv); # debug
790 my $stash = $sv->SvSTASH;
791 $stash->save;
792 if ($$stash) {
793 warn sprintf("xmg_stash = %s (0x%x)\n", $stash->NAME, $$stash)
794 if $debug_mg;
795 # XXX Hope stash is already going to be saved.
796 $init->add(sprintf("SvSTASH(s\\_%x) = s\\_%x;", $$sv, $$stash));
797 }
798 my @mgchain = $sv->MAGIC;
799 my ($mg, $type, $obj, $ptr,$len,$ptrsv);
800 foreach $mg (@mgchain) {
801 $type = $mg->TYPE;
802 $ptr = $mg->PTR;
803 $len=$mg->LENGTH;
804 if ($debug_mg) {
805 warn sprintf("magic %s (0x%x), obj %s (0x%x), type %s, ptr %s\n",
806 class($sv), $$sv, class($obj), $$obj,
807 cchar($type), cstring($ptr));
808 }
809
810 unless( $type eq 'r' ) {
811 $obj = $mg->OBJ;
812 $obj->save;
813 }
814
815 if ($len == HEf_SVKEY){
816 #The pointer is an SV*
817 $ptrsv=svref_2object($ptr)->save;
818 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s,(char *) %s, %d);",
819 $$sv, $$obj, cchar($type),$ptrsv,$len));
820 }elsif( $type eq 'r' ){
821 my $rx = $mg->REGEX;
822 my $pmop = $REGEXP{$rx};
823
824 confess "PMOP not found for REGEXP $rx" unless $pmop;
825
826 my( $resym, $relen ) = savere( $mg->precomp );
827 my $pmsym = $pmop->save;
828 $init->add( split /\n/, sprintf <<CODE, $$sv, cchar($type), cstring($ptr) );
829{
830 REGEXP* rx = pregcomp($resym, $resym + $relen, (PMOP*)$pmsym);
831 sv_magic((SV*)s\\_%x, (SV*)rx, %s, %s, %d);
832}
833CODE
834 }else{
835 $init->add(sprintf("sv_magic((SV*)s\\_%x, (SV*)s\\_%x, %s, %s, %d);",
836 $$sv, $$obj, cchar($type),cstring($ptr),$len));
837 }
838 }
839}
840
841sub B::RV::save {
842 my ($sv) = @_;
843 my $sym = objsym($sv);
844 return $sym if defined $sym;
845 my $rv = save_rv( $sv );
846 # GVs need to be handled at runtime
847 if( ref( $sv->RV ) eq 'B::GV' ) {
848 $xrvsect->add( "(SV*)Nullgv" );
849 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
850 }
851 # and stashes, too
852 elsif( $sv->RV->isa( 'B::HV' ) && $sv->RV->NAME ) {
853 $xrvsect->add( "(SV*)Nullhv" );
854 $init->add(sprintf("xrv_list[%d].xrv_rv = (SV*)%s;\n", $xrvsect->index, $rv));
855 }
856 else {
857 $xrvsect->add($rv);
858 }
859 $svsect->add(sprintf("&xrv_list[%d], %lu, 0x%x",
860 $xrvsect->index, $sv->REFCNT , $sv->FLAGS));
861 return savesym($sv, sprintf("&sv_list[%d]", $svsect->index));
862}
863
864sub try_autoload {
865 my ($cvstashname, $cvname) = @_;
866 warn sprintf("No definition for sub %s::%s\n", $cvstashname, $cvname);
867 # Handle AutoLoader classes explicitly. Any more general AUTOLOAD
868 # use should be handled by the class itself.
869 no strict 'refs';
870 my $isa = \@{"$cvstashname\::ISA"};
871 if (grep($_ eq "AutoLoader", @$isa)) {
872 warn "Forcing immediate load of sub derived from AutoLoader\n";
873 # Tweaked version of AutoLoader::AUTOLOAD
874 my $dir = $cvstashname;
875 $dir =~ s(::)(/)g;
876 eval { require "auto/$dir/$cvname.al" };
877 if ($@) {
878 warn qq(failed require "auto/$dir/$cvname.al": $@\n);
879 return 0;
880 } else {
881 return 1;
882 }
883 }
884}
885sub Dummy_initxs{};
886sub B::CV::save {
887 my ($cv) = @_;
888 my $sym = objsym($cv);
889 if (defined($sym)) {
890# warn sprintf("CV 0x%x already saved as $sym\n", $$cv); # debug
891 return $sym;
892 }
893 # Reserve a place in svsect and xpvcvsect and record indices
894 my $gv = $cv->GV;
895 my ($cvname, $cvstashname);
896 if ($$gv){
897 $cvname = $gv->NAME;
898 $cvstashname = $gv->STASH->NAME;
899 }
900 my $root = $cv->ROOT;
901 my $cvxsub = $cv->XSUB;
902 my $isconst = $cv->CvFLAGS & CVf_CONST;
903 if( $isconst ) {
904 my $value = $cv->XSUBANY;
905 my $stash = $gv->STASH;
906 my $vsym = $value->save;
907 my $stsym = $stash->save;
908 my $name = cstring($cvname);
909 $decl->add( "static CV* cv$cv_index;" );
910 $init->add( "cv$cv_index = newCONSTSUB( $stsym, NULL, $vsym );" );
911 my $sym = savesym( $cv, "cv$cv_index" );
912 $cv_index++;
913 return $sym;
914 }
915 #INIT is removed from the symbol table, so this call must come
916 # from PL_initav->save. Re-bootstrapping will push INIT back in
917 # so nullop should be sent.
918 if (!$isconst && $cvxsub && ($cvname ne "INIT")) {
919 my $egv = $gv->EGV;
920 my $stashname = $egv->STASH->NAME;
921 if ($cvname eq "bootstrap")
922 {
923 my $file = $gv->FILE;
924 $decl->add("/* bootstrap $file */");
925 warn "Bootstrap $stashname $file\n";
926 # if it not isa('DynaLoader'), it should hopefully be XSLoaded
927 # ( attributes being an exception, of course )
928 if( $stashname ne 'attributes' &&
929 !UNIVERSAL::isa($stashname,'DynaLoader') ) {
930 $xsub{$stashname}='Dynamic-XSLoaded';
931 $use_xsloader = 1;
932 }
933 else {
934 $xsub{$stashname}='Dynamic';
935 }
936 # $xsub{$stashname}='Static' unless $xsub{$stashname};
937 return qq/NULL/;
938 }
939 else
940 {
941 # XSUBs for IO::File, IO::Handle, IO::Socket,
942 # IO::Seekable and IO::Poll
943 # are defined in IO.xs, so let's bootstrap it
944 svref_2object( \&IO::bootstrap )->save
945 if grep { $stashname eq $_ } qw(IO::File IO::Handle IO::Socket
946 IO::Seekable IO::Poll);
947 }
948 warn sprintf("stub for XSUB $cvstashname\:\:$cvname CV 0x%x\n", $$cv) if $debug_cv;
949 return qq/(perl_get_cv("$stashname\:\:$cvname",TRUE))/;
950 }
951 if ($cvxsub && $cvname eq "INIT") {
952 no strict 'refs';
953 return svref_2object(\&Dummy_initxs)->save;
954 }
955 my $sv_ix = $svsect->index + 1;
956 $svsect->add("svix$sv_ix");
957 my $xpvcv_ix = $xpvcvsect->index + 1;
958 $xpvcvsect->add("xpvcvix$xpvcv_ix");
959 # Save symbol now so that GvCV() doesn't recurse back to us via CvGV()
960 $sym = savesym($cv, "&sv_list[$sv_ix]");
961 warn sprintf("saving $cvstashname\:\:$cvname CV 0x%x as $sym\n", $$cv) if $debug_cv;
962 if (!$$root && !$cvxsub) {
963 if (try_autoload($cvstashname, $cvname)) {
964 # Recalculate root and xsub
965 $root = $cv->ROOT;
966 $cvxsub = $cv->XSUB;
967 if ($$root || $cvxsub) {
968 warn "Successful forced autoload\n";
969 }
970 }
971 }
972 my $startfield = 0;
973 my $padlist = $cv->PADLIST;
974 my $pv = $cv->PV;
975 my $xsub = 0;
976 my $xsubany = "Nullany";
977 if ($$root) {
978 warn sprintf("saving op tree for CV 0x%x, root = 0x%x\n",
979 $$cv, $$root) if $debug_cv;
980 my $ppname = "";
981 if ($$gv) {
982 my $stashname = $gv->STASH->NAME;
983 my $gvname = $gv->NAME;
984 if ($gvname ne "__ANON__") {
985 $ppname = (${$gv->FORM} == $$cv) ? "pp_form_" : "pp_sub_";
986 $ppname .= ($stashname eq "main") ?
987 $gvname : "$stashname\::$gvname";
988 $ppname =~ s/::/__/g;
989 if ($gvname eq "INIT"){
990 $ppname .= "_$initsub_index";
991 $initsub_index++;
992 }
993 }
994 }
995 if (!$ppname) {
996 $ppname = "pp_anonsub_$anonsub_index";
997 $anonsub_index++;
998 }
999 $startfield = saveoptree($ppname, $root, $cv->START, $padlist->ARRAY);
1000 warn sprintf("done saving op tree for CV 0x%x, name %s, root 0x%x\n",
1001 $$cv, $ppname, $$root) if $debug_cv;
1002 if ($$padlist) {
1003 warn sprintf("saving PADLIST 0x%x for CV 0x%x\n",
1004 $$padlist, $$cv) if $debug_cv;
1005 $padlist->save;
1006 warn sprintf("done saving PADLIST 0x%x for CV 0x%x\n",
1007 $$padlist, $$cv) if $debug_cv;
1008 }
1009 }
1010 else {
1011 warn sprintf("No definition for sub %s::%s (unable to autoload)\n",
1012 $cvstashname, $cvname); # debug
1013 }
1014 $pv = '' unless defined $pv; # Avoid use of undef warnings
1015 $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",
1016 $xpvcv_ix, cstring($pv), length($pv), $cv->IVX,
1017 $cv->NVX, $startfield, ${$cv->ROOT}, $cv->DEPTH,
1018 $$padlist, ${$cv->OUTSIDE}, $cv->CvFLAGS));
1019
1020 if (${$cv->OUTSIDE} == ${main_cv()}){
1021 $init->add(sprintf("CvOUTSIDE(s\\_%x)=PL_main_cv;",$$cv));
1022 $init->add(sprintf("SvREFCNT_inc(PL_main_cv);"));
1023 }
1024
1025 if ($$gv) {
1026 $gv->save;
1027 $init->add(sprintf("CvGV(s\\_%x) = s\\_%x;",$$cv,$$gv));
1028 warn sprintf("done saving GV 0x%x for CV 0x%x\n",
1029 $$gv, $$cv) if $debug_cv;
1030 }
1031 if( $ithreads ) {
1032 $init->add( savepvn( "CvFILE($sym)", $cv->FILE) );
1033 }
1034 else {
1035 $init->add(sprintf("CvFILE($sym) = %s;", cstring($cv->FILE)));
1036 }
1037 my $stash = $cv->STASH;
1038 if ($$stash) {
1039 $stash->save;
1040 $init->add(sprintf("CvSTASH(s\\_%x) = s\\_%x;", $$cv, $$stash));
1041 warn sprintf("done saving STASH 0x%x for CV 0x%x\n",
1042 $$stash, $$cv) if $debug_cv;
1043 }
1044 $symsect->add(sprintf("svix%d\t(XPVCV*)&xpvcv_list[%u], %lu, 0x%x",
1045 $sv_ix, $xpvcv_ix, $cv->REFCNT +1*0 , $cv->FLAGS));
1046 return $sym;
1047}
1048
1049sub B::GV::save {
1050 my ($gv) = @_;
1051 my $sym = objsym($gv);
1052 if (defined($sym)) {
1053 #warn sprintf("GV 0x%x already saved as $sym\n", $$gv); # debug
1054 return $sym;
1055 } else {
1056 my $ix = $gv_index++;
1057 $sym = savesym($gv, "gv_list[$ix]");
1058 #warn sprintf("Saving GV 0x%x as $sym\n", $$gv); # debug
1059 }
1060 my $is_empty = $gv->is_empty;
1061 my $gvname = $gv->NAME;
1062 my $fullname = $gv->STASH->NAME . "::" . $gvname;
1063 my $name = cstring($fullname);
1064 #warn "GV name is $name\n"; # debug
1065 my $egvsym;
1066 unless ($is_empty) {
1067 my $egv = $gv->EGV;
1068 if ($$gv != $$egv) {
1069 #warn(sprintf("EGV name is %s, saving it now\n",
1070 # $egv->STASH->NAME . "::" . $egv->NAME)); # debug
1071 $egvsym = $egv->save;
1072 }
1073 }
1074 $init->add(qq[$sym = gv_fetchpv($name, TRUE, SVt_PV);],
1075 sprintf("SvFLAGS($sym) = 0x%x;", $gv->FLAGS ),
1076 sprintf("GvFLAGS($sym) = 0x%x;", $gv->GvFLAGS));
1077 $init->add(sprintf("GvLINE($sym) = %u;", $gv->LINE)) unless $is_empty;
1078 # XXX hack for when Perl accesses PVX of GVs
1079 $init->add("SvPVX($sym) = emptystring;\n");
1080 # Shouldn't need to do save_magic since gv_fetchpv handles that
1081 #$gv->save_magic;
1082 # XXX will always be > 1!!!
1083 my $refcnt = $gv->REFCNT + 1;
1084 $init->add(sprintf("SvREFCNT($sym) += %u;", $refcnt - 1 )) if $refcnt > 1;
1085
1086 return $sym if $is_empty;
1087
1088 # XXX B::walksymtable creates an extra reference to the GV
1089 my $gvrefcnt = $gv->GvREFCNT;
1090 if ($gvrefcnt > 1) {
1091 $init->add(sprintf("GvREFCNT($sym) += %u;", $gvrefcnt - 1));
1092 }
1093 # some non-alphavetic globs require some parts to be saved
1094 # ( ex. %!, but not $! )
1095 sub Save_HV() { 1 }
1096 sub Save_AV() { 2 }
1097 sub Save_SV() { 4 }
1098 sub Save_CV() { 8 }
1099 sub Save_FORM() { 16 }
1100 sub Save_IO() { 32 }
1101 my $savefields = 0;
1102 if( $gvname !~ /^([^A-Za-z]|STDIN|STDOUT|STDERR|ARGV|SIG|ENV)$/ ) {
1103 $savefields = Save_HV|Save_AV|Save_SV|Save_CV|Save_FORM|Save_IO;
1104 }
1105 elsif( $gvname eq '!' ) {
1106 $savefields = Save_HV;
1107 }
1108 # attributes::bootstrap is created in perl_parse
1109 # saving it would overwrite it, because perl_init() is
1110 # called after perl_parse()
1111 $savefields&=~Save_CV if $fullname eq 'attributes::bootstrap';
1112
1113 # save it
1114 # XXX is that correct?
1115 if (defined($egvsym) && $egvsym !~ m/Null/ ) {
1116 # Shared glob *foo = *bar
1117 $init->add("gp_free($sym);",
1118 "GvGP($sym) = GvGP($egvsym);");
1119 } elsif ($savefields) {
1120 # Don't save subfields of special GVs (*_, *1, *# and so on)
1121# warn "GV::save saving subfields\n"; # debug
1122 my $gvsv = $gv->SV;
1123 if ($$gvsv && $savefields&Save_SV) {
1124 $gvsv->save;
1125 $init->add(sprintf("GvSV($sym) = s\\_%x;", $$gvsv));
1126# warn "GV::save \$$name\n"; # debug
1127 }
1128 my $gvav = $gv->AV;
1129 if ($$gvav && $savefields&Save_AV) {
1130 $gvav->save;
1131 $init->add(sprintf("GvAV($sym) = s\\_%x;", $$gvav));
1132# warn "GV::save \@$name\n"; # debug
1133 }
1134 my $gvhv = $gv->HV;
1135 if ($$gvhv && $savefields&Save_HV) {
1136 $gvhv->save;
1137 $init->add(sprintf("GvHV($sym) = s\\_%x;", $$gvhv));
1138# warn "GV::save \%$name\n"; # debug
1139 }
1140 my $gvcv = $gv->CV;
1141 if ($$gvcv && $savefields&Save_CV) {
1142 my $origname=cstring($gvcv->GV->EGV->STASH->NAME .
1143 "::" . $gvcv->GV->EGV->NAME);
1144 if (0 && $gvcv->XSUB && $name ne $origname) { #XSUB alias
1145 # must save as a 'stub' so newXS() has a CV to populate
1146 $init->add("{ CV *cv;");
1147 $init->add("\tcv=perl_get_cv($origname,TRUE);");
1148 $init->add("\tGvCV($sym)=cv;");
1149 $init->add("\tSvREFCNT_inc((SV *)cv);");
1150 $init->add("}");
1151 } else {
1152 $init->add(sprintf("GvCV($sym) = (CV*)(%s);", $gvcv->save));
1153# warn "GV::save &$name\n"; # debug
1154 }
1155 }
1156 $init->add(sprintf("GvFILE($sym) = %s;", cstring($gv->FILE)));
1157# warn "GV::save GvFILE(*$name)\n"; # debug
1158 my $gvform = $gv->FORM;
1159 if ($$gvform && $savefields&Save_FORM) {
1160 $gvform->save;
1161 $init->add(sprintf("GvFORM($sym) = (CV*)s\\_%x;", $$gvform));
1162# warn "GV::save GvFORM(*$name)\n"; # debug
1163 }
1164 my $gvio = $gv->IO;
1165 if ($$gvio && $savefields&Save_IO) {
1166 $gvio->save;
1167 $init->add(sprintf("GvIOp($sym) = s\\_%x;", $$gvio));
1168 if( $fullname =~ m/::DATA$/ && $save_data_fh ) {
1169 no strict 'refs';
1170 my $fh = *{$fullname}{IO};
1171 use strict 'refs';
1172 $gvio->save_data( $fullname, <$fh> ) if $fh->opened;
1173 }
1174# warn "GV::save GvIO(*$name)\n"; # debug
1175 }
1176 }
1177 return $sym;
1178}
1179
1180sub B::AV::save {
1181 my ($av) = @_;
1182 my $sym = objsym($av);
1183 return $sym if defined $sym;
1184 my $avflags = $av->AvFLAGS;
1185 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x",
1186 $avflags));
1187 $svsect->add(sprintf("&xpvav_list[%d], %lu, 0x%x",
1188 $xpvavsect->index, $av->REFCNT , $av->FLAGS));
1189 my $sv_list_index = $svsect->index;
1190 my $fill = $av->FILL;
1191 $av->save_magic;
1192 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags)
1193 if $debug_av;
1194 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack
1195 #if ($fill > -1 && ($avflags & AVf_REAL)) {
1196 if ($fill > -1) {
1197 my @array = $av->ARRAY;
1198 if ($debug_av) {
1199 my $el;
1200 my $i = 0;
1201 foreach $el (@array) {
1202 warn sprintf("AV 0x%x[%d] = %s 0x%x\n",
1203 $$av, $i++, class($el), $$el);
1204 }
1205 }
1206# my @names = map($_->save, @array);
1207 # XXX Better ways to write loop?
1208 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...;
1209 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...;
1210
1211 # micro optimization: op/pat.t ( and other code probably )
1212 # has very large pads ( 20k/30k elements ) passing them to
1213 # ->add is a performance bottleneck: passing them as a
1214 # single string cuts runtime from 6min20sec to 40sec
1215
1216 # you want to keep this out of the no_split/split
1217 # map("\t*svp++ = (SV*)$_;", @names),
1218 my $acc = '';
1219 foreach my $i ( 0..$#array ) {
1220 $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t";
1221 }
1222 $acc .= "\n";
1223
1224 $init->no_split;
1225 $init->add("{",
1226 "\tSV **svp;",
1227 "\tAV *av = (AV*)&sv_list[$sv_list_index];",
1228 "\tav_extend(av, $fill);",
1229 "\tsvp = AvARRAY(av);" );
1230 $init->add($acc);
1231 $init->add("\tAvFILLp(av) = $fill;",
1232 "}");
1233 $init->split;
1234 # we really added a lot of lines ( B::C::InitSection->add
1235 # should really scan for \n, but that would slow
1236 # it down
1237 $init->inc_count( $#array );
1238 } else {
1239 my $max = $av->MAX;
1240 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);")
1241 if $max > -1;
1242 }
1243 return savesym($av, "(AV*)&sv_list[$sv_list_index]");
1244}
1245
1246sub B::HV::save {
1247 my ($hv) = @_;
1248 my $sym = objsym($hv);
1249 return $sym if defined $sym;
1250 my $name = $hv->NAME;
1251 if ($name) {
1252 # It's a stash
1253
1254 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually
1255 # the only symptom is that sv_reset tries to reset the PMf_USED flag of
1256 # a trashed op but we look at the trashed op_type and segfault.
1257 #my $adpmroot = ${$hv->PMROOT};
1258 my $adpmroot = 0;
1259 $decl->add("static HV *hv$hv_index;");
1260 # XXX Beware of weird package names containing double-quotes, \n, ...?
1261 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]);
1262 if ($adpmroot) {
1263 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;",
1264 $adpmroot));
1265 }
1266 $sym = savesym($hv, "hv$hv_index");
1267 $hv_index++;
1268 return $sym;
1269 }
1270 # It's just an ordinary HV
1271 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0",
1272 $hv->MAX, $hv->RITER));
1273 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x",
1274 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS));
1275 my $sv_list_index = $svsect->index;
1276 my @contents = $hv->ARRAY;
1277 if (@contents) {
1278 my $i;
1279 for ($i = 1; $i < @contents; $i += 2) {
1280 $contents[$i] = $contents[$i]->save;
1281 }
1282 $init->no_split;
1283 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];");
1284 while (@contents) {
1285 my ($key, $value) = splice(@contents, 0, 2);
1286 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1287 cstring($key),length(pack "a*",$key),
1288 $value, hash($key)));
1289# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1290# cstring($key),length($key),$value, 0));
1291 }
1292 $init->add("}");
1293 $init->split;
1294 }
1295 $hv->save_magic();
1296 return savesym($hv, "(HV*)&sv_list[$sv_list_index]");
1297}
1298
1299sub B::IO::save_data {
1300 my( $io, $globname, @data ) = @_;
1301 my $data = join '', @data;
1302
1303 # XXX using $DATA might clobber it!
1304 my $sym = svref_2object( \\$data )->save;
1305 $init->add( split /\n/, <<CODE );
1306 {
1307 GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV );
1308 SV* sv = $sym;
1309 GvSV( gv ) = sv;
1310 }
1311CODE
1312 # for PerlIO::scalar
1313 $use_xsloader = 1;
1314 $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname );
1315}
1316
1317sub B::IO::save {
1318 my ($io) = @_;
1319 my $sym = objsym($io);
1320 return $sym if defined $sym;
1321 my $pv = $io->PV;
1322 $pv = '' unless defined $pv;
1323 my $len = length($pv);
1324 $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",
1325 $len, $len+1, $io->IVX, $io->NVX, $io->LINES,
1326 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT,
1327 cstring($io->TOP_NAME), cstring($io->FMT_NAME),
1328 cstring($io->BOTTOM_NAME), $io->SUBPROCESS,
1329 cchar($io->IoTYPE), $io->IoFLAGS));
1330 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x",
1331 $xpviosect->index, $io->REFCNT , $io->FLAGS));
1332 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index));
1333 # deal with $x = *STDIN/STDOUT/STDERR{IO}
1334 my $perlio_func;
1335 foreach ( qw(stdin stdout stderr) ) {
1336 $io->IsSTD($_) and $perlio_func = $_;
1337 }
1338 if( $perlio_func ) {
1339 $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" );
1340 $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" );
1341 }
1342
1343 my ($field, $fsym);
1344 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) {
1345 $fsym = $io->$field();
1346 if ($$fsym) {
1347 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym));
1348 $fsym->save;
1349 }
1350 }
1351 $io->save_magic;
1352 return $sym;
1353}
1354
1355sub B::SV::save {
1356 my $sv = shift;
1357 # This is where we catch an honest-to-goodness Nullsv (which gets
1358 # blessed into B::SV explicitly) and any stray erroneous SVs.
1359 return 0 unless $$sv;
1360 confess sprintf("cannot save that type of SV: %s (0x%x)\n",
1361 class($sv), $$sv);
1362}
1363
1364sub output_all {
1365 my $init_name = shift;
1366 my $section;
1367 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect,
1368 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect,
1369 $loopsect, $copsect, $svsect, $xpvsect,
1370 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect,
1371 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect);
1372 $symsect->output(\*STDOUT, "#define %s\n");
1373 print "\n";
1374 output_declarations();
1375 foreach $section (@sections) {
1376 my $lines = $section->index + 1;
1377 if ($lines) {
1378 my $name = $section->name;
1379 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1380 print "Static $typename ${name}_list[$lines];\n";
1381 }
1382 }
1383 # XXX hack for when Perl accesses PVX of GVs
1384 print 'Static char emptystring[] = "\0";';
1385
1386 $decl->output(\*STDOUT, "%s\n");
1387 print "\n";
1388 foreach $section (@sections) {
1389 my $lines = $section->index + 1;
1390 if ($lines) {
1391 my $name = $section->name;
1392 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name);
1393 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines;
1394 $section->output(\*STDOUT, "\t{ %s }, /* %d */\n");
1395 print "};\n\n";
1396 }
1397 }
1398
1399 $init->output(\*STDOUT, "\t%s\n", $init_name );
1400 if ($verbose) {
1401 warn compile_stats();
1402 warn "NULLOP count: $nullop_count\n";
1403 }
1404}
1405
1406sub output_declarations {
1407 print <<'EOT';
1408#ifdef BROKEN_STATIC_REDECL
1409#define Static extern
1410#else
1411#define Static static
1412#endif /* BROKEN_STATIC_REDECL */
1413
1414#ifdef BROKEN_UNION_INIT
1415/*
1416 * Cribbed from cv.h with ANY (a union) replaced by void*.
1417 * Some pre-Standard compilers can't cope with initialising unions. Ho hum.
1418 */
1419typedef struct {
1420 char * xpv_pv; /* pointer to malloced string */
1421 STRLEN xpv_cur; /* length of xp_pv as a C string */
1422 STRLEN xpv_len; /* allocated size */
1423 IV xof_off; /* integer value */
1424 NV xnv_nv; /* numeric value, if any */
1425 MAGIC* xmg_magic; /* magic for scalar array */
1426 HV* xmg_stash; /* class package */
1427
1428 HV * xcv_stash;
1429 OP * xcv_start;
1430 OP * xcv_root;
1431 void (*xcv_xsub) (pTHX_ CV*);
1432 ANY xcv_xsubany;
1433 GV * xcv_gv;
1434 char * xcv_file;
1435 long xcv_depth; /* >= 2 indicates recursive call */
1436 AV * xcv_padlist;
1437 CV * xcv_outside;
1438#ifdef USE_5005THREADS
1439 perl_mutex *xcv_mutexp;
1440 struct perl_thread *xcv_owner; /* current owner thread */
1441#endif /* USE_5005THREADS */
1442 cv_flags_t xcv_flags;
1443} XPVCV_or_similar;
1444#define ANYINIT(i) i
1445#else
1446#define XPVCV_or_similar XPVCV
1447#define ANYINIT(i) {i}
1448#endif /* BROKEN_UNION_INIT */
1449#define Nullany ANYINIT(0)
1450
1451#define UNUSED 0
1452#define sym_0 0
1453EOT
1454 print "static GV *gv_list[$gv_index];\n" if $gv_index;
1455 print "\n";
1456}
1457
1458
1459sub output_boilerplate {
1460 print <<'EOT';
1461#include "EXTERN.h"
1462#include "perl.h"
1463#include "XSUB.h"
1464
1465/* Workaround for mapstart: the only op which needs a different ppaddr */
1466#undef Perl_pp_mapstart
1467#define Perl_pp_mapstart Perl_pp_grepstart
1468#undef OP_MAPSTART
1469#define OP_MAPSTART OP_GREPSTART
1470#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader
1471EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
1472
1473static void xs_init (pTHX);
1474static void dl_init (pTHX);
1475static PerlInterpreter *my_perl;
1476EOT
1477}
1478
1479sub init_op_addr {
1480 my( $op_type, $num ) = @_;
1481 my $op_list = $op_type."_list";
1482
1483 $init->add( split /\n/, <<EOT );
1484 {
1485 int i;
1486
1487 for( i = 0; i < ${num}; ++i )
1488 {
1489 ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)];
1490 }
1491 }
1492EOT
1493}
1494
1495sub init_op_warn {
1496 my( $op_type, $num ) = @_;
1497 my $op_list = $op_type."_list";
1498
1499 # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const
1500 $init->add( split /\n/, <<EOT );
1501 {
1502 int i;
1503
1504 for( i = 0; i < ${num}; ++i )
1505 {
1506 switch( (int)(${op_list}\[i].cop_warnings) )
1507 {
1508 case 1:
1509 ${op_list}\[i].cop_warnings = pWARN_ALL;
1510 break;
1511 case 2:
1512 ${op_list}\[i].cop_warnings = pWARN_NONE;
1513 break;
1514 case 3:
1515 ${op_list}\[i].cop_warnings = pWARN_STD;
1516 break;
1517 default:
1518 break;
1519 }
1520 }
1521 }
1522EOT
1523}
1524
1525sub output_main {
1526 print <<'EOT';
1527/* if USE_IMPLICIT_SYS, we need a 'real' exit */
1528#if defined(exit)
1529#undef exit
1530#endif
1531
1532int
1533main(int argc, char **argv, char **env)
1534{
1535 int exitstatus;
1536 int i;
1537 char **fakeargv;
1538 GV* tmpgv;
1539 SV* tmpsv;
1540 int options_count;
1541
1542 PERL_SYS_INIT3(&argc,&argv,&env);
1543
1544 if (!PL_do_undump) {
1545 my_perl = perl_alloc();
1546 if (!my_perl)
1547 exit(1);
1548 perl_construct( my_perl );
1549 PL_perl_destruct_level = 0;
1550 }
1551EOT
1552 if( $ithreads ) {
1553 # XXX init free elems!
1554 my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref
1555
1556 print <<EOT;
1557#ifdef USE_ITHREADS
1558 for( i = 0; i < $pad_len; ++i ) {
1559 av_push( PL_regex_padav, newSViv(0) );
1560 }
1561 PL_regex_pad = AvARRAY( PL_regex_padav );
1562#endif
1563EOT
1564 }
1565
1566 print <<'EOT';
1567#ifdef CSH
1568 if (!PL_cshlen)
1569 PL_cshlen = strlen(PL_cshname);
1570#endif
1571
1572#ifdef ALLOW_PERL_OPTIONS
1573#define EXTRA_OPTIONS 3
1574#else
1575#define EXTRA_OPTIONS 4
1576#endif /* ALLOW_PERL_OPTIONS */
1577 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
1578
1579 fakeargv[0] = argv[0];
1580 fakeargv[1] = "-e";
1581 fakeargv[2] = "";
1582 options_count = 3;
1583EOT
1584 # honour -T
1585 print <<EOT;
1586 if( ${^TAINT} ) {
1587 fakeargv[options_count] = "-T";
1588 ++options_count;
1589 }
1590EOT
1591 print <<'EOT';
1592#ifndef ALLOW_PERL_OPTIONS
1593 fakeargv[options_count] = "--";
1594 ++options_count;
1595#endif /* ALLOW_PERL_OPTIONS */
1596 for (i = 1; i < argc; i++)
1597 fakeargv[i + options_count - 1] = argv[i];
1598 fakeargv[argc + options_count - 1] = 0;
1599
1600 exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
1601 fakeargv, NULL);
1602
1603 if (exitstatus)
1604 exit( exitstatus );
1605
1606 TAINT;
1607EOT
1608
1609 if( $use_perl_script_name ) {
1610 my $dollar_0 = $0;
1611 $dollar_0 =~ s/\\/\\\\/g;
1612 $dollar_0 = '"' . $dollar_0 . '"';
1613
1614 print <<EOT;
1615 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */
1616 tmpsv = GvSV(tmpgv);
1617 sv_setpv(tmpsv, ${dollar_0});
1618 SvSETMAGIC(tmpsv);
1619 }
1620EOT
1621 }
1622
1623 print <<'EOT';
1624 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
1625 tmpsv = GvSV(tmpgv);
1626#ifdef WIN32
1627 sv_setpv(tmpsv,"perl.exe");
1628#else
1629 sv_setpv(tmpsv,"perl");
1630#endif
1631 SvSETMAGIC(tmpsv);
1632 }
1633
1634 TAINT_NOT;
1635
1636 /* PL_main_cv = PL_compcv; */
1637 PL_compcv = 0;
1638
1639 exitstatus = perl_init();
1640 if (exitstatus)
1641 exit( exitstatus );
1642 dl_init(aTHX);
1643
1644 exitstatus = perl_run( my_perl );
1645
1646 perl_destruct( my_perl );
1647 perl_free( my_perl );
1648
1649 PERL_SYS_TERM();
1650
1651 exit( exitstatus );
1652}
1653
1654/* yanked from perl.c */
1655static void
1656xs_init(pTHX)
1657{
1658 char *file = __FILE__;
1659 dTARG;
1660 dSP;
1661EOT
1662 print "\n#ifdef USE_DYNAMIC_LOADING";
1663 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/;
1664 print "\n#endif\n" ;
1665 # delete $xsub{'DynaLoader'};
1666 delete $xsub{'UNIVERSAL'};
1667 print("/* bootstrapping code*/\n\tSAVETMPS;\n");
1668 print("\ttarg=sv_newmortal();\n");
1669 print "#ifdef USE_DYNAMIC_LOADING\n";
1670 print "\tPUSHMARK(sp);\n";
1671 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/;
1672 print qq/\tPUTBACK;\n/;
1673 print "\tboot_DynaLoader(aTHX_ NULL);\n";
1674 print qq/\tSPAGAIN;\n/;
1675 print "#endif\n";
1676 foreach my $stashname (keys %xsub){
1677 if ($xsub{$stashname} !~ m/Dynamic/ ) {
1678 my $stashxsub=$stashname;
1679 $stashxsub =~ s/::/__/g;
1680 print "\tPUSHMARK(sp);\n";
1681 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/;
1682 print qq/\tPUTBACK;\n/;
1683 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1684 print qq/\tSPAGAIN;\n/;
1685 }
1686 }
1687 print("\tFREETMPS;\n/* end bootstrapping code */\n");
1688 print "}\n";
1689
1690print <<'EOT';
1691static void
1692dl_init(pTHX)
1693{
1694 char *file = __FILE__;
1695 dTARG;
1696 dSP;
1697EOT
1698 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n");
1699 print("\ttarg=sv_newmortal();\n");
1700 foreach my $stashname (@DynaLoader::dl_modules) {
1701 warn "Loaded $stashname\n";
1702 if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) {
1703 my $stashxsub=$stashname;
1704 $stashxsub =~ s/::/__/g;
1705 print "\tPUSHMARK(sp);\n";
1706 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/;
1707 print qq/\tPUTBACK;\n/;
1708 print "#ifdef USE_DYNAMIC_LOADING\n";
1709 warn "bootstrapping $stashname added to xs_init\n";
1710 if( $xsub{$stashname} eq 'Dynamic' ) {
1711 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/;
1712 }
1713 else {
1714 print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/;
1715 }
1716 print "#else\n";
1717 print "\tboot_$stashxsub(aTHX_ NULL);\n";
1718 print "#endif\n";
1719 print qq/\tSPAGAIN;\n/;
1720 }
1721 }
1722 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n");
1723 print "}\n";
1724}
1725sub dump_symtable {
1726 # For debugging
1727 my ($sym, $val);
1728 warn "----Symbol table:\n";
1729 while (($sym, $val) = each %symtable) {
1730 warn "$sym => $val\n";
1731 }
1732 warn "---End of symbol table\n";
1733}
1734
1735sub save_object {
1736 my $sv;
1737 foreach $sv (@_) {
1738 svref_2object($sv)->save;
1739 }
1740}
1741
1742sub Dummy_BootStrap { }
1743
1744sub B::GV::savecv
1745{
1746 my $gv = shift;
1747 my $package=$gv->STASH->NAME;
1748 my $name = $gv->NAME;
1749 my $cv = $gv->CV;
1750 my $sv = $gv->SV;
1751 my $av = $gv->AV;
1752 my $hv = $gv->HV;
1753
1754 my $fullname = $gv->STASH->NAME . "::" . $gv->NAME;
1755
1756 # We may be looking at this package just because it is a branch in the
1757 # symbol table which is on the path to a package which we need to save
1758 # e.g. this is 'Getopt' and we need to save 'Getopt::Long'
1759 #
1760 return unless ($unused_sub_packages{$package});
1761 return unless ($$cv || $$av || $$sv || $$hv);
1762 $gv->save;
1763}
1764
1765sub mark_package
1766{
1767 my $package = shift;
1768 unless ($unused_sub_packages{$package})
1769 {
1770 no strict 'refs';
1771 $unused_sub_packages{$package} = 1;
1772 if (defined @{$package.'::ISA'})
1773 {
1774 foreach my $isa (@{$package.'::ISA'})
1775 {
1776 if ($isa eq 'DynaLoader')
1777 {
1778 unless (defined(&{$package.'::bootstrap'}))
1779 {
1780 warn "Forcing bootstrap of $package\n";
1781 eval { $package->bootstrap };
1782 }
1783 }
1784# else
1785 {
1786 unless ($unused_sub_packages{$isa})
1787 {
1788 warn "$isa saved (it is in $package\'s \@ISA)\n";
1789 mark_package($isa);
1790 }
1791 }
1792 }
1793 }
1794 }
1795 return 1;
1796}
1797
1798sub should_save
1799{
1800 no strict qw(vars refs);
1801 my $package = shift;
1802 $package =~ s/::$//;
1803 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc.
1804 # warn "Considering $package\n";#debug
1805 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages))
1806 {
1807 # If this package is a prefix to something we are saving, traverse it
1808 # but do not mark it for saving if it is not already
1809 # e.g. to get to Getopt::Long we need to traverse Getopt but need
1810 # not save Getopt
1811 return 1 if ($u =~ /^$package\:\:/);
1812 }
1813 if (exists $unused_sub_packages{$package})
1814 {
1815 # warn "Cached $package is ".$unused_sub_packages{$package}."\n";
1816 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ;
1817 return $unused_sub_packages{$package};
1818 }
1819 # Omit the packages which we use (and which cause grief
1820 # because of fancy "goto &$AUTOLOAD" stuff).
1821 # XXX Surely there must be a nicer way to do this.
1822 if ($package eq "FileHandle" || $package eq "Config" ||
1823 $package eq "SelectSaver" || $package =~/^(B|IO)::/)
1824 {
1825 delete_unsaved_hashINC($package);
1826 return $unused_sub_packages{$package} = 0;
1827 }
1828 # Now see if current package looks like an OO class this is probably too strong.
1829 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE))
1830 {
1831 if (UNIVERSAL::can($package, $m))
1832 {
1833 warn "$package has method $m: saving package\n";#debug
1834 return mark_package($package);
1835 }
1836 }
1837 delete_unsaved_hashINC($package);
1838 return $unused_sub_packages{$package} = 0;
1839}
1840sub delete_unsaved_hashINC{
1841 my $packname=shift;
1842 $packname =~ s/\:\:/\//g;
1843 $packname .= '.pm';
1844# warn "deleting $packname" if $INC{$packname} ;# debug
1845 delete $INC{$packname};
1846}
1847sub walkpackages
1848{
1849 my ($symref, $recurse, $prefix) = @_;
1850 my $sym;
1851 my $ref;
1852 no strict 'vars';
1853 local(*glob);
1854 $prefix = '' unless defined $prefix;
1855 while (($sym, $ref) = each %$symref)
1856 {
1857 *glob = $ref;
1858 if ($sym =~ /::$/)
1859 {
1860 $sym = $prefix . $sym;
1861 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym))
1862 {
1863 walkpackages(\%glob, $recurse, $sym);
1864 }
1865 }
1866 }
1867}
1868
1869
1870sub save_unused_subs
1871{
1872 no strict qw(refs);
1873 &descend_marked_unused;
1874 warn "Prescan\n";
1875 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 });
1876 warn "Saving methods\n";
1877 walksymtable(\%{"main::"}, "savecv", \&should_save);
1878}
1879
1880sub save_context
1881{
1882 my $curpad_nam = (comppadlist->ARRAY)[0]->save;
1883 my $curpad_sym = (comppadlist->ARRAY)[1]->save;
1884 my $inc_hv = svref_2object(\%INC)->save;
1885 my $inc_av = svref_2object(\@INC)->save;
1886 my $amagic_generate= amagic_generation;
1887 $init->add( "PL_curpad = AvARRAY($curpad_sym);",
1888 "GvHV(PL_incgv) = $inc_hv;",
1889 "GvAV(PL_incgv) = $inc_av;",
1890 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
1891 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1892 "PL_amagic_generation= $amagic_generate;" );
1893}
1894
1895sub descend_marked_unused {
1896 foreach my $pack (keys %unused_sub_packages)
1897 {
1898 mark_package($pack);
1899 }
1900}
1901
1902sub save_main {
1903 # this is mainly for the test suite
1904 my $warner = $SIG{__WARN__};
1905 local $SIG{__WARN__} = sub { print STDERR @_ };
1906
1907 warn "Starting compile\n";
1908 warn "Walking tree\n";
1909 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output
1910 walkoptree(main_root, "save");
1911 warn "done main optree, walking symtable for extras\n" if $debug_cv;
1912 save_unused_subs();
1913 # XSLoader was used, force saving of XSLoader::load
1914 if( $use_xsloader ) {
1915 my $cv = svref_2object( \&XSLoader::load );
1916 $cv->save;
1917 }
1918 # save %SIG ( in case it was set in a BEGIN block )
1919 if( $save_sig ) {
1920 local $SIG{__WARN__} = $warner;
1921 $init->no_split;
1922 $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" );
1923 foreach my $k ( keys %SIG ) {
1924 next unless ref $SIG{$k};
1925 my $cv = svref_2object( \$SIG{$k} );
1926 my $sv = $cv->save;
1927 $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv );
1928 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);",
1929 cstring($k),length(pack "a*",$k),
1930 'sv', hash($k)));
1931 $init->add('mg_set(sv);','}');
1932 }
1933 $init->add('}');
1934 $init->split;
1935 }
1936 # honour -w
1937 $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W );
1938 #
1939 my $init_av = init_av->save;
1940 my $end_av = end_av->save;
1941 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1942 sprintf("PL_main_start = s\\_%x;", ${main_start()}),
1943 "PL_initav = (AV *) $init_av;",
1944 "PL_endav = (AV*) $end_av;");
1945 save_context();
1946 # init op addrs ( must be the last action, otherwise
1947 # some ops might not be initialized
1948 if( $optimize_ppaddr ) {
1949 foreach my $i ( @op_sections ) {
1950 my $section = $$i;
1951 next unless $section->index >= 0;
1952 init_op_addr( $section->name, $section->index + 1);
1953 }
1954 }
1955 init_op_warn( $copsect->name, $copsect->index + 1)
1956 if $optimize_warn_sv && $copsect->index >= 0;
1957
1958 warn "Writing output\n";
1959 output_boilerplate();
1960 print "\n";
1961 output_all("perl_init");
1962 print "\n";
1963 output_main();
1964}
1965
1966sub init_sections {
1967 my @sections = (decl => \$decl, sym => \$symsect,
1968 binop => \$binopsect, condop => \$condopsect,
1969 cop => \$copsect, padop => \$padopsect,
1970 listop => \$listopsect, logop => \$logopsect,
1971 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect,
1972 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect,
1973 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect,
1974 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect,
1975 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect,
1976 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect,
1977 xrv => \$xrvsect, xpvbm => \$xpvbmsect,
1978 xpvio => \$xpviosect);
1979 my ($name, $sectref);
1980 while (($name, $sectref) = splice(@sections, 0, 2)) {
1981 $$sectref = new B::C::Section $name, \%symtable, 0;
1982 }
1983 $init = new B::C::InitSection 'init', \%symtable, 0;
1984}
1985
1986sub mark_unused
1987{
1988 my ($arg,$val) = @_;
1989 $unused_sub_packages{$arg} = $val;
1990}
1991
1992sub compile {
1993 my @options = @_;
1994 my ($option, $opt, $arg);
1995 my @eval_at_startup;
1996 my %option_map = ( 'cog' => \$pv_copy_on_grow,
1997 'save-data' => \$save_data_fh,
1998 'ppaddr' => \$optimize_ppaddr,
1999 'warn-sv' => \$optimize_warn_sv,
2000 'use-script-name' => \$use_perl_script_name,
2001 'save-sig-hash' => \$save_sig,
2002 );
2003 my %optimization_map = ( 0 => [ qw() ], # special case
2004 1 => [ qw(-fcog) ],
2005 2 => [ qw(-fwarn-sv -fppaddr) ],
2006 );
2007 OPTION:
2008 while ($option = shift @options) {
2009 if ($option =~ /^-(.)(.*)/) {
2010 $opt = $1;
2011 $arg = $2;
2012 } else {
2013 unshift @options, $option;
2014 last OPTION;
2015 }
2016 if ($opt eq "-" && $arg eq "-") {
2017 shift @options;
2018 last OPTION;
2019 }
2020 if ($opt eq "w") {
2021 $warn_undefined_syms = 1;
2022 } elsif ($opt eq "D") {
2023 $arg ||= shift @options;
2024 foreach $arg (split(//, $arg)) {
2025 if ($arg eq "o") {
2026 B->debug(1);
2027 } elsif ($arg eq "c") {
2028 $debug_cops = 1;
2029 } elsif ($arg eq "A") {
2030 $debug_av = 1;
2031 } elsif ($arg eq "C") {
2032 $debug_cv = 1;
2033 } elsif ($arg eq "M") {
2034 $debug_mg = 1;
2035 } else {
2036 warn "ignoring unknown debug option: $arg\n";
2037 }
2038 }
2039 } elsif ($opt eq "o") {
2040 $arg ||= shift @options;
2041 open(STDOUT, ">$arg") or return "$arg: $!\n";
2042 } elsif ($opt eq "v") {
2043 $verbose = 1;
2044 } elsif ($opt eq "u") {
2045 $arg ||= shift @options;
2046 mark_unused($arg,undef);
2047 } elsif ($opt eq "f") {
2048 $arg ||= shift @options;
2049 $arg =~ m/(no-)?(.*)/;
2050 my $no = defined($1) && $1 eq 'no-';
2051 $arg = $no ? $2 : $arg;
2052 if( exists $option_map{$arg} ) {
2053 ${$option_map{$arg}} = !$no;
2054 } else {
2055 die "Invalid optimization '$arg'";
2056 }
2057 } elsif ($opt eq "O") {
2058 $arg = 1 if $arg eq "";
2059 my @opt;
2060 foreach my $i ( 1 .. $arg ) {
2061 push @opt, @{$optimization_map{$i}}
2062 if exists $optimization_map{$i};
2063 }
2064 unshift @options, @opt;
2065 } elsif ($opt eq "e") {
2066 push @eval_at_startup, $arg;
2067 } elsif ($opt eq "l") {
2068 $max_string_len = $arg;
2069 }
2070 }
2071 init_sections();
2072 foreach my $i ( @eval_at_startup ) {
2073 $init->add_eval( $i );
2074 }
2075 if (@options) {
2076 return sub {
2077 my $objname;
2078 foreach $objname (@options) {
2079 eval "save_object(\\$objname)";
2080 }
2081 output_all();
2082 }
2083 } else {
2084 return sub { save_main() };
2085 }
2086}
2087
20881;
2089
2090__END__
2091
2092=head1 NAME
2093
2094B::C - Perl compiler's C backend
2095
2096=head1 SYNOPSIS
2097
2098 perl -MO=C[,OPTIONS] foo.pl
2099
2100=head1 DESCRIPTION
2101
2102This compiler backend takes Perl source and generates C source code
2103corresponding to the internal structures that perl uses to run
2104your program. When the generated C source is compiled and run, it
2105cuts out the time which perl would have taken to load and parse
2106your program into its internal semi-compiled form. That means that
2107compiling with this backend will not help improve the runtime
2108execution speed of your program but may improve the start-up time.
2109Depending on the environment in which your program runs this may be
2110either a help or a hindrance.
2111
2112=head1 OPTIONS
2113
2114If there are any non-option arguments, they are taken to be
2115names of objects to be saved (probably doesn't work properly yet).
2116Without extra arguments, it saves the main program.
2117
2118=over 4
2119
2120=item B<-ofilename>
2121
2122Output to filename instead of STDOUT
2123
2124=item B<-v>
2125
2126Verbose compilation (currently gives a few compilation statistics).
2127
2128=item B<-->
2129
2130Force end of options
2131
2132=item B<-uPackname>
2133
2134Force apparently unused subs from package Packname to be compiled.
2135This allows programs to use eval "foo()" even when sub foo is never
2136seen to be used at compile time. The down side is that any subs which
2137really are never used also have code generated. This option is
2138necessary, for example, if you have a signal handler foo which you
2139initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
2140to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
2141options. The compiler tries to figure out which packages may possibly
2142have subs in which need compiling but the current version doesn't do
2143it very well. In particular, it is confused by nested packages (i.e.
2144of the form C<A::B>) where package C<A> does not contain any subs.
2145
2146=item B<-D>
2147
2148Debug options (concatenated or separate flags like C<perl -D>).
2149
2150=item B<-Do>
2151
2152OPs, prints each OP as it's processed
2153
2154=item B<-Dc>
2155
2156COPs, prints COPs as processed (incl. file & line num)
2157
2158=item B<-DA>
2159
2160prints AV information on saving
2161
2162=item B<-DC>
2163
2164prints CV information on saving
2165
2166=item B<-DM>
2167
2168prints MAGIC information on saving
2169
2170=item B<-f>
2171
2172Force options/optimisations on or off one at a time. You can explicitly
2173disable an option using B<-fno-option>. All options default to
2174B<disabled>.
2175
2176=over 4
2177
2178=item B<-fcog>
2179
2180Copy-on-grow: PVs declared and initialised statically.
2181
2182=item B<-fsave-data>
2183
2184Save package::DATA filehandles ( only available with PerlIO ).
2185
2186=item B<-fppaddr>
2187
2188Optimize the initialization of op_ppaddr.
2189
2190=item B<-fwarn-sv>
2191
2192Optimize the initialization of cop_warnings.
2193
2194=item B<-fuse-script-name>
2195
2196Use the script name instead of the program name as $0.
2197
2198=item B<-fsave-sig-hash>
2199
2200Save compile-time modifications to the %SIG hash.
2201
2202=back
2203
2204=item B<-On>
2205
2206Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
2207
2208=over 4
2209
2210=item B<-O0>
2211
2212Disable all optimizations.
2213
2214=item B<-O1>
2215
2216Enable B<-fcog>.
2217
2218=item B<-O2>
2219
2220Enable B<-fppaddr>, B<-fwarn-sv>.
2221
2222=back
2223
2224=item B<-llimit>
2225
2226Some C compilers impose an arbitrary limit on the length of string
2227constants (e.g. 2048 characters for Microsoft Visual C++). The
2228B<-llimit> options tells the C backend not to generate string literals
2229exceeding that limit.
2230
2231=back
2232
2233=head1 EXAMPLES
2234
2235 perl -MO=C,-ofoo.c foo.pl
2236 perl cc_harness -o foo foo.c
2237
2238Note that C<cc_harness> lives in the C<B> subdirectory of your perl
2239library directory. The utility called C<perlcc> may also be used to
2240help make use of this compiler.
2241
2242 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
2243
2244=head1 BUGS
2245
2246Plenty. Current status: experimental.
2247
2248=head1 AUTHOR
2249
2250Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
2251
2252=cut
Full OpenSPARC design & verification tarball including full HDL.