This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
more s/s_/s!/ etc.
[perl5.git] / ext / B / B / CC.pm
CommitLineData
a798dbf2
MB
1# CC.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#
8package B::CC;
9use strict;
10use B qw(main_start main_root class comppadlist peekop svref_2object
4c1f658f
NIS
11 timing_info init_av
12 OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
13 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
14 OPpDEREF OPpFLIP_LINENUM G_ARRAY
15 CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
16 );
0cc1d052 17use B::C qw(save_unused_subs objsym init_sections mark_unused
a798dbf2
MB
18 output_all output_boilerplate output_main);
19use B::Bblock qw(find_leaders);
20use B::Stackobj qw(:types :flags);
21
22# These should probably be elsewhere
23# Flags for $op->flags
a798dbf2
MB
24
25my $module; # module name (when compiled with -m)
26my %done; # hash keyed by $$op of leaders of basic blocks
27 # which have already been done.
28my $leaders; # ref to hash of basic block leaders. Keys are $$op
29 # addresses, values are the $op objects themselves.
30my @bblock_todo; # list of leaders of basic blocks that need visiting
31 # sometime.
32my @cc_todo; # list of tuples defining what PP code needs to be
33 # saved (e.g. CV, main or PMOP repl code). Each tuple
34 # is [$name, $root, $start, @padlist]. PMOP repl code
35 # tuples inherit padlist.
36my @stack; # shadows perl's stack when contents are known.
37 # Values are objects derived from class B::Stackobj
38my @pad; # Lexicals in current pad as Stackobj-derived objects
39my @padlist; # Copy of current padlist so PMOP repl code can find it
40my @cxstack; # Shadows the (compile-time) cxstack for next,last,redo
41my $jmpbuf_ix = 0; # Next free index for dynamically allocated jmpbufs
42my %constobj; # OP_CONST constants as Stackobj-derived objects
43 # keyed by $$sv.
44my $need_freetmps = 0; # We may postpone FREETMPS to the end of each basic
45 # block or even to the end of each loop of blocks,
46 # depending on optimisation options.
47my $know_op = 0; # Set when C variable op already holds the right op
48 # (from an immediately preceding DOOP(ppname)).
49my $errors = 0; # Number of errors encountered
50my %skip_stack; # Hash of PP names which don't need write_back_stack
51my %skip_lexicals; # Hash of PP names which don't need write_back_lexicals
52my %skip_invalidate; # Hash of PP names which don't need invalidate_lexicals
53my %ignore_op; # Hash of ops which do nothing except returning op_next
df2464c8 54my %need_curcop; # Hash of ops which need PL_curcop
a798dbf2
MB
55
56BEGIN {
57 foreach (qw(pp_scalar pp_regcmaybe pp_lineseq pp_scope pp_null)) {
58 $ignore_op{$_} = 1;
59 }
60}
61
a798dbf2
MB
62my ($module_name);
63my ($debug_op, $debug_stack, $debug_cxstack, $debug_pad, $debug_runtime,
64 $debug_shadow, $debug_queue, $debug_lineno, $debug_timings);
65
66# Optimisation options. On the command line, use hyphens instead of
67# underscores for compatibility with gcc-style options. We use
68# underscores here because they are OK in (strict) barewords.
69my ($freetmps_each_bblock, $freetmps_each_loop, $omit_taint);
70my %optimise = (freetmps_each_bblock => \$freetmps_each_bblock,
71 freetmps_each_loop => \$freetmps_each_loop,
72 omit_taint => \$omit_taint);
73# perl patchlevel to generate code for (defaults to current patchlevel)
74my $patchlevel = int(0.5 + 1000 * ($] - 5));
75
76# Could rewrite push_runtime() and output_runtime() to use a
77# temporary file if memory is at a premium.
78my $ppname; # name of current fake PP function
79my $runtime_list_ref;
80my $declare_ref; # Hash ref keyed by C variable type of declarations.
81
82my @pp_list; # list of [$ppname, $runtime_list_ref, $declare_ref]
83 # tuples to be written out.
84
85my ($init, $decl);
86
87sub init_hash { map { $_ => 1 } @_ }
88
89#
90# Initialise the hashes for the default PP functions where we can avoid
91# either write_back_stack, write_back_lexicals or invalidate_lexicals.
92#
93%skip_lexicals = init_hash qw(pp_enter pp_enterloop);
94%skip_invalidate = init_hash qw(pp_enter pp_enterloop);
df2464c8 95%need_curcop = init_hash qw(pp_rv2gv pp_bless pp_repeat pp_sort pp_caller pp_reset pp_rv2cv pp_entereval pp_require pp_dofile pp_entertry pp_enterloop pp_enteriter );
a798dbf2
MB
96
97sub debug {
98 if ($debug_runtime) {
99 warn(@_);
100 } else {
101 runtime(map { chomp; "/* $_ */"} @_);
102 }
103}
104
105sub declare {
106 my ($type, $var) = @_;
107 push(@{$declare_ref->{$type}}, $var);
108}
109
110sub push_runtime {
111 push(@$runtime_list_ref, @_);
112 warn join("\n", @_) . "\n" if $debug_runtime;
113}
114
115sub save_runtime {
116 push(@pp_list, [$ppname, $runtime_list_ref, $declare_ref]);
117}
118
119sub output_runtime {
120 my $ppdata;
121 print qq(#include "cc_runtime.h"\n);
122 foreach $ppdata (@pp_list) {
123 my ($name, $runtime, $declare) = @$ppdata;
124 print "\nstatic\nPP($name)\n{\n";
125 my ($type, $varlist, $line);
126 while (($type, $varlist) = each %$declare) {
127 print "\t$type ", join(", ", @$varlist), ";\n";
128 }
129 foreach $line (@$runtime) {
130 print $line, "\n";
131 }
132 print "}\n";
133 }
134}
135
136sub runtime {
137 my $line;
138 foreach $line (@_) {
139 push_runtime("\t$line");
140 }
141}
142
143sub init_pp {
144 $ppname = shift;
145 $runtime_list_ref = [];
146 $declare_ref = {};
147 runtime("djSP;");
148 declare("I32", "oldsave");
149 declare("SV", "**svp");
150 map { declare("SV", "*$_") } qw(sv src dst left right);
151 declare("MAGIC", "*mg");
152 $decl->add("static OP * $ppname _((ARGSproto));");
153 debug "init_pp: $ppname\n" if $debug_queue;
154}
155
156# Initialise runtime_callback function for Stackobj class
157BEGIN { B::Stackobj::set_callback(\&runtime) }
158
159# Initialise saveoptree_callback for B::C class
160sub cc_queue {
161 my ($name, $root, $start, @pl) = @_;
162 debug "cc_queue: name $name, root $root, start $start, padlist (@pl)\n"
163 if $debug_queue;
164 if ($name eq "*ignore*") {
165 $name = 0;
166 } else {
167 push(@cc_todo, [$name, $root, $start, (@pl ? @pl : @padlist)]);
168 }
169 my $fakeop = new B::FAKEOP ("next" => 0, sibling => 0, ppaddr => $name);
170 $start = $fakeop->save;
171 debug "cc_queue: name $name returns $start\n" if $debug_queue;
172 return $start;
173}
174BEGIN { B::C::set_callback(\&cc_queue) }
175
176sub valid_int { $_[0]->{flags} & VALID_INT }
177sub valid_double { $_[0]->{flags} & VALID_DOUBLE }
178sub valid_numeric { $_[0]->{flags} & (VALID_INT | VALID_DOUBLE) }
179sub valid_sv { $_[0]->{flags} & VALID_SV }
180
181sub top_int { @stack ? $stack[-1]->as_int : "TOPi" }
182sub top_double { @stack ? $stack[-1]->as_double : "TOPn" }
183sub top_numeric { @stack ? $stack[-1]->as_numeric : "TOPn" }
184sub top_sv { @stack ? $stack[-1]->as_sv : "TOPs" }
a9b6343a 185sub top_bool { @stack ? $stack[-1]->as_bool : "SvTRUE(TOPs)" }
a798dbf2
MB
186
187sub pop_int { @stack ? (pop @stack)->as_int : "POPi" }
188sub pop_double { @stack ? (pop @stack)->as_double : "POPn" }
189sub pop_numeric { @stack ? (pop @stack)->as_numeric : "POPn" }
190sub pop_sv { @stack ? (pop @stack)->as_sv : "POPs" }
191sub pop_bool {
192 if (@stack) {
a9b6343a 193 return ((pop @stack)->as_bool);
a798dbf2
MB
194 } else {
195 # Careful: POPs has an auto-decrement and SvTRUE evaluates
196 # its argument more than once.
197 runtime("sv = POPs;");
198 return "SvTRUE(sv)";
199 }
200}
201
202sub write_back_lexicals {
203 my $avoid = shift || 0;
204 debug "write_back_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
205 if $debug_shadow;
206 my $lex;
207 foreach $lex (@pad) {
208 next unless ref($lex);
209 $lex->write_back unless $lex->{flags} & $avoid;
210 }
211}
212
213sub write_back_stack {
214 my $obj;
215 return unless @stack;
216 runtime(sprintf("EXTEND(sp, %d);", scalar(@stack)));
217 foreach $obj (@stack) {
218 runtime(sprintf("PUSHs((SV*)%s);", $obj->as_sv));
219 }
220 @stack = ();
221}
222
223sub invalidate_lexicals {
224 my $avoid = shift || 0;
225 debug "invalidate_lexicals($avoid) called from @{[(caller(1))[3]]}\n"
226 if $debug_shadow;
227 my $lex;
228 foreach $lex (@pad) {
229 next unless ref($lex);
230 $lex->invalidate unless $lex->{flags} & $avoid;
231 }
232}
233
234sub reload_lexicals {
235 my $lex;
236 foreach $lex (@pad) {
237 next unless ref($lex);
238 my $type = $lex->{type};
239 if ($type == T_INT) {
240 $lex->as_int;
241 } elsif ($type == T_DOUBLE) {
242 $lex->as_double;
243 } else {
244 $lex->as_sv;
245 }
246 }
247}
248
249{
250 package B::Pseudoreg;
251 #
252 # This class allocates pseudo-registers (OK, so they're C variables).
253 #
254 my %alloc; # Keyed by variable name. A value of 1 means the
255 # variable has been declared. A value of 2 means
256 # it's in use.
257
258 sub new_scope { %alloc = () }
259
260 sub new ($$$) {
261 my ($class, $type, $prefix) = @_;
262 my ($ptr, $i, $varname, $status, $obj);
263 $prefix =~ s/^(\**)//;
264 $ptr = $1;
265 $i = 0;
266 do {
267 $varname = "$prefix$i";
268 $status = $alloc{$varname};
269 } while $status == 2;
270 if ($status != 1) {
271 # Not declared yet
272 B::CC::declare($type, "$ptr$varname");
273 $alloc{$varname} = 2; # declared and in use
274 }
275 $obj = bless \$varname, $class;
276 return $obj;
277 }
278 sub DESTROY {
279 my $obj = shift;
280 $alloc{$$obj} = 1; # no longer in use but still declared
281 }
282}
283{
284 package B::Shadow;
285 #
286 # This class gives a standard API for a perl object to shadow a
287 # C variable and only generate reloads/write-backs when necessary.
288 #
289 # Use $obj->load($foo) instead of runtime("shadowed_c_var = foo").
290 # Use $obj->write_back whenever shadowed_c_var needs to be up to date.
291 # Use $obj->invalidate whenever an unknown function may have
292 # set shadow itself.
293
294 sub new {
295 my ($class, $write_back) = @_;
296 # Object fields are perl shadow variable, validity flag
297 # (for *C* variable) and callback sub for write_back
298 # (passed perl shadow variable as argument).
299 bless [undef, 1, $write_back], $class;
300 }
301 sub load {
302 my ($obj, $newval) = @_;
303 $obj->[1] = 0; # C variable no longer valid
304 $obj->[0] = $newval;
305 }
306 sub write_back {
307 my $obj = shift;
308 if (!($obj->[1])) {
309 $obj->[1] = 1; # C variable will now be valid
310 &{$obj->[2]}($obj->[0]);
311 }
312 }
313 sub invalidate { $_[0]->[1] = 0 } # force C variable to be invalid
314}
315my $curcop = new B::Shadow (sub {
316 my $opsym = shift->save;
81009501 317 runtime("PL_curcop = (COP*)$opsym;");
a798dbf2
MB
318});
319
320#
321# Context stack shadowing. Mimics stuff in pp_ctl.c, cop.h and so on.
322#
323sub dopoptoloop {
324 my $cxix = $#cxstack;
325 while ($cxix >= 0 && $cxstack[$cxix]->{type} != CXt_LOOP) {
326 $cxix--;
327 }
328 debug "dopoptoloop: returning $cxix" if $debug_cxstack;
329 return $cxix;
330}
331
332sub dopoptolabel {
333 my $label = shift;
334 my $cxix = $#cxstack;
73544139
NIS
335 while ($cxix >= 0 &&
336 ($cxstack[$cxix]->{type} != CXt_LOOP ||
337 $cxstack[$cxix]->{label} ne $label)) {
a798dbf2
MB
338 $cxix--;
339 }
340 debug "dopoptolabel: returning $cxix" if $debug_cxstack;
341 return $cxix;
342}
343
344sub error {
345 my $format = shift;
346 my $file = $curcop->[0]->filegv->SV->PV;
347 my $line = $curcop->[0]->line;
348 $errors++;
349 if (@_) {
350 warn sprintf("%s:%d: $format\n", $file, $line, @_);
351 } else {
352 warn sprintf("%s:%d: %s\n", $file, $line, $format);
353 }
354}
355
356#
357# Load pad takes (the elements of) a PADLIST as arguments and loads
358# up @pad with Stackobj-derived objects which represent those lexicals.
359# If/when perl itself can generate type information (my int $foo) then
360# we'll take advantage of that here. Until then, we'll use various hacks
361# to tell the compiler when we want a lexical to be a particular type
362# or to be a register.
363#
364sub load_pad {
365 my ($namelistav, $valuelistav) = @_;
366 @padlist = @_;
367 my @namelist = $namelistav->ARRAY;
368 my @valuelist = $valuelistav->ARRAY;
369 my $ix;
370 @pad = ();
371 debug "load_pad: $#namelist names, $#valuelist values\n" if $debug_pad;
372 # Temporary lexicals don't get named so it's possible for @valuelist
373 # to be strictly longer than @namelist. We count $ix up to the end of
374 # @valuelist but index into @namelist for the name. Any temporaries which
375 # run off the end of @namelist will make $namesv undefined and we treat
376 # that the same as having an explicit SPECIAL sv_undef object in @namelist.
377 # [XXX If/when @_ becomes a lexical, we must start at 0 here.]
378 for ($ix = 1; $ix < @valuelist; $ix++) {
379 my $namesv = $namelist[$ix];
380 my $type = T_UNKNOWN;
381 my $flags = 0;
382 my $name = "tmp$ix";
383 my $class = class($namesv);
384 if (!defined($namesv) || $class eq "SPECIAL") {
81009501 385 # temporaries have &PL_sv_undef instead of a PVNV for a name
a798dbf2
MB
386 $flags = VALID_SV|TEMPORARY|REGISTER;
387 } else {
388 if ($namesv->PV =~ /^\$(.*)_([di])(r?)$/) {
389 $name = $1;
390 if ($2 eq "i") {
391 $type = T_INT;
392 $flags = VALID_SV|VALID_INT;
393 } elsif ($2 eq "d") {
394 $type = T_DOUBLE;
395 $flags = VALID_SV|VALID_DOUBLE;
396 }
397 $flags |= REGISTER if $3;
398 }
399 }
400 $pad[$ix] = new B::Stackobj::Padsv ($type, $flags, $ix,
401 "i_$name", "d_$name");
402 declare("IV", $type == T_INT ? "i_$name = 0" : "i_$name");
403 declare("double", $type == T_DOUBLE ? "d_$name = 0" : "d_$name");
81009501 404 debug sprintf("PL_curpad[$ix] = %s\n", $pad[$ix]->peek) if $debug_pad;
a798dbf2
MB
405 }
406}
407
408#
409# Debugging stuff
410#
411sub peek_stack { sprintf "stack = %s\n", join(" ", map($_->minipeek, @stack)) }
412
413#
414# OP stuff
415#
416
417sub label {
418 my $op = shift;
419 # XXX Preserve original label name for "real" labels?
420 return sprintf("lab_%x", $$op);
421}
422
423sub write_label {
424 my $op = shift;
425 push_runtime(sprintf(" %s:", label($op)));
426}
427
428sub loadop {
429 my $op = shift;
430 my $opsym = $op->save;
81009501 431 runtime("PL_op = $opsym;") unless $know_op;
a798dbf2
MB
432 return $opsym;
433}
434
435sub doop {
436 my $op = shift;
437 my $ppname = $op->ppaddr;
438 my $sym = loadop($op);
439 runtime("DOOP($ppname);");
440 $know_op = 1;
441 return $sym;
442}
443
444sub gimme {
445 my $op = shift;
446 my $flags = $op->flags;
4c1f658f 447 return (($flags & OPf_WANT) ? ($flags & OPf_WANT_LIST) : "dowantarray()");
a798dbf2
MB
448}
449
450#
451# Code generation for PP code
452#
453
454sub pp_null {
455 my $op = shift;
456 return $op->next;
457}
458
459sub pp_stub {
460 my $op = shift;
461 my $gimme = gimme($op);
462 if ($gimme != 1) {
463 # XXX Change to push a constant sv_undef Stackobj onto @stack
464 write_back_stack();
81009501 465 runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
a798dbf2
MB
466 }
467 return $op->next;
468}
469
470sub pp_unstack {
471 my $op = shift;
472 @stack = ();
473 runtime("PP_UNSTACK;");
474 return $op->next;
475}
476
477sub pp_and {
478 my $op = shift;
479 my $next = $op->next;
480 reload_lexicals();
481 unshift(@bblock_todo, $next);
482 if (@stack >= 1) {
483 my $bool = pop_bool();
484 write_back_stack();
44887cfa 485 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
a798dbf2
MB
486 } else {
487 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
488 "*sp--;");
489 }
490 return $op->other;
491}
492
493sub pp_or {
494 my $op = shift;
495 my $next = $op->next;
496 reload_lexicals();
497 unshift(@bblock_todo, $next);
498 if (@stack >= 1) {
44887cfa 499 my $bool = pop_bool @stack;
a798dbf2 500 write_back_stack();
44887cfa
NIS
501 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
502 $bool, label($next)));
a798dbf2
MB
503 } else {
504 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
505 "*sp--;");
506 }
507 return $op->other;
508}
509
510sub pp_cond_expr {
511 my $op = shift;
512 my $false = $op->false;
513 unshift(@bblock_todo, $false);
514 reload_lexicals();
515 my $bool = pop_bool();
516 write_back_stack();
517 runtime(sprintf("if (!$bool) goto %s;", label($false)));
518 return $op->true;
519}
520
521sub pp_padsv {
522 my $op = shift;
523 my $ix = $op->targ;
524 push(@stack, $pad[$ix]);
525 if ($op->flags & OPf_MOD) {
526 my $private = $op->private;
527 if ($private & OPpLVAL_INTRO) {
81009501 528 runtime("SAVECLEARSV(PL_curpad[$ix]);");
a798dbf2 529 } elsif ($private & OPpDEREF) {
81009501 530 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
a798dbf2
MB
531 $ix, $private & OPpDEREF));
532 $pad[$ix]->invalidate;
533 }
534 }
535 return $op->next;
536}
537
538sub pp_const {
539 my $op = shift;
540 my $sv = $op->sv;
541 my $obj = $constobj{$$sv};
542 if (!defined($obj)) {
543 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
544 }
545 push(@stack, $obj);
546 return $op->next;
547}
548
549sub pp_nextstate {
550 my $op = shift;
551 $curcop->load($op);
552 @stack = ();
553 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
554 runtime("TAINT_NOT;") unless $omit_taint;
81009501 555 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
a798dbf2
MB
556 if ($freetmps_each_bblock || $freetmps_each_loop) {
557 $need_freetmps = 1;
558 } else {
559 runtime("FREETMPS;");
560 }
561 return $op->next;
562}
563
564sub pp_dbstate {
565 my $op = shift;
566 $curcop->invalidate; # XXX?
567 return default_pp($op);
568}
569
df2464c8
VB
570#default_pp will handle this:
571#sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
572#sub pp_bless { $curcop->write_back; default_pp(@_) }
573#sub pp_repeat { $curcop->write_back; default_pp(@_) }
a798dbf2
MB
574# The following subs need $curcop->write_back if we decide to support arybase:
575# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
df2464c8
VB
576#sub pp_sort { $curcop->write_back; default_pp(@_) }
577#sub pp_caller { $curcop->write_back; default_pp(@_) }
578#sub pp_reset { $curcop->write_back; default_pp(@_) }
a798dbf2
MB
579
580sub pp_gv {
581 my $op = shift;
582 my $gvsym = $op->gv->save;
583 write_back_stack();
584 runtime("XPUSHs((SV*)$gvsym);");
585 return $op->next;
586}
587
588sub pp_gvsv {
589 my $op = shift;
590 my $gvsym = $op->gv->save;
591 write_back_stack();
592 if ($op->private & OPpLVAL_INTRO) {
593 runtime("XPUSHs(save_scalar($gvsym));");
594 } else {
595 runtime("XPUSHs(GvSV($gvsym));");
596 }
597 return $op->next;
598}
599
600sub pp_aelemfast {
601 my $op = shift;
602 my $gvsym = $op->gv->save;
603 my $ix = $op->private;
604 my $flag = $op->flags & OPf_MOD;
605 write_back_stack();
606 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
81009501 607 "PUSHs(svp ? *svp : &PL_sv_undef);");
a798dbf2
MB
608 return $op->next;
609}
610
611sub int_binop {
612 my ($op, $operator) = @_;
613 if ($op->flags & OPf_STACKED) {
614 my $right = pop_int();
615 if (@stack >= 1) {
616 my $left = top_int();
617 $stack[-1]->set_int(&$operator($left, $right));
618 } else {
619 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
620 }
621 } else {
622 my $targ = $pad[$op->targ];
623 my $right = new B::Pseudoreg ("IV", "riv");
624 my $left = new B::Pseudoreg ("IV", "liv");
625 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
626 $targ->set_int(&$operator($$left, $$right));
627 push(@stack, $targ);
628 }
629 return $op->next;
630}
631
632sub INTS_CLOSED () { 0x1 }
633sub INT_RESULT () { 0x2 }
634sub NUMERIC_RESULT () { 0x4 }
635
636sub numeric_binop {
637 my ($op, $operator, $flags) = @_;
638 my $force_int = 0;
639 $force_int ||= ($flags & INT_RESULT);
640 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
641 && valid_int($stack[-2]) && valid_int($stack[-1]));
642 if ($op->flags & OPf_STACKED) {
643 my $right = pop_numeric();
644 if (@stack >= 1) {
645 my $left = top_numeric();
646 if ($force_int) {
647 $stack[-1]->set_int(&$operator($left, $right));
648 } else {
649 $stack[-1]->set_numeric(&$operator($left, $right));
650 }
651 } else {
652 if ($force_int) {
73544139
NIS
653 my $rightruntime = new B::Pseudoreg ("IV", "riv");
654 runtime(sprintf("$$rightruntime = %s;",$right));
a798dbf2 655 runtime(sprintf("sv_setiv(TOPs, %s);",
73544139 656 &$operator("TOPi", $$rightruntime)));
a798dbf2 657 } else {
73544139
NIS
658 my $rightruntime = new B::Pseudoreg ("double", "rnv");
659 runtime(sprintf("$$rightruntime = %s;",$right));
a798dbf2 660 runtime(sprintf("sv_setnv(TOPs, %s);",
73544139 661 &$operator("TOPn",$$rightruntime)));
a798dbf2
MB
662 }
663 }
664 } else {
665 my $targ = $pad[$op->targ];
666 $force_int ||= ($targ->{type} == T_INT);
667 if ($force_int) {
668 my $right = new B::Pseudoreg ("IV", "riv");
669 my $left = new B::Pseudoreg ("IV", "liv");
670 runtime(sprintf("$$right = %s; $$left = %s;",
671 pop_numeric(), pop_numeric));
672 $targ->set_int(&$operator($$left, $$right));
673 } else {
674 my $right = new B::Pseudoreg ("double", "rnv");
675 my $left = new B::Pseudoreg ("double", "lnv");
676 runtime(sprintf("$$right = %s; $$left = %s;",
677 pop_numeric(), pop_numeric));
678 $targ->set_numeric(&$operator($$left, $$right));
679 }
680 push(@stack, $targ);
681 }
682 return $op->next;
683}
684
685sub sv_binop {
686 my ($op, $operator, $flags) = @_;
687 if ($op->flags & OPf_STACKED) {
688 my $right = pop_sv();
689 if (@stack >= 1) {
690 my $left = top_sv();
691 if ($flags & INT_RESULT) {
692 $stack[-1]->set_int(&$operator($left, $right));
693 } elsif ($flags & NUMERIC_RESULT) {
694 $stack[-1]->set_numeric(&$operator($left, $right));
695 } else {
696 # XXX Does this work?
697 runtime(sprintf("sv_setsv($left, %s);",
698 &$operator($left, $right)));
699 $stack[-1]->invalidate;
700 }
701 } else {
702 my $f;
703 if ($flags & INT_RESULT) {
704 $f = "sv_setiv";
705 } elsif ($flags & NUMERIC_RESULT) {
706 $f = "sv_setnv";
707 } else {
708 $f = "sv_setsv";
709 }
710 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
711 }
712 } else {
713 my $targ = $pad[$op->targ];
714 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
715 if ($flags & INT_RESULT) {
716 $targ->set_int(&$operator("left", "right"));
717 } elsif ($flags & NUMERIC_RESULT) {
718 $targ->set_numeric(&$operator("left", "right"));
719 } else {
720 # XXX Does this work?
721 runtime(sprintf("sv_setsv(%s, %s);",
722 $targ->as_sv, &$operator("left", "right")));
723 $targ->invalidate;
724 }
725 push(@stack, $targ);
726 }
727 return $op->next;
728}
729
730sub bool_int_binop {
731 my ($op, $operator) = @_;
732 my $right = new B::Pseudoreg ("IV", "riv");
733 my $left = new B::Pseudoreg ("IV", "liv");
734 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
735 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
736 $bool->set_int(&$operator($$left, $$right));
737 push(@stack, $bool);
738 return $op->next;
739}
740
741sub bool_numeric_binop {
742 my ($op, $operator) = @_;
743 my $right = new B::Pseudoreg ("double", "rnv");
744 my $left = new B::Pseudoreg ("double", "lnv");
745 runtime(sprintf("$$right = %s; $$left = %s;",
746 pop_numeric(), pop_numeric()));
747 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
748 $bool->set_numeric(&$operator($$left, $$right));
749 push(@stack, $bool);
750 return $op->next;
751}
752
753sub bool_sv_binop {
754 my ($op, $operator) = @_;
755 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
756 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
757 $bool->set_numeric(&$operator("left", "right"));
758 push(@stack, $bool);
759 return $op->next;
760}
761
762sub infix_op {
763 my $opname = shift;
764 return sub { "$_[0] $opname $_[1]" }
765}
766
767sub prefix_op {
768 my $opname = shift;
769 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
770}
771
772BEGIN {
773 my $plus_op = infix_op("+");
774 my $minus_op = infix_op("-");
775 my $multiply_op = infix_op("*");
776 my $divide_op = infix_op("/");
777 my $modulo_op = infix_op("%");
778 my $lshift_op = infix_op("<<");
a0d31f98 779 my $rshift_op = infix_op(">>");
a798dbf2
MB
780 my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
781 my $scmp_op = prefix_op("sv_cmp");
782 my $seq_op = prefix_op("sv_eq");
783 my $sne_op = prefix_op("!sv_eq");
784 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
785 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
786 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
787 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
788 my $eq_op = infix_op("==");
789 my $ne_op = infix_op("!=");
790 my $lt_op = infix_op("<");
791 my $gt_op = infix_op(">");
792 my $le_op = infix_op("<=");
793 my $ge_op = infix_op(">=");
794
795 #
796 # XXX The standard perl PP code has extra handling for
797 # some special case arguments of these operators.
798 #
799 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
800 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
801 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
802 sub pp_divide { numeric_binop($_[0], $divide_op) }
803 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
804 sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
805
806 sub pp_left_shift { int_binop($_[0], $lshift_op) }
807 sub pp_right_shift { int_binop($_[0], $rshift_op) }
808 sub pp_i_add { int_binop($_[0], $plus_op) }
809 sub pp_i_subtract { int_binop($_[0], $minus_op) }
810 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
811 sub pp_i_divide { int_binop($_[0], $divide_op) }
812 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
813
814 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
815 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
816 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
817 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
818 sub pp_le { bool_numeric_binop($_[0], $le_op) }
819 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
820
821 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
822 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
823 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
824 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
825 sub pp_i_le { bool_int_binop($_[0], $le_op) }
826 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
827
828 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
829 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
830 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
831 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
832 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
833 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
834 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
835}
836
837
838sub pp_sassign {
839 my $op = shift;
840 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
841 my ($dst, $src);
842 if (@stack >= 2) {
843 $dst = pop @stack;
844 $src = pop @stack;
845 ($src, $dst) = ($dst, $src) if $backwards;
846 my $type = $src->{type};
847 if ($type == T_INT) {
848 $dst->set_int($src->as_int);
849 } elsif ($type == T_DOUBLE) {
850 $dst->set_numeric($src->as_numeric);
851 } else {
852 $dst->set_sv($src->as_sv);
853 }
854 push(@stack, $dst);
855 } elsif (@stack == 1) {
856 if ($backwards) {
857 my $src = pop @stack;
858 my $type = $src->{type};
81009501 859 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
a798dbf2
MB
860 if ($type == T_INT) {
861 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
862 } elsif ($type == T_DOUBLE) {
863 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
864 } else {
865 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
866 }
867 runtime("SvSETMAGIC(TOPs);");
868 } else {
b8f1fa48 869 my $dst = $stack[-1];
a798dbf2
MB
870 my $type = $dst->{type};
871 runtime("sv = POPs;");
872 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
873 if ($type == T_INT) {
874 $dst->set_int("SvIV(sv)");
875 } elsif ($type == T_DOUBLE) {
876 $dst->set_double("SvNV(sv)");
877 } else {
878 runtime("SvSetSV($dst->{sv}, sv);");
879 $dst->invalidate;
880 }
881 }
882 } else {
883 if ($backwards) {
884 runtime("src = POPs; dst = TOPs;");
885 } else {
886 runtime("dst = POPs; src = TOPs;");
887 }
888 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
889 "SvSetSV(dst, src);",
890 "SvSETMAGIC(dst);",
891 "SETs(dst);");
892 }
893 return $op->next;
894}
895
896sub pp_preinc {
897 my $op = shift;
898 if (@stack >= 1) {
899 my $obj = $stack[-1];
900 my $type = $obj->{type};
901 if ($type == T_INT || $type == T_DOUBLE) {
902 $obj->set_int($obj->as_int . " + 1");
903 } else {
904 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
905 $obj->invalidate();
906 }
907 } else {
908 runtime sprintf("PP_PREINC(TOPs);");
909 }
910 return $op->next;
911}
912
913sub pp_pushmark {
914 my $op = shift;
915 write_back_stack();
916 runtime("PUSHMARK(sp);");
917 return $op->next;
918}
919
920sub pp_list {
921 my $op = shift;
922 write_back_stack();
923 my $gimme = gimme($op);
924 if ($gimme == 1) { # sic
925 runtime("POPMARK;"); # need this even though not a "full" pp_list
926 } else {
927 runtime("PP_LIST($gimme);");
928 }
929 return $op->next;
930}
931
932sub pp_entersub {
933 my $op = shift;
934 write_back_lexicals(REGISTER|TEMPORARY);
935 write_back_stack();
936 my $sym = doop($op);
5cfd8ad4
VB
937 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
938 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
939 runtime("SPAGAIN;}");
a798dbf2
MB
940 $know_op = 0;
941 invalidate_lexicals(REGISTER|TEMPORARY);
942 return $op->next;
943}
944
5cfd8ad4
VB
945sub pp_goto{
946
947 my $op = shift;
948 my $ppname = $op->ppaddr;
949 write_back_lexicals() unless $skip_lexicals{$ppname};
950 write_back_stack() unless $skip_stack{$ppname};
951 my $sym=doop($op);
952 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
953 invalidate_lexicals() unless $skip_invalidate{$ppname};
954 return $op->next;
955}
a798dbf2
MB
956sub pp_enterwrite {
957 my $op = shift;
958 pp_entersub($op);
959}
960
961sub pp_leavewrite {
962 my $op = shift;
963 write_back_lexicals(REGISTER|TEMPORARY);
964 write_back_stack();
965 my $sym = doop($op);
966 # XXX Is this the right way to distinguish between it returning
967 # CvSTART(cv) (via doform) and pop_return()?
81009501 968 runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
a798dbf2
MB
969 runtime("SPAGAIN;");
970 $know_op = 0;
971 invalidate_lexicals(REGISTER|TEMPORARY);
972 return $op->next;
973}
974
975sub doeval {
976 my $op = shift;
977 $curcop->write_back;
978 write_back_lexicals(REGISTER|TEMPORARY);
979 write_back_stack();
980 my $sym = loadop($op);
981 my $ppaddr = $op->ppaddr;
982 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
983 $know_op = 1;
984 invalidate_lexicals(REGISTER|TEMPORARY);
985 return $op->next;
986}
987
988sub pp_entereval { doeval(@_) }
989sub pp_require { doeval(@_) }
990sub pp_dofile { doeval(@_) }
991
992sub pp_entertry {
993 my $op = shift;
994 $curcop->write_back;
995 write_back_lexicals(REGISTER|TEMPORARY);
996 write_back_stack();
997 my $sym = doop($op);
998 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
999 declare("Sigjmp_buf", $jmpbuf);
1000 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1001 invalidate_lexicals(REGISTER|TEMPORARY);
1002 return $op->next;
1003}
1004
1005sub pp_grepstart {
1006 my $op = shift;
1007 if ($need_freetmps && $freetmps_each_loop) {
1008 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1009 $need_freetmps = 0;
1010 }
1011 write_back_stack();
a2093a06
GS
1012 my $sym= doop($op);
1013 my $next=$op->next;
1014 $next->save;
1015 my $nexttonext=$next->next;
1016 $nexttonext->save;
1017 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1018 label($nexttonext)));
a798dbf2
MB
1019 return $op->next->other;
1020}
1021
1022sub pp_mapstart {
1023 my $op = shift;
1024 if ($need_freetmps && $freetmps_each_loop) {
1025 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1026 $need_freetmps = 0;
1027 }
1028 write_back_stack();
e0c90f07
VB
1029 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1030 # we need to be able to distinguish the two at runtime.
1031 my $sym= doop($op);
1032 my $next=$op->next;
1033 $next->save;
1034 my $nexttonext=$next->next;
1035 $nexttonext->save;
a2093a06
GS
1036 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1037 label($nexttonext)));
a798dbf2
MB
1038 return $op->next->other;
1039}
1040
1041sub pp_grepwhile {
1042 my $op = shift;
1043 my $next = $op->next;
1044 unshift(@bblock_todo, $next);
1045 write_back_lexicals();
1046 write_back_stack();
1047 my $sym = doop($op);
1048 # pp_grepwhile can return either op_next or op_other and we need to
1049 # be able to distinguish the two at runtime. Since it's possible for
1050 # both ops to be "inlined", the fields could both be zero. To get
1051 # around that, we hack op_next to be our own op (purely because we
1052 # know it's a non-NULL pointer and can't be the same as op_other).
1053 $init->add("((LOGOP*)$sym)->op_next = $sym;");
81009501 1054 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
a798dbf2
MB
1055 $know_op = 0;
1056 return $op->other;
1057}
1058
1059sub pp_mapwhile {
1060 pp_grepwhile(@_);
1061}
1062
1063sub pp_return {
1064 my $op = shift;
1065 write_back_lexicals(REGISTER|TEMPORARY);
1066 write_back_stack();
1067 doop($op);
a9b6343a 1068 runtime("PUTBACK;", "return PL_op;");
a798dbf2
MB
1069 $know_op = 0;
1070 return $op->next;
1071}
1072
1073sub nyi {
1074 my $op = shift;
1075 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1076 return default_pp($op);
1077}
1078
1079sub pp_range {
1080 my $op = shift;
1081 my $flags = $op->flags;
4c1f658f 1082 if (!($flags & OPf_WANT)) {
a798dbf2
MB
1083 error("context of range unknown at compile-time");
1084 }
1085 write_back_lexicals();
1086 write_back_stack();
4c1f658f 1087 if (!($flags & OPf_WANT_LIST)) {
a798dbf2
MB
1088 # We need to save our UNOP structure since pp_flop uses
1089 # it to find and adjust out targ. We don't need it ourselves.
1090 $op->save;
81009501 1091 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
a798dbf2
MB
1092 $op->targ, label($op->false));
1093 unshift(@bblock_todo, $op->false);
1094 }
1095 return $op->true;
1096}
1097
1098sub pp_flip {
1099 my $op = shift;
1100 my $flags = $op->flags;
4c1f658f 1101 if (!($flags & OPf_WANT)) {
a798dbf2
MB
1102 error("context of flip unknown at compile-time");
1103 }
4c1f658f 1104 if ($flags & OPf_WANT_LIST) {
a798dbf2
MB
1105 return $op->first->false;
1106 }
1107 write_back_lexicals();
1108 write_back_stack();
1109 # We need to save our UNOP structure since pp_flop uses
1110 # it to find and adjust out targ. We don't need it ourselves.
1111 $op->save;
1112 my $ix = $op->targ;
1113 my $rangeix = $op->first->targ;
1114 runtime(($op->private & OPpFLIP_LINENUM) ?
81009501 1115 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
a798dbf2 1116 : "if (SvTRUE(TOPs)) {");
81009501 1117 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
a798dbf2 1118 if ($op->flags & OPf_SPECIAL) {
81009501 1119 runtime("sv_setiv(PL_curpad[$ix], 1);");
a798dbf2 1120 } else {
81009501 1121 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
a798dbf2
MB
1122 "\tsp--;",
1123 sprintf("\tgoto %s;", label($op->first->false)));
1124 }
1125 runtime("}",
81009501
GS
1126 qq{sv_setpv(PL_curpad[$ix], "");},
1127 "SETs(PL_curpad[$ix]);");
a798dbf2
MB
1128 $know_op = 0;
1129 return $op->next;
1130}
1131
1132sub pp_flop {
1133 my $op = shift;
1134 default_pp($op);
1135 $know_op = 0;
1136 return $op->next;
1137}
1138
1139sub enterloop {
1140 my $op = shift;
1141 my $nextop = $op->nextop;
1142 my $lastop = $op->lastop;
1143 my $redoop = $op->redoop;
1144 $curcop->write_back;
1145 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1146 push(@cxstack, {
1147 type => CXt_LOOP,
1148 op => $op,
1149 "label" => $curcop->[0]->label,
1150 nextop => $nextop,
1151 lastop => $lastop,
1152 redoop => $redoop
1153 });
1154 $nextop->save;
1155 $lastop->save;
1156 $redoop->save;
1157 return default_pp($op);
1158}
1159
1160sub pp_enterloop { enterloop(@_) }
1161sub pp_enteriter { enterloop(@_) }
1162
1163sub pp_leaveloop {
1164 my $op = shift;
1165 if (!@cxstack) {
1166 die "panic: leaveloop";
1167 }
1168 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1169 pop(@cxstack);
1170 return default_pp($op);
1171}
1172
1173sub pp_next {
1174 my $op = shift;
1175 my $cxix;
1176 if ($op->flags & OPf_SPECIAL) {
1177 $cxix = dopoptoloop();
1178 if ($cxix < 0) {
1179 error('"next" used outside loop');
1180 return $op->next; # ignore the op
1181 }
1182 } else {
1183 $cxix = dopoptolabel($op->pv);
1184 if ($cxix < 0) {
1185 error('Label not found at compile time for "next %s"', $op->pv);
1186 return $op->next; # ignore the op
1187 }
1188 }
1189 default_pp($op);
1190 my $nextop = $cxstack[$cxix]->{nextop};
1191 push(@bblock_todo, $nextop);
1192 runtime(sprintf("goto %s;", label($nextop)));
1193 return $op->next;
1194}
1195
1196sub pp_redo {
1197 my $op = shift;
1198 my $cxix;
1199 if ($op->flags & OPf_SPECIAL) {
1200 $cxix = dopoptoloop();
1201 if ($cxix < 0) {
1202 error('"redo" used outside loop');
1203 return $op->next; # ignore the op
1204 }
1205 } else {
1206 $cxix = dopoptolabel($op->pv);
1207 if ($cxix < 0) {
1208 error('Label not found at compile time for "redo %s"', $op->pv);
1209 return $op->next; # ignore the op
1210 }
1211 }
1212 default_pp($op);
1213 my $redoop = $cxstack[$cxix]->{redoop};
1214 push(@bblock_todo, $redoop);
1215 runtime(sprintf("goto %s;", label($redoop)));
1216 return $op->next;
1217}
1218
1219sub pp_last {
1220 my $op = shift;
1221 my $cxix;
1222 if ($op->flags & OPf_SPECIAL) {
1223 $cxix = dopoptoloop();
1224 if ($cxix < 0) {
1225 error('"last" used outside loop');
1226 return $op->next; # ignore the op
1227 }
1228 } else {
1229 $cxix = dopoptolabel($op->pv);
1230 if ($cxix < 0) {
1231 error('Label not found at compile time for "last %s"', $op->pv);
1232 return $op->next; # ignore the op
1233 }
1234 # XXX Add support for "last" to leave non-loop blocks
1235 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1236 error('Use of "last" for non-loop blocks is not yet implemented');
1237 return $op->next; # ignore the op
1238 }
1239 }
1240 default_pp($op);
1241 my $lastop = $cxstack[$cxix]->{lastop}->next;
1242 push(@bblock_todo, $lastop);
1243 runtime(sprintf("goto %s;", label($lastop)));
1244 return $op->next;
1245}
1246
1247sub pp_subst {
1248 my $op = shift;
1249 write_back_lexicals();
1250 write_back_stack();
1251 my $sym = doop($op);
1252 my $replroot = $op->pmreplroot;
1253 if ($$replroot) {
81009501 1254 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
a798dbf2
MB
1255 $sym, label($replroot));
1256 $op->pmreplstart->save;
1257 push(@bblock_todo, $replroot);
1258 }
1259 invalidate_lexicals();
1260 return $op->next;
1261}
1262
1263sub pp_substcont {
1264 my $op = shift;
1265 write_back_lexicals();
1266 write_back_stack();
1267 doop($op);
1268 my $pmop = $op->other;
0cc1d052
NIS
1269 # warn sprintf("substcont: op = %s, pmop = %s\n",
1270 # peekop($op), peekop($pmop));#debug
1271# my $pmopsym = objsym($pmop);
a798dbf2 1272 my $pmopsym = $pmop->save; # XXX can this recurse?
0cc1d052 1273# warn "pmopsym = $pmopsym\n";#debug
81009501 1274 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
a798dbf2
MB
1275 $pmopsym, label($pmop->pmreplstart));
1276 invalidate_lexicals();
1277 return $pmop->next;
1278}
1279
1280sub default_pp {
1281 my $op = shift;
1282 my $ppname = $op->ppaddr;
df2464c8
VB
1283 if ($curcop and $need_curcop{$ppname}){
1284 $curcop->write_back;
1285 }
a798dbf2
MB
1286 write_back_lexicals() unless $skip_lexicals{$ppname};
1287 write_back_stack() unless $skip_stack{$ppname};
1288 doop($op);
1289 # XXX If the only way that ops can write to a TEMPORARY lexical is
1290 # when it's named in $op->targ then we could call
1291 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1292 # the temporaries. For now, we'll play it safe and write back the lot.
1293 invalidate_lexicals() unless $skip_invalidate{$ppname};
1294 return $op->next;
1295}
1296
1297sub compile_op {
1298 my $op = shift;
1299 my $ppname = $op->ppaddr;
1300 if (exists $ignore_op{$ppname}) {
1301 return $op->next;
1302 }
1303 debug peek_stack() if $debug_stack;
1304 if ($debug_op) {
1305 debug sprintf("%s [%s]\n",
1306 peekop($op),
1307 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1308 }
1309 no strict 'refs';
1310 if (defined(&$ppname)) {
1311 $know_op = 0;
1312 return &$ppname($op);
1313 } else {
1314 return default_pp($op);
1315 }
1316}
1317
1318sub compile_bblock {
1319 my $op = shift;
1320 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1321 write_label($op);
1322 $know_op = 0;
1323 do {
1324 $op = compile_op($op);
1325 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1326 write_back_stack(); # boo hoo: big loss
1327 reload_lexicals();
1328 return $op;
1329}
1330
1331sub cc {
1332 my ($name, $root, $start, @padlist) = @_;
1333 my $op;
1334 init_pp($name);
1335 load_pad(@padlist);
1336 B::Pseudoreg->new_scope;
1337 @cxstack = ();
1338 if ($debug_timings) {
1339 warn sprintf("Basic block analysis at %s\n", timing_info);
1340 }
1341 $leaders = find_leaders($root, $start);
1342 @bblock_todo = ($start, values %$leaders);
1343 if ($debug_timings) {
1344 warn sprintf("Compilation at %s\n", timing_info);
1345 }
1346 while (@bblock_todo) {
1347 $op = shift @bblock_todo;
1348 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1349 next if !defined($op) || !$$op || $done{$$op};
1350 #warn "...compiling it\n"; # debug
1351 do {
1352 $done{$$op} = 1;
1353 $op = compile_bblock($op);
1354 if ($need_freetmps && $freetmps_each_bblock) {
1355 runtime("FREETMPS;");
1356 $need_freetmps = 0;
1357 }
1358 } while defined($op) && $$op && !$done{$$op};
1359 if ($need_freetmps && $freetmps_each_loop) {
1360 runtime("FREETMPS;");
1361 $need_freetmps = 0;
1362 }
1363 if (!$$op) {
a9b6343a 1364 runtime("PUTBACK;","return PL_op;");
a798dbf2
MB
1365 } elsif ($done{$$op}) {
1366 runtime(sprintf("goto %s;", label($op)));
1367 }
1368 }
1369 if ($debug_timings) {
1370 warn sprintf("Saving runtime at %s\n", timing_info);
1371 }
1372 save_runtime();
1373}
1374
1375sub cc_recurse {
1376 my $ccinfo;
1377 my $start;
1378 $start = cc_queue(@_) if @_;
1379 while ($ccinfo = shift @cc_todo) {
1380 cc(@$ccinfo);
1381 }
1382 return $start;
1383}
1384
1385sub cc_obj {
1386 my ($name, $cvref) = @_;
1387 my $cv = svref_2object($cvref);
1388 my @padlist = $cv->PADLIST->ARRAY;
1389 my $curpad_sym = $padlist[1]->save;
1390 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1391}
1392
1393sub cc_main {
1394 my @comppadlist = comppadlist->ARRAY;
0cc1d052
NIS
1395 my $curpad_nam = $comppadlist[0]->save;
1396 my $curpad_sym = $comppadlist[1]->save;
1397 my $init_av = init_av->save;
1398 my $inc_hv = svref_2object(\%INC)->save;
1399 my $inc_av = svref_2object(\@INC)->save;
a798dbf2 1400 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
0cc1d052 1401 save_unused_subs();
a798dbf2
MB
1402 cc_recurse();
1403
1404 return if $errors;
1405 if (!defined($module)) {
81009501
GS
1406 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1407 "PL_main_start = $start;",
5cfd8ad4 1408 "PL_curpad = AvARRAY($curpad_sym);",
0cc1d052
NIS
1409 "PL_initav = $init_av;",
1410 "GvHV(PL_incgv) = $inc_hv;",
1411 "GvAV(PL_incgv) = $inc_av;",
5cfd8ad4 1412 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
44887cfa
NIS
1413 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1414 );
1415
a798dbf2 1416 }
73544139 1417 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
a798dbf2
MB
1418 output_boilerplate();
1419 print "\n";
1420 output_all("perl_init");
1421 output_runtime();
1422 print "\n";
1423 output_main();
1424 if (defined($module)) {
1425 my $cmodule = $module;
1426 $cmodule =~ s/::/__/g;
1427 print <<"EOT";
1428
1429#include "XSUB.h"
1430XS(boot_$cmodule)
1431{
1432 dXSARGS;
1433 perl_init();
1434 ENTER;
1435 SAVETMPS;
81009501
GS
1436 SAVESPTR(PL_curpad);
1437 SAVESPTR(PL_op);
1438 PL_curpad = AvARRAY($curpad_sym);
1439 PL_op = $start;
a798dbf2
MB
1440 pp_main(ARGS);
1441 FREETMPS;
1442 LEAVE;
81009501 1443 ST(0) = &PL_sv_yes;
a798dbf2
MB
1444 XSRETURN(1);
1445}
1446EOT
1447 }
1448 if ($debug_timings) {
1449 warn sprintf("Done at %s\n", timing_info);
1450 }
1451}
1452
1453sub compile {
1454 my @options = @_;
1455 my ($option, $opt, $arg);
1456 OPTION:
1457 while ($option = shift @options) {
1458 if ($option =~ /^-(.)(.*)/) {
1459 $opt = $1;
1460 $arg = $2;
1461 } else {
1462 unshift @options, $option;
1463 last OPTION;
1464 }
1465 if ($opt eq "-" && $arg eq "-") {
1466 shift @options;
1467 last OPTION;
1468 } elsif ($opt eq "o") {
1469 $arg ||= shift @options;
ff06c60c 1470 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
a798dbf2
MB
1471 } elsif ($opt eq "n") {
1472 $arg ||= shift @options;
1473 $module_name = $arg;
1474 } elsif ($opt eq "u") {
1475 $arg ||= shift @options;
0cc1d052 1476 mark_unused($arg,undef);
a798dbf2
MB
1477 } elsif ($opt eq "f") {
1478 $arg ||= shift @options;
1479 my $value = $arg !~ s/^no-//;
1480 $arg =~ s/-/_/g;
1481 my $ref = $optimise{$arg};
1482 if (defined($ref)) {
1483 $$ref = $value;
1484 } else {
1485 warn qq(ignoring unknown optimisation option "$arg"\n);
1486 }
1487 } elsif ($opt eq "O") {
1488 $arg = 1 if $arg eq "";
1489 my $ref;
1490 foreach $ref (values %optimise) {
1491 $$ref = 0;
1492 }
1493 if ($arg >= 2) {
1494 $freetmps_each_loop = 1;
1495 }
1496 if ($arg >= 1) {
1497 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1498 }
1499 } elsif ($opt eq "m") {
1500 $arg ||= shift @options;
1501 $module = $arg;
a9b6343a 1502 mark_unused($arg,undef);
a798dbf2
MB
1503 } elsif ($opt eq "p") {
1504 $arg ||= shift @options;
1505 $patchlevel = $arg;
1506 } elsif ($opt eq "D") {
1507 $arg ||= shift @options;
1508 foreach $arg (split(//, $arg)) {
1509 if ($arg eq "o") {
1510 B->debug(1);
1511 } elsif ($arg eq "O") {
1512 $debug_op = 1;
1513 } elsif ($arg eq "s") {
1514 $debug_stack = 1;
1515 } elsif ($arg eq "c") {
1516 $debug_cxstack = 1;
1517 } elsif ($arg eq "p") {
1518 $debug_pad = 1;
1519 } elsif ($arg eq "r") {
1520 $debug_runtime = 1;
1521 } elsif ($arg eq "S") {
1522 $debug_shadow = 1;
1523 } elsif ($arg eq "q") {
1524 $debug_queue = 1;
1525 } elsif ($arg eq "l") {
1526 $debug_lineno = 1;
1527 } elsif ($arg eq "t") {
1528 $debug_timings = 1;
1529 }
1530 }
1531 }
1532 }
1533 init_sections();
1534 $init = B::Section->get("init");
1535 $decl = B::Section->get("decl");
1536
1537 if (@options) {
1538 return sub {
1539 my ($objname, $ppname);
1540 foreach $objname (@options) {
1541 $objname = "main::$objname" unless $objname =~ /::/;
1542 ($ppname = $objname) =~ s/^.*?:://;
1543 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1544 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1545 return if $errors;
1546 }
1547 output_boilerplate();
1548 print "\n";
1549 output_all($module_name || "init_module");
1550 output_runtime();
1551 }
1552 } else {
1553 return sub { cc_main() };
1554 }
1555}
1556
15571;
7f20e9dd
GS
1558
1559__END__
1560
1561=head1 NAME
1562
1563B::CC - Perl compiler's optimized C translation backend
1564
1565=head1 SYNOPSIS
1566
1567 perl -MO=CC[,OPTIONS] foo.pl
1568
1569=head1 DESCRIPTION
1570
1a52ab62
MB
1571This compiler backend takes Perl source and generates C source code
1572corresponding to the flow of your program. In other words, this
1573backend is somewhat a "real" compiler in the sense that many people
1574think about compilers. Note however that, currently, it is a very
1575poor compiler in that although it generates (mostly, or at least
1576sometimes) correct code, it performs relatively few optimisations.
1577This will change as the compiler develops. The result is that
1578running an executable compiled with this backend may start up more
1579quickly than running the original Perl program (a feature shared
1580by the B<C> compiler backend--see F<B::C>) and may also execute
1581slightly faster. This is by no means a good optimising compiler--yet.
1582
1583=head1 OPTIONS
1584
1585If there are any non-option arguments, they are taken to be
1586names of objects to be saved (probably doesn't work properly yet).
1587Without extra arguments, it saves the main program.
1588
1589=over 4
1590
1591=item B<-ofilename>
1592
1593Output to filename instead of STDOUT
1594
1595=item B<-v>
1596
1597Verbose compilation (currently gives a few compilation statistics).
1598
1599=item B<-->
1600
1601Force end of options
1602
1603=item B<-uPackname>
1604
1605Force apparently unused subs from package Packname to be compiled.
1606This allows programs to use eval "foo()" even when sub foo is never
1607seen to be used at compile time. The down side is that any subs which
1608really are never used also have code generated. This option is
1609necessary, for example, if you have a signal handler foo which you
1610initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1611to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1612options. The compiler tries to figure out which packages may possibly
1613have subs in which need compiling but the current version doesn't do
1614it very well. In particular, it is confused by nested packages (i.e.
1615of the form C<A::B>) where package C<A> does not contain any subs.
1616
1617=item B<-mModulename>
1618
1619Instead of generating source for a runnable executable, generate
1620source for an XSUB module. The boot_Modulename function (which
1621DynaLoader can look for) does the appropriate initialisation and runs
1622the main part of the Perl source that is being compiled.
1623
1624
1625=item B<-D>
1626
1627Debug options (concatenated or separate flags like C<perl -D>).
1628
1629=item B<-Dr>
1630
1631Writes debugging output to STDERR just as it's about to write to the
1632program's runtime (otherwise writes debugging info as comments in
1633its C output).
1634
1635=item B<-DO>
1636
1637Outputs each OP as it's compiled
1638
1639=item B<-Ds>
1640
1641Outputs the contents of the shadow stack at each OP
1642
1643=item B<-Dp>
1644
1645Outputs the contents of the shadow pad of lexicals as it's loaded for
1646each sub or the main program.
1647
1648=item B<-Dq>
1649
1650Outputs the name of each fake PP function in the queue as it's about
1651to process it.
1652
1653=item B<-Dl>
1654
1655Output the filename and line number of each original line of Perl
1656code as it's processed (C<pp_nextstate>).
1657
1658=item B<-Dt>
1659
1660Outputs timing information of compilation stages.
1661
1662=item B<-f>
1663
1664Force optimisations on or off one at a time.
1665
1666=item B<-ffreetmps-each-bblock>
1667
1668Delays FREETMPS from the end of each statement to the end of the each
1669basic block.
1670
1671=item B<-ffreetmps-each-loop>
1672
1673Delays FREETMPS from the end of each statement to the end of the group
1674of basic blocks forming a loop. At most one of the freetmps-each-*
1675options can be used.
1676
1677=item B<-fomit-taint>
1678
1679Omits generating code for handling perl's tainting mechanism.
1680
1681=item B<-On>
1682
1683Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1684Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1685sets B<-ffreetmps-each-loop>.
1686
1687=back
1688
1689=head1 EXAMPLES
1690
1691 perl -MO=CC,-O2,-ofoo.c foo.pl
1692 perl cc_harness -o foo foo.c
1693
1694Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1695library directory. The utility called C<perlcc> may also be used to
1696help make use of this compiler.
1697
1698 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1699 perl cc_harness -shared -c -o Foo.so Foo.c
1700
1701=head1 BUGS
1702
1703Plenty. Current status: experimental.
1704
1705=head1 DIFFERENCES
1706
1707These aren't really bugs but they are constructs which are heavily
1708tied to perl's compile-and-go implementation and with which this
1709compiler backend cannot cope.
1710
1711=head2 Loops
1712
1713Standard perl calculates the target of "next", "last", and "redo"
1714at run-time. The compiler calculates the targets at compile-time.
1715For example, the program
1716
1717 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1718 NUMBER: for ($i = 0; $i < 5; $i++) {
1719 skip_on_odd($i);
1720 print $i;
1721 }
1722
1723produces the output
1724
1725 024
1726
1727with standard perl but gives a compile-time error with the compiler.
1728
1729=head2 Context of ".."
1730
1731The context (scalar or array) of the ".." operator determines whether
1732it behaves as a range or a flip/flop. Standard perl delays until
1733runtime the decision of which context it is in but the compiler needs
1734to know the context at compile-time. For example,
1735
1736 @a = (4,6,1,0,0,1);
1737 sub range { (shift @a)..(shift @a) }
1738 print range();
1739 while (@a) { print scalar(range()) }
1740
1741generates the output
1742
1743 456123E0
1744
1745with standard Perl but gives a compile-time error with compiled Perl.
1746
1747=head2 Arithmetic
1748
1749Compiled Perl programs use native C arithemtic much more frequently
1750than standard perl. Operations on large numbers or on boundary
1751cases may produce different behaviour.
1752
1753=head2 Deprecated features
1754
1755Features of standard perl such as C<$[> which have been deprecated
1756in standard perl since Perl5 was released have not been implemented
1757in the compiler.
7f20e9dd
GS
1758
1759=head1 AUTHOR
1760
1761Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1762
1763=cut