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.02'; 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, 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 $avflags = $av->AvFLAGS; 1186 $xpvavsect->add(sprintf("0, -1, -1, 0, 0.0, 0, Nullhv, 0, 0, 0x%x", 1187 $avflags)); 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 warn sprintf("saving AV 0x%x FILL=$fill AvFLAGS=0x%x", $$av, $avflags) 1194 if $debug_av; 1195 # XXX AVf_REAL is wrong test: need to save comppadlist but not stack 1196 #if ($fill > -1 && ($avflags & AVf_REAL)) { 1197 if ($fill > -1) { 1198 my @array = $av->ARRAY; 1199 if ($debug_av) { 1200 my $el; 1201 my $i = 0; 1202 foreach $el (@array) { 1203 warn sprintf("AV 0x%x[%d] = %s 0x%x\n", 1204 $$av, $i++, class($el), $$el); 1205 } 1206 } 1207# my @names = map($_->save, @array); 1208 # XXX Better ways to write loop? 1209 # Perhaps svp[0] = ...; svp[1] = ...; svp[2] = ...; 1210 # Perhaps I32 i = 0; svp[i++] = ...; svp[i++] = ...; svp[i++] = ...; 1211 1212 # micro optimization: op/pat.t ( and other code probably ) 1213 # has very large pads ( 20k/30k elements ) passing them to 1214 # ->add is a performance bottleneck: passing them as a 1215 # single string cuts runtime from 6min20sec to 40sec 1216 1217 # you want to keep this out of the no_split/split 1218 # map("\t*svp++ = (SV*)$_;", @names), 1219 my $acc = ''; 1220 foreach my $i ( 0..$#array ) { 1221 $acc .= "\t*svp++ = (SV*)" . $array[$i]->save . ";\n\t"; 1222 } 1223 $acc .= "\n"; 1224 1225 $init->no_split; 1226 $init->add("{", 1227 "\tSV **svp;", 1228 "\tAV *av = (AV*)&sv_list[$sv_list_index];", 1229 "\tav_extend(av, $fill);", 1230 "\tsvp = AvARRAY(av);" ); 1231 $init->add($acc); 1232 $init->add("\tAvFILLp(av) = $fill;", 1233 "}"); 1234 $init->split; 1235 # we really added a lot of lines ( B::C::InitSection->add 1236 # should really scan for \n, but that would slow 1237 # it down 1238 $init->inc_count( $#array ); 1239 } else { 1240 my $max = $av->MAX; 1241 $init->add("av_extend((AV*)&sv_list[$sv_list_index], $max);") 1242 if $max > -1; 1243 } 1244 return savesym($av, "(AV*)&sv_list[$sv_list_index]"); 1245} 1246 1247sub B::HV::save { 1248 my ($hv) = @_; 1249 my $sym = objsym($hv); 1250 return $sym if defined $sym; 1251 my $name = $hv->NAME; 1252 if ($name) { 1253 # It's a stash 1254 1255 # A perl bug means HvPMROOT isn't altered when a PMOP is freed. Usually 1256 # the only symptom is that sv_reset tries to reset the PMf_USED flag of 1257 # a trashed op but we look at the trashed op_type and segfault. 1258 #my $adpmroot = ${$hv->PMROOT}; 1259 my $adpmroot = 0; 1260 $decl->add("static HV *hv$hv_index;"); 1261 # XXX Beware of weird package names containing double-quotes, \n, ...? 1262 $init->add(qq[hv$hv_index = gv_stashpv("$name", TRUE);]); 1263 if ($adpmroot) { 1264 $init->add(sprintf("HvPMROOT(hv$hv_index) = (PMOP*)s\\_%x;", 1265 $adpmroot)); 1266 } 1267 $sym = savesym($hv, "hv$hv_index"); 1268 $hv_index++; 1269 return $sym; 1270 } 1271 # It's just an ordinary HV 1272 $xpvhvsect->add(sprintf("0, 0, %d, 0, 0.0, 0, Nullhv, %d, 0, 0, 0", 1273 $hv->MAX, $hv->RITER)); 1274 $svsect->add(sprintf("&xpvhv_list[%d], %lu, 0x%x", 1275 $xpvhvsect->index, $hv->REFCNT , $hv->FLAGS)); 1276 my $sv_list_index = $svsect->index; 1277 my @contents = $hv->ARRAY; 1278 if (@contents) { 1279 my $i; 1280 for ($i = 1; $i < @contents; $i += 2) { 1281 $contents[$i] = $contents[$i]->save; 1282 } 1283 $init->no_split; 1284 $init->add("{", "\tHV *hv = (HV*)&sv_list[$sv_list_index];"); 1285 while (@contents) { 1286 my ($key, $value) = splice(@contents, 0, 2); 1287 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", 1288 cstring($key),length(pack "a*",$key), 1289 $value, hash($key))); 1290# $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", 1291# cstring($key),length($key),$value, 0)); 1292 } 1293 $init->add("}"); 1294 $init->split; 1295 } 1296 $hv->save_magic(); 1297 return savesym($hv, "(HV*)&sv_list[$sv_list_index]"); 1298} 1299 1300sub B::IO::save_data { 1301 my( $io, $globname, @data ) = @_; 1302 my $data = join '', @data; 1303 1304 # XXX using $DATA might clobber it! 1305 my $sym = svref_2object( \\$data )->save; 1306 $init->add( split /\n/, <<CODE ); 1307 { 1308 GV* gv = (GV*)gv_fetchpv( "$globname", TRUE, SVt_PV ); 1309 SV* sv = $sym; 1310 GvSV( gv ) = sv; 1311 } 1312CODE 1313 # for PerlIO::scalar 1314 $use_xsloader = 1; 1315 $init->add_eval( sprintf 'open(%s, "<", $%s)', $globname, $globname ); 1316} 1317 1318sub B::IO::save { 1319 my ($io) = @_; 1320 my $sym = objsym($io); 1321 return $sym if defined $sym; 1322 my $pv = $io->PV; 1323 $pv = '' unless defined $pv; 1324 my $len = length($pv); 1325 $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", 1326 $len, $len+1, $io->IVX, $io->NVX, $io->LINES, 1327 $io->PAGE, $io->PAGE_LEN, $io->LINES_LEFT, 1328 cstring($io->TOP_NAME), cstring($io->FMT_NAME), 1329 cstring($io->BOTTOM_NAME), $io->SUBPROCESS, 1330 cchar($io->IoTYPE), $io->IoFLAGS)); 1331 $svsect->add(sprintf("&xpvio_list[%d], %lu, 0x%x", 1332 $xpviosect->index, $io->REFCNT , $io->FLAGS)); 1333 $sym = savesym($io, sprintf("(IO*)&sv_list[%d]", $svsect->index)); 1334 # deal with $x = *STDIN/STDOUT/STDERR{IO} 1335 my $perlio_func; 1336 foreach ( qw(stdin stdout stderr) ) { 1337 $io->IsSTD($_) and $perlio_func = $_; 1338 } 1339 if( $perlio_func ) { 1340 $init->add( "IoIFP(${sym})=PerlIO_${perlio_func}();" ); 1341 $init->add( "IoOFP(${sym})=PerlIO_${perlio_func}();" ); 1342 } 1343 1344 my ($field, $fsym); 1345 foreach $field (qw(TOP_GV FMT_GV BOTTOM_GV)) { 1346 $fsym = $io->$field(); 1347 if ($$fsym) { 1348 $init->add(sprintf("Io$field($sym) = (GV*)s\\_%x;", $$fsym)); 1349 $fsym->save; 1350 } 1351 } 1352 $io->save_magic; 1353 return $sym; 1354} 1355 1356sub B::SV::save { 1357 my $sv = shift; 1358 # This is where we catch an honest-to-goodness Nullsv (which gets 1359 # blessed into B::SV explicitly) and any stray erroneous SVs. 1360 return 0 unless $$sv; 1361 confess sprintf("cannot save that type of SV: %s (0x%x)\n", 1362 class($sv), $$sv); 1363} 1364 1365sub output_all { 1366 my $init_name = shift; 1367 my $section; 1368 my @sections = ($opsect, $unopsect, $binopsect, $logopsect, $condopsect, 1369 $listopsect, $pmopsect, $svopsect, $padopsect, $pvopsect, 1370 $loopsect, $copsect, $svsect, $xpvsect, 1371 $xpvavsect, $xpvhvsect, $xpvcvsect, $xpvivsect, $xpvnvsect, 1372 $xpvmgsect, $xpvlvsect, $xrvsect, $xpvbmsect, $xpviosect); 1373 $symsect->output(\*STDOUT, "#define %s\n"); 1374 print "\n"; 1375 output_declarations(); 1376 foreach $section (@sections) { 1377 my $lines = $section->index + 1; 1378 if ($lines) { 1379 my $name = $section->name; 1380 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); 1381 print "Static $typename ${name}_list[$lines];\n"; 1382 } 1383 } 1384 # XXX hack for when Perl accesses PVX of GVs 1385 print 'Static char emptystring[] = "\0";'; 1386 1387 $decl->output(\*STDOUT, "%s\n"); 1388 print "\n"; 1389 foreach $section (@sections) { 1390 my $lines = $section->index + 1; 1391 if ($lines) { 1392 my $name = $section->name; 1393 my $typename = ($name eq "xpvcv") ? "XPVCV_or_similar" : uc($name); 1394 printf "static %s %s_list[%u] = {\n", $typename, $name, $lines; 1395 $section->output(\*STDOUT, "\t{ %s }, /* %d */\n"); 1396 print "};\n\n"; 1397 } 1398 } 1399 1400 $init->output(\*STDOUT, "\t%s\n", $init_name ); 1401 if ($verbose) { 1402 warn compile_stats(); 1403 warn "NULLOP count: $nullop_count\n"; 1404 } 1405} 1406 1407sub output_declarations { 1408 print <<'EOT'; 1409#ifdef BROKEN_STATIC_REDECL 1410#define Static extern 1411#else 1412#define Static static 1413#endif /* BROKEN_STATIC_REDECL */ 1414 1415#ifdef BROKEN_UNION_INIT 1416/* 1417 * Cribbed from cv.h with ANY (a union) replaced by void*. 1418 * Some pre-Standard compilers can't cope with initialising unions. Ho hum. 1419 */ 1420typedef struct { 1421 char * xpv_pv; /* pointer to malloced string */ 1422 STRLEN xpv_cur; /* length of xp_pv as a C string */ 1423 STRLEN xpv_len; /* allocated size */ 1424 IV xof_off; /* integer value */ 1425 NV xnv_nv; /* numeric value, if any */ 1426 MAGIC* xmg_magic; /* magic for scalar array */ 1427 HV* xmg_stash; /* class package */ 1428 1429 HV * xcv_stash; 1430 OP * xcv_start; 1431 OP * xcv_root; 1432 void (*xcv_xsub) (pTHX_ CV*); 1433 ANY xcv_xsubany; 1434 GV * xcv_gv; 1435 char * xcv_file; 1436 long xcv_depth; /* >= 2 indicates recursive call */ 1437 AV * xcv_padlist; 1438 CV * xcv_outside; 1439#ifdef USE_5005THREADS 1440 perl_mutex *xcv_mutexp; 1441 struct perl_thread *xcv_owner; /* current owner thread */ 1442#endif /* USE_5005THREADS */ 1443 cv_flags_t xcv_flags; 1444 U32 xcv_outside_seq; /* the COP sequence (at the point of our 1445 * compilation) in the lexically enclosing 1446 * sub */ 1447} XPVCV_or_similar; 1448#define ANYINIT(i) i 1449#else 1450#define XPVCV_or_similar XPVCV 1451#define ANYINIT(i) {i} 1452#endif /* BROKEN_UNION_INIT */ 1453#define Nullany ANYINIT(0) 1454 1455#define UNUSED 0 1456#define sym_0 0 1457EOT 1458 print "static GV *gv_list[$gv_index];\n" if $gv_index; 1459 print "\n"; 1460} 1461 1462 1463sub output_boilerplate { 1464 print <<'EOT'; 1465#include "EXTERN.h" 1466#include "perl.h" 1467#include "XSUB.h" 1468 1469/* Workaround for mapstart: the only op which needs a different ppaddr */ 1470#undef Perl_pp_mapstart 1471#define Perl_pp_mapstart Perl_pp_grepstart 1472#undef OP_MAPSTART 1473#define OP_MAPSTART OP_GREPSTART 1474#define XS_DynaLoader_boot_DynaLoader boot_DynaLoader 1475EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); 1476 1477static void xs_init (pTHX); 1478static void dl_init (pTHX); 1479static PerlInterpreter *my_perl; 1480EOT 1481} 1482 1483sub init_op_addr { 1484 my( $op_type, $num ) = @_; 1485 my $op_list = $op_type."_list"; 1486 1487 $init->add( split /\n/, <<EOT ); 1488 { 1489 int i; 1490 1491 for( i = 0; i < ${num}; ++i ) 1492 { 1493 ${op_list}\[i].op_ppaddr = PL_ppaddr[INT2PTR(int,${op_list}\[i].op_ppaddr)]; 1494 } 1495 } 1496EOT 1497} 1498 1499sub init_op_warn { 1500 my( $op_type, $num ) = @_; 1501 my $op_list = $op_type."_list"; 1502 1503 # for resons beyond imagination, MSVC5 considers pWARN_ALL non-const 1504 $init->add( split /\n/, <<EOT ); 1505 { 1506 int i; 1507 1508 for( i = 0; i < ${num}; ++i ) 1509 { 1510 switch( (int)(${op_list}\[i].cop_warnings) ) 1511 { 1512 case 1: 1513 ${op_list}\[i].cop_warnings = pWARN_ALL; 1514 break; 1515 case 2: 1516 ${op_list}\[i].cop_warnings = pWARN_NONE; 1517 break; 1518 case 3: 1519 ${op_list}\[i].cop_warnings = pWARN_STD; 1520 break; 1521 default: 1522 break; 1523 } 1524 } 1525 } 1526EOT 1527} 1528 1529sub output_main { 1530 print <<'EOT'; 1531/* if USE_IMPLICIT_SYS, we need a 'real' exit */ 1532#if defined(exit) 1533#undef exit 1534#endif 1535 1536int 1537main(int argc, char **argv, char **env) 1538{ 1539 int exitstatus; 1540 int i; 1541 char **fakeargv; 1542 GV* tmpgv; 1543 SV* tmpsv; 1544 int options_count; 1545 1546 PERL_SYS_INIT3(&argc,&argv,&env); 1547 1548 if (!PL_do_undump) { 1549 my_perl = perl_alloc(); 1550 if (!my_perl) 1551 exit(1); 1552 perl_construct( my_perl ); 1553 PL_perl_destruct_level = 0; 1554 } 1555EOT 1556 if( $ithreads ) { 1557 # XXX init free elems! 1558 my $pad_len = regex_padav->FILL + 1 - 1; # first is an avref 1559 1560 print <<EOT; 1561#ifdef USE_ITHREADS 1562 for( i = 0; i < $pad_len; ++i ) { 1563 av_push( PL_regex_padav, newSViv(0) ); 1564 } 1565 PL_regex_pad = AvARRAY( PL_regex_padav ); 1566#endif 1567EOT 1568 } 1569 1570 print <<'EOT'; 1571#ifdef CSH 1572 if (!PL_cshlen) 1573 PL_cshlen = strlen(PL_cshname); 1574#endif 1575 1576#ifdef ALLOW_PERL_OPTIONS 1577#define EXTRA_OPTIONS 3 1578#else 1579#define EXTRA_OPTIONS 4 1580#endif /* ALLOW_PERL_OPTIONS */ 1581 New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *); 1582 1583 fakeargv[0] = argv[0]; 1584 fakeargv[1] = "-e"; 1585 fakeargv[2] = ""; 1586 options_count = 3; 1587EOT 1588 # honour -T 1589 print <<EOT; 1590 if( ${^TAINT} ) { 1591 fakeargv[options_count] = "-T"; 1592 ++options_count; 1593 } 1594EOT 1595 print <<'EOT'; 1596#ifndef ALLOW_PERL_OPTIONS 1597 fakeargv[options_count] = "--"; 1598 ++options_count; 1599#endif /* ALLOW_PERL_OPTIONS */ 1600 for (i = 1; i < argc; i++) 1601 fakeargv[i + options_count - 1] = argv[i]; 1602 fakeargv[argc + options_count - 1] = 0; 1603 1604 exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1, 1605 fakeargv, NULL); 1606 1607 if (exitstatus) 1608 exit( exitstatus ); 1609 1610 TAINT; 1611EOT 1612 1613 if( $use_perl_script_name ) { 1614 my $dollar_0 = $0; 1615 $dollar_0 =~ s/\\/\\\\/g; 1616 $dollar_0 = '"' . $dollar_0 . '"'; 1617 1618 print <<EOT; 1619 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */ 1620 tmpsv = GvSV(tmpgv); 1621 sv_setpv(tmpsv, ${dollar_0}); 1622 SvSETMAGIC(tmpsv); 1623 } 1624EOT 1625 } 1626 else { 1627 print <<EOT; 1628 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* $0 */ 1629 tmpsv = GvSV(tmpgv); 1630 sv_setpv(tmpsv, argv[0]); 1631 SvSETMAGIC(tmpsv); 1632 } 1633EOT 1634 } 1635 1636 print <<'EOT'; 1637 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */ 1638 tmpsv = GvSV(tmpgv); 1639#ifdef WIN32 1640 sv_setpv(tmpsv,"perl.exe"); 1641#else 1642 sv_setpv(tmpsv,"perl"); 1643#endif 1644 SvSETMAGIC(tmpsv); 1645 } 1646 1647 TAINT_NOT; 1648 1649 /* PL_main_cv = PL_compcv; */ 1650 PL_compcv = 0; 1651 1652 exitstatus = perl_init(); 1653 if (exitstatus) 1654 exit( exitstatus ); 1655 dl_init(aTHX); 1656 1657 exitstatus = perl_run( my_perl ); 1658 1659 perl_destruct( my_perl ); 1660 perl_free( my_perl ); 1661 1662 PERL_SYS_TERM(); 1663 1664 exit( exitstatus ); 1665} 1666 1667/* yanked from perl.c */ 1668static void 1669xs_init(pTHX) 1670{ 1671 char *file = __FILE__; 1672 dTARG; 1673 dSP; 1674EOT 1675 print "\n#ifdef USE_DYNAMIC_LOADING"; 1676 print qq/\n\tnewXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);/; 1677 print "\n#endif\n" ; 1678 # delete $xsub{'DynaLoader'}; 1679 delete $xsub{'UNIVERSAL'}; 1680 print("/* bootstrapping code*/\n\tSAVETMPS;\n"); 1681 print("\ttarg=sv_newmortal();\n"); 1682 print "#ifdef USE_DYNAMIC_LOADING\n"; 1683 print "\tPUSHMARK(sp);\n"; 1684 print qq/\tXPUSHp("DynaLoader",strlen("DynaLoader"));\n/; 1685 print qq/\tPUTBACK;\n/; 1686 print "\tboot_DynaLoader(aTHX_ NULL);\n"; 1687 print qq/\tSPAGAIN;\n/; 1688 print "#endif\n"; 1689 foreach my $stashname (keys %xsub){ 1690 if ($xsub{$stashname} !~ m/Dynamic/ ) { 1691 my $stashxsub=$stashname; 1692 $stashxsub =~ s/::/__/g; 1693 print "\tPUSHMARK(sp);\n"; 1694 print qq/\tXPUSHp("$stashname",strlen("$stashname"));\n/; 1695 print qq/\tPUTBACK;\n/; 1696 print "\tboot_$stashxsub(aTHX_ NULL);\n"; 1697 print qq/\tSPAGAIN;\n/; 1698 } 1699 } 1700 print("\tFREETMPS;\n/* end bootstrapping code */\n"); 1701 print "}\n"; 1702 1703print <<'EOT'; 1704static void 1705dl_init(pTHX) 1706{ 1707 char *file = __FILE__; 1708 dTARG; 1709 dSP; 1710EOT 1711 print("/* Dynamicboot strapping code*/\n\tSAVETMPS;\n"); 1712 print("\ttarg=sv_newmortal();\n"); 1713 foreach my $stashname (@DynaLoader::dl_modules) { 1714 warn "Loaded $stashname\n"; 1715 if (exists($xsub{$stashname}) && $xsub{$stashname} =~ m/Dynamic/) { 1716 my $stashxsub=$stashname; 1717 $stashxsub =~ s/::/__/g; 1718 print "\tPUSHMARK(sp);\n"; 1719 print qq/\tXPUSHp("$stashname",/,length($stashname),qq/);\n/; 1720 print qq/\tPUTBACK;\n/; 1721 print "#ifdef USE_DYNAMIC_LOADING\n"; 1722 warn "bootstrapping $stashname added to xs_init\n"; 1723 if( $xsub{$stashname} eq 'Dynamic' ) { 1724 print qq/\tperl_call_method("bootstrap",G_DISCARD);\n/; 1725 } 1726 else { 1727 print qq/\tperl_call_pv("XSLoader::load",G_DISCARD);\n/; 1728 } 1729 print "#else\n"; 1730 print "\tboot_$stashxsub(aTHX_ NULL);\n"; 1731 print "#endif\n"; 1732 print qq/\tSPAGAIN;\n/; 1733 } 1734 } 1735 print("\tFREETMPS;\n/* end Dynamic bootstrapping code */\n"); 1736 print "}\n"; 1737} 1738sub dump_symtable { 1739 # For debugging 1740 my ($sym, $val); 1741 warn "----Symbol table:\n"; 1742 while (($sym, $val) = each %symtable) { 1743 warn "$sym => $val\n"; 1744 } 1745 warn "---End of symbol table\n"; 1746} 1747 1748sub save_object { 1749 my $sv; 1750 foreach $sv (@_) { 1751 svref_2object($sv)->save; 1752 } 1753} 1754 1755sub Dummy_BootStrap { } 1756 1757sub B::GV::savecv 1758{ 1759 my $gv = shift; 1760 my $package=$gv->STASH->NAME; 1761 my $name = $gv->NAME; 1762 my $cv = $gv->CV; 1763 my $sv = $gv->SV; 1764 my $av = $gv->AV; 1765 my $hv = $gv->HV; 1766 1767 my $fullname = $gv->STASH->NAME . "::" . $gv->NAME; 1768 1769 # We may be looking at this package just because it is a branch in the 1770 # symbol table which is on the path to a package which we need to save 1771 # e.g. this is 'Getopt' and we need to save 'Getopt::Long' 1772 # 1773 return unless ($unused_sub_packages{$package}); 1774 return unless ($$cv || $$av || $$sv || $$hv); 1775 $gv->save; 1776} 1777 1778sub mark_package 1779{ 1780 my $package = shift; 1781 unless ($unused_sub_packages{$package}) 1782 { 1783 no strict 'refs'; 1784 $unused_sub_packages{$package} = 1; 1785 if (defined @{$package.'::ISA'}) 1786 { 1787 foreach my $isa (@{$package.'::ISA'}) 1788 { 1789 if ($isa eq 'DynaLoader') 1790 { 1791 unless (defined(&{$package.'::bootstrap'})) 1792 { 1793 warn "Forcing bootstrap of $package\n"; 1794 eval { $package->bootstrap }; 1795 } 1796 } 1797# else 1798 { 1799 unless ($unused_sub_packages{$isa}) 1800 { 1801 warn "$isa saved (it is in $package\'s \@ISA)\n"; 1802 mark_package($isa); 1803 } 1804 } 1805 } 1806 } 1807 } 1808 return 1; 1809} 1810 1811sub should_save 1812{ 1813 no strict qw(vars refs); 1814 my $package = shift; 1815 $package =~ s/::$//; 1816 return $unused_sub_packages{$package} = 0 if ($package =~ /::::/); # skip ::::ISA::CACHE etc. 1817 # warn "Considering $package\n";#debug 1818 foreach my $u (grep($unused_sub_packages{$_},keys %unused_sub_packages)) 1819 { 1820 # If this package is a prefix to something we are saving, traverse it 1821 # but do not mark it for saving if it is not already 1822 # e.g. to get to Getopt::Long we need to traverse Getopt but need 1823 # not save Getopt 1824 return 1 if ($u =~ /^$package\:\:/); 1825 } 1826 if (exists $unused_sub_packages{$package}) 1827 { 1828 # warn "Cached $package is ".$unused_sub_packages{$package}."\n"; 1829 delete_unsaved_hashINC($package) unless $unused_sub_packages{$package} ; 1830 return $unused_sub_packages{$package}; 1831 } 1832 # Omit the packages which we use (and which cause grief 1833 # because of fancy "goto &$AUTOLOAD" stuff). 1834 # XXX Surely there must be a nicer way to do this. 1835 if ($package eq "FileHandle" || $package eq "Config" || 1836 $package eq "SelectSaver" || $package =~/^(B|IO)::/) 1837 { 1838 delete_unsaved_hashINC($package); 1839 return $unused_sub_packages{$package} = 0; 1840 } 1841 # Now see if current package looks like an OO class this is probably too strong. 1842 foreach my $m (qw(new DESTROY TIESCALAR TIEARRAY TIEHASH TIEHANDLE)) 1843 { 1844 if (UNIVERSAL::can($package, $m)) 1845 { 1846 warn "$package has method $m: saving package\n";#debug 1847 return mark_package($package); 1848 } 1849 } 1850 delete_unsaved_hashINC($package); 1851 return $unused_sub_packages{$package} = 0; 1852} 1853sub delete_unsaved_hashINC{ 1854 my $packname=shift; 1855 $packname =~ s/\:\:/\//g; 1856 $packname .= '.pm'; 1857# warn "deleting $packname" if $INC{$packname} ;# debug 1858 delete $INC{$packname}; 1859} 1860sub walkpackages 1861{ 1862 my ($symref, $recurse, $prefix) = @_; 1863 my $sym; 1864 my $ref; 1865 no strict 'vars'; 1866 $prefix = '' unless defined $prefix; 1867 while (($sym, $ref) = each %$symref) 1868 { 1869 local(*glob); 1870 *glob = $ref; 1871 if ($sym =~ /::$/) 1872 { 1873 $sym = $prefix . $sym; 1874 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) 1875 { 1876 walkpackages(\%glob, $recurse, $sym); 1877 } 1878 } 1879 } 1880} 1881 1882 1883sub save_unused_subs 1884{ 1885 no strict qw(refs); 1886 &descend_marked_unused; 1887 warn "Prescan\n"; 1888 walkpackages(\%{"main::"}, sub { should_save($_[0]); return 1 }); 1889 warn "Saving methods\n"; 1890 walksymtable(\%{"main::"}, "savecv", \&should_save); 1891} 1892 1893sub save_context 1894{ 1895 my $curpad_nam = (comppadlist->ARRAY)[0]->save; 1896 my $curpad_sym = (comppadlist->ARRAY)[1]->save; 1897 my $inc_hv = svref_2object(\%INC)->save; 1898 my $inc_av = svref_2object(\@INC)->save; 1899 my $amagic_generate= amagic_generation; 1900 $init->add( "PL_curpad = AvARRAY($curpad_sym);", 1901 "GvHV(PL_incgv) = $inc_hv;", 1902 "GvAV(PL_incgv) = $inc_av;", 1903 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));", 1904 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));", 1905 "PL_amagic_generation= $amagic_generate;" ); 1906} 1907 1908sub descend_marked_unused { 1909 foreach my $pack (keys %unused_sub_packages) 1910 { 1911 mark_package($pack); 1912 } 1913} 1914 1915sub save_main { 1916 # this is mainly for the test suite 1917 my $warner = $SIG{__WARN__}; 1918 local $SIG{__WARN__} = sub { print STDERR @_ }; 1919 1920 warn "Starting compile\n"; 1921 warn "Walking tree\n"; 1922 seek(STDOUT,0,0); #exclude print statements in BEGIN{} into output 1923 walkoptree(main_root, "save"); 1924 warn "done main optree, walking symtable for extras\n" if $debug_cv; 1925 save_unused_subs(); 1926 # XSLoader was used, force saving of XSLoader::load 1927 if( $use_xsloader ) { 1928 my $cv = svref_2object( \&XSLoader::load ); 1929 $cv->save; 1930 } 1931 # save %SIG ( in case it was set in a BEGIN block ) 1932 if( $save_sig ) { 1933 local $SIG{__WARN__} = $warner; 1934 $init->no_split; 1935 $init->add("{", "\tHV* hv = get_hv(\"main::SIG\",1);" ); 1936 foreach my $k ( keys %SIG ) { 1937 next unless ref $SIG{$k}; 1938 my $cv = svref_2object( \$SIG{$k} ); 1939 my $sv = $cv->save; 1940 $init->add('{',sprintf 'SV* sv = (SV*)%s;', $sv ); 1941 $init->add(sprintf("\thv_store(hv, %s, %u, %s, %s);", 1942 cstring($k),length(pack "a*",$k), 1943 'sv', hash($k))); 1944 $init->add('mg_set(sv);','}'); 1945 } 1946 $init->add('}'); 1947 $init->split; 1948 } 1949 # honour -w 1950 $init->add( sprintf " PL_dowarn = ( %s ) ? G_WARN_ON : G_WARN_OFF;", $^W ); 1951 # 1952 my $init_av = init_av->save; 1953 my $end_av = end_av->save; 1954 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}), 1955 sprintf("PL_main_start = s\\_%x;", ${main_start()}), 1956 "PL_initav = (AV *) $init_av;", 1957 "PL_endav = (AV*) $end_av;"); 1958 save_context(); 1959 # init op addrs ( must be the last action, otherwise 1960 # some ops might not be initialized 1961 if( $optimize_ppaddr ) { 1962 foreach my $i ( @op_sections ) { 1963 my $section = $$i; 1964 next unless $section->index >= 0; 1965 init_op_addr( $section->name, $section->index + 1); 1966 } 1967 } 1968 init_op_warn( $copsect->name, $copsect->index + 1) 1969 if $optimize_warn_sv && $copsect->index >= 0; 1970 1971 warn "Writing output\n"; 1972 output_boilerplate(); 1973 print "\n"; 1974 output_all("perl_init"); 1975 print "\n"; 1976 output_main(); 1977} 1978 1979sub init_sections { 1980 my @sections = (decl => \$decl, sym => \$symsect, 1981 binop => \$binopsect, condop => \$condopsect, 1982 cop => \$copsect, padop => \$padopsect, 1983 listop => \$listopsect, logop => \$logopsect, 1984 loop => \$loopsect, op => \$opsect, pmop => \$pmopsect, 1985 pvop => \$pvopsect, svop => \$svopsect, unop => \$unopsect, 1986 sv => \$svsect, xpv => \$xpvsect, xpvav => \$xpvavsect, 1987 xpvhv => \$xpvhvsect, xpvcv => \$xpvcvsect, 1988 xpviv => \$xpvivsect, xpvnv => \$xpvnvsect, 1989 xpvmg => \$xpvmgsect, xpvlv => \$xpvlvsect, 1990 xrv => \$xrvsect, xpvbm => \$xpvbmsect, 1991 xpvio => \$xpviosect); 1992 my ($name, $sectref); 1993 while (($name, $sectref) = splice(@sections, 0, 2)) { 1994 $$sectref = new B::C::Section $name, \%symtable, 0; 1995 } 1996 $init = new B::C::InitSection 'init', \%symtable, 0; 1997} 1998 1999sub mark_unused 2000{ 2001 my ($arg,$val) = @_; 2002 $unused_sub_packages{$arg} = $val; 2003} 2004 2005sub compile { 2006 my @options = @_; 2007 my ($option, $opt, $arg); 2008 my @eval_at_startup; 2009 my %option_map = ( 'cog' => \$pv_copy_on_grow, 2010 'save-data' => \$save_data_fh, 2011 'ppaddr' => \$optimize_ppaddr, 2012 'warn-sv' => \$optimize_warn_sv, 2013 'use-script-name' => \$use_perl_script_name, 2014 'save-sig-hash' => \$save_sig, 2015 ); 2016 my %optimization_map = ( 0 => [ qw() ], # special case 2017 1 => [ qw(-fcog) ], 2018 2 => [ qw(-fwarn-sv -fppaddr) ], 2019 ); 2020 OPTION: 2021 while ($option = shift @options) { 2022 if ($option =~ /^-(.)(.*)/) { 2023 $opt = $1; 2024 $arg = $2; 2025 } else { 2026 unshift @options, $option; 2027 last OPTION; 2028 } 2029 if ($opt eq "-" && $arg eq "-") { 2030 shift @options; 2031 last OPTION; 2032 } 2033 if ($opt eq "w") { 2034 $warn_undefined_syms = 1; 2035 } elsif ($opt eq "D") { 2036 $arg ||= shift @options; 2037 foreach $arg (split(//, $arg)) { 2038 if ($arg eq "o") { 2039 B->debug(1); 2040 } elsif ($arg eq "c") { 2041 $debug_cops = 1; 2042 } elsif ($arg eq "A") { 2043 $debug_av = 1; 2044 } elsif ($arg eq "C") { 2045 $debug_cv = 1; 2046 } elsif ($arg eq "M") { 2047 $debug_mg = 1; 2048 } else { 2049 warn "ignoring unknown debug option: $arg\n"; 2050 } 2051 } 2052 } elsif ($opt eq "o") { 2053 $arg ||= shift @options; 2054 open(STDOUT, ">$arg") or return "$arg: $!\n"; 2055 } elsif ($opt eq "v") { 2056 $verbose = 1; 2057 } elsif ($opt eq "u") { 2058 $arg ||= shift @options; 2059 mark_unused($arg,undef); 2060 } elsif ($opt eq "f") { 2061 $arg ||= shift @options; 2062 $arg =~ m/(no-)?(.*)/; 2063 my $no = defined($1) && $1 eq 'no-'; 2064 $arg = $no ? $2 : $arg; 2065 if( exists $option_map{$arg} ) { 2066 ${$option_map{$arg}} = !$no; 2067 } else { 2068 die "Invalid optimization '$arg'"; 2069 } 2070 } elsif ($opt eq "O") { 2071 $arg = 1 if $arg eq ""; 2072 my @opt; 2073 foreach my $i ( 1 .. $arg ) { 2074 push @opt, @{$optimization_map{$i}} 2075 if exists $optimization_map{$i}; 2076 } 2077 unshift @options, @opt; 2078 } elsif ($opt eq "e") { 2079 push @eval_at_startup, $arg; 2080 } elsif ($opt eq "l") { 2081 $max_string_len = $arg; 2082 } 2083 } 2084 init_sections(); 2085 foreach my $i ( @eval_at_startup ) { 2086 $init->add_eval( $i ); 2087 } 2088 if (@options) { 2089 return sub { 2090 my $objname; 2091 foreach $objname (@options) { 2092 eval "save_object(\\$objname)"; 2093 } 2094 output_all(); 2095 } 2096 } else { 2097 return sub { save_main() }; 2098 } 2099} 2100 21011; 2102 2103__END__ 2104 2105=head1 NAME 2106 2107B::C - Perl compiler's C backend 2108 2109=head1 SYNOPSIS 2110 2111 perl -MO=C[,OPTIONS] foo.pl 2112 2113=head1 DESCRIPTION 2114 2115This compiler backend takes Perl source and generates C source code 2116corresponding to the internal structures that perl uses to run 2117your program. When the generated C source is compiled and run, it 2118cuts out the time which perl would have taken to load and parse 2119your program into its internal semi-compiled form. That means that 2120compiling with this backend will not help improve the runtime 2121execution speed of your program but may improve the start-up time. 2122Depending on the environment in which your program runs this may be 2123either a help or a hindrance. 2124 2125=head1 OPTIONS 2126 2127If there are any non-option arguments, they are taken to be 2128names of objects to be saved (probably doesn't work properly yet). 2129Without extra arguments, it saves the main program. 2130 2131=over 4 2132 2133=item B<-ofilename> 2134 2135Output to filename instead of STDOUT 2136 2137=item B<-v> 2138 2139Verbose compilation (currently gives a few compilation statistics). 2140 2141=item B<--> 2142 2143Force end of options 2144 2145=item B<-uPackname> 2146 2147Force apparently unused subs from package Packname to be compiled. 2148This allows programs to use eval "foo()" even when sub foo is never 2149seen to be used at compile time. The down side is that any subs which 2150really are never used also have code generated. This option is 2151necessary, for example, if you have a signal handler foo which you 2152initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just 2153to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u> 2154options. The compiler tries to figure out which packages may possibly 2155have subs in which need compiling but the current version doesn't do 2156it very well. In particular, it is confused by nested packages (i.e. 2157of the form C<A::B>) where package C<A> does not contain any subs. 2158 2159=item B<-D> 2160 2161Debug options (concatenated or separate flags like C<perl -D>). 2162 2163=item B<-Do> 2164 2165OPs, prints each OP as it's processed 2166 2167=item B<-Dc> 2168 2169COPs, prints COPs as processed (incl. file & line num) 2170 2171=item B<-DA> 2172 2173prints AV information on saving 2174 2175=item B<-DC> 2176 2177prints CV information on saving 2178 2179=item B<-DM> 2180 2181prints MAGIC information on saving 2182 2183=item B<-f> 2184 2185Force options/optimisations on or off one at a time. You can explicitly 2186disable an option using B<-fno-option>. All options default to 2187B<disabled>. 2188 2189=over 4 2190 2191=item B<-fcog> 2192 2193Copy-on-grow: PVs declared and initialised statically. 2194 2195=item B<-fsave-data> 2196 2197Save package::DATA filehandles ( only available with PerlIO ). 2198 2199=item B<-fppaddr> 2200 2201Optimize the initialization of op_ppaddr. 2202 2203=item B<-fwarn-sv> 2204 2205Optimize the initialization of cop_warnings. 2206 2207=item B<-fuse-script-name> 2208 2209Use the script name instead of the program name as $0. 2210 2211=item B<-fsave-sig-hash> 2212 2213Save compile-time modifications to the %SIG hash. 2214 2215=back 2216 2217=item B<-On> 2218 2219Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>. 2220 2221=over 4 2222 2223=item B<-O0> 2224 2225Disable all optimizations. 2226 2227=item B<-O1> 2228 2229Enable B<-fcog>. 2230 2231=item B<-O2> 2232 2233Enable B<-fppaddr>, B<-fwarn-sv>. 2234 2235=back 2236 2237=item B<-llimit> 2238 2239Some C compilers impose an arbitrary limit on the length of string 2240constants (e.g. 2048 characters for Microsoft Visual C++). The 2241B<-llimit> options tells the C backend not to generate string literals 2242exceeding that limit. 2243 2244=back 2245 2246=head1 EXAMPLES 2247 2248 perl -MO=C,-ofoo.c foo.pl 2249 perl cc_harness -o foo foo.c 2250 2251Note that C<cc_harness> lives in the C<B> subdirectory of your perl 2252library directory. The utility called C<perlcc> may also be used to 2253help make use of this compiler. 2254 2255 perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null 2256 2257=head1 BUGS 2258 2259Plenty. Current status: experimental. 2260 2261=head1 AUTHOR 2262 2263Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> 2264 2265=cut 2266