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