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