This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add Ethiopic section to unicode master database (from Ken
[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
a6f4eb0a 11 timing_info init_av sv_undef
4c1f658f
NIS
12 OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
13 OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
a6f4eb0a 14 OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
4c1f658f
NIS
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;
a6f4eb0a 447 return (($flags & OPf_WANT) ? (($flags & OPf_WANT)== OPf_WANT_LIST? G_ARRAY:G_SCALAR) : "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);
a6f4eb0a
VB
462 if ($gimme != G_ARRAY) {
463 my $obj= new B::Stackobj::Const(sv_undef);
464 push(@stack, $obj);
a798dbf2 465 # XXX Change to push a constant sv_undef Stackobj onto @stack
a6f4eb0a
VB
466 #write_back_stack();
467 #runtime("if ($gimme != G_ARRAY) XPUSHs(&PL_sv_undef);");
a798dbf2
MB
468 }
469 return $op->next;
470}
471
472sub pp_unstack {
473 my $op = shift;
474 @stack = ();
475 runtime("PP_UNSTACK;");
476 return $op->next;
477}
478
479sub pp_and {
480 my $op = shift;
481 my $next = $op->next;
482 reload_lexicals();
483 unshift(@bblock_todo, $next);
484 if (@stack >= 1) {
485 my $bool = pop_bool();
486 write_back_stack();
44887cfa 487 runtime(sprintf("if (!$bool) {XPUSHs(&PL_sv_no); goto %s;}", label($next)));
a798dbf2
MB
488 } else {
489 runtime(sprintf("if (!%s) goto %s;", top_bool(), label($next)),
490 "*sp--;");
491 }
492 return $op->other;
493}
494
495sub pp_or {
496 my $op = shift;
497 my $next = $op->next;
498 reload_lexicals();
499 unshift(@bblock_todo, $next);
500 if (@stack >= 1) {
44887cfa 501 my $bool = pop_bool @stack;
a798dbf2 502 write_back_stack();
44887cfa
NIS
503 runtime(sprintf("if (%s) { XPUSHs(&PL_sv_yes); goto %s; }",
504 $bool, label($next)));
a798dbf2
MB
505 } else {
506 runtime(sprintf("if (%s) goto %s;", top_bool(), label($next)),
507 "*sp--;");
508 }
509 return $op->other;
510}
511
512sub pp_cond_expr {
513 my $op = shift;
514 my $false = $op->false;
515 unshift(@bblock_todo, $false);
516 reload_lexicals();
517 my $bool = pop_bool();
518 write_back_stack();
519 runtime(sprintf("if (!$bool) goto %s;", label($false)));
520 return $op->true;
521}
522
523sub pp_padsv {
524 my $op = shift;
525 my $ix = $op->targ;
526 push(@stack, $pad[$ix]);
527 if ($op->flags & OPf_MOD) {
528 my $private = $op->private;
529 if ($private & OPpLVAL_INTRO) {
81009501 530 runtime("SAVECLEARSV(PL_curpad[$ix]);");
a798dbf2 531 } elsif ($private & OPpDEREF) {
81009501 532 runtime(sprintf("vivify_ref(PL_curpad[%d], %d);",
a798dbf2
MB
533 $ix, $private & OPpDEREF));
534 $pad[$ix]->invalidate;
535 }
536 }
537 return $op->next;
538}
539
540sub pp_const {
541 my $op = shift;
542 my $sv = $op->sv;
543 my $obj = $constobj{$$sv};
544 if (!defined($obj)) {
545 $obj = $constobj{$$sv} = new B::Stackobj::Const ($sv);
546 }
547 push(@stack, $obj);
548 return $op->next;
549}
550
551sub pp_nextstate {
552 my $op = shift;
553 $curcop->load($op);
554 @stack = ();
555 debug(sprintf("%s:%d\n", $op->filegv->SV->PV, $op->line)) if $debug_lineno;
556 runtime("TAINT_NOT;") unless $omit_taint;
81009501 557 runtime("sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;");
a798dbf2
MB
558 if ($freetmps_each_bblock || $freetmps_each_loop) {
559 $need_freetmps = 1;
560 } else {
561 runtime("FREETMPS;");
562 }
563 return $op->next;
564}
565
566sub pp_dbstate {
567 my $op = shift;
568 $curcop->invalidate; # XXX?
569 return default_pp($op);
570}
571
df2464c8
VB
572#default_pp will handle this:
573#sub pp_rv2gv { $curcop->write_back; default_pp(@_) }
574#sub pp_bless { $curcop->write_back; default_pp(@_) }
575#sub pp_repeat { $curcop->write_back; default_pp(@_) }
a798dbf2
MB
576# The following subs need $curcop->write_back if we decide to support arybase:
577# pp_pos, pp_substr, pp_index, pp_rindex, pp_aslice, pp_lslice, pp_splice
df2464c8
VB
578#sub pp_sort { $curcop->write_back; default_pp(@_) }
579#sub pp_caller { $curcop->write_back; default_pp(@_) }
580#sub pp_reset { $curcop->write_back; default_pp(@_) }
a798dbf2
MB
581
582sub pp_gv {
583 my $op = shift;
584 my $gvsym = $op->gv->save;
585 write_back_stack();
586 runtime("XPUSHs((SV*)$gvsym);");
587 return $op->next;
588}
589
590sub pp_gvsv {
591 my $op = shift;
592 my $gvsym = $op->gv->save;
593 write_back_stack();
594 if ($op->private & OPpLVAL_INTRO) {
595 runtime("XPUSHs(save_scalar($gvsym));");
596 } else {
597 runtime("XPUSHs(GvSV($gvsym));");
598 }
599 return $op->next;
600}
601
602sub pp_aelemfast {
603 my $op = shift;
604 my $gvsym = $op->gv->save;
605 my $ix = $op->private;
606 my $flag = $op->flags & OPf_MOD;
607 write_back_stack();
608 runtime("svp = av_fetch(GvAV($gvsym), $ix, $flag);",
81009501 609 "PUSHs(svp ? *svp : &PL_sv_undef);");
a798dbf2
MB
610 return $op->next;
611}
612
613sub int_binop {
614 my ($op, $operator) = @_;
615 if ($op->flags & OPf_STACKED) {
616 my $right = pop_int();
617 if (@stack >= 1) {
618 my $left = top_int();
619 $stack[-1]->set_int(&$operator($left, $right));
620 } else {
621 runtime(sprintf("sv_setiv(TOPs, %s);",&$operator("TOPi", $right)));
622 }
623 } else {
624 my $targ = $pad[$op->targ];
625 my $right = new B::Pseudoreg ("IV", "riv");
626 my $left = new B::Pseudoreg ("IV", "liv");
627 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int));
628 $targ->set_int(&$operator($$left, $$right));
629 push(@stack, $targ);
630 }
631 return $op->next;
632}
633
634sub INTS_CLOSED () { 0x1 }
635sub INT_RESULT () { 0x2 }
636sub NUMERIC_RESULT () { 0x4 }
637
638sub numeric_binop {
639 my ($op, $operator, $flags) = @_;
640 my $force_int = 0;
641 $force_int ||= ($flags & INT_RESULT);
642 $force_int ||= ($flags & INTS_CLOSED && @stack >= 2
643 && valid_int($stack[-2]) && valid_int($stack[-1]));
644 if ($op->flags & OPf_STACKED) {
645 my $right = pop_numeric();
646 if (@stack >= 1) {
647 my $left = top_numeric();
648 if ($force_int) {
649 $stack[-1]->set_int(&$operator($left, $right));
650 } else {
651 $stack[-1]->set_numeric(&$operator($left, $right));
652 }
653 } else {
654 if ($force_int) {
73544139
NIS
655 my $rightruntime = new B::Pseudoreg ("IV", "riv");
656 runtime(sprintf("$$rightruntime = %s;",$right));
a798dbf2 657 runtime(sprintf("sv_setiv(TOPs, %s);",
73544139 658 &$operator("TOPi", $$rightruntime)));
a798dbf2 659 } else {
73544139
NIS
660 my $rightruntime = new B::Pseudoreg ("double", "rnv");
661 runtime(sprintf("$$rightruntime = %s;",$right));
a798dbf2 662 runtime(sprintf("sv_setnv(TOPs, %s);",
73544139 663 &$operator("TOPn",$$rightruntime)));
a798dbf2
MB
664 }
665 }
666 } else {
667 my $targ = $pad[$op->targ];
668 $force_int ||= ($targ->{type} == T_INT);
669 if ($force_int) {
670 my $right = new B::Pseudoreg ("IV", "riv");
671 my $left = new B::Pseudoreg ("IV", "liv");
672 runtime(sprintf("$$right = %s; $$left = %s;",
673 pop_numeric(), pop_numeric));
674 $targ->set_int(&$operator($$left, $$right));
675 } else {
676 my $right = new B::Pseudoreg ("double", "rnv");
677 my $left = new B::Pseudoreg ("double", "lnv");
678 runtime(sprintf("$$right = %s; $$left = %s;",
679 pop_numeric(), pop_numeric));
680 $targ->set_numeric(&$operator($$left, $$right));
681 }
682 push(@stack, $targ);
683 }
684 return $op->next;
685}
686
687sub sv_binop {
688 my ($op, $operator, $flags) = @_;
689 if ($op->flags & OPf_STACKED) {
690 my $right = pop_sv();
691 if (@stack >= 1) {
692 my $left = top_sv();
693 if ($flags & INT_RESULT) {
694 $stack[-1]->set_int(&$operator($left, $right));
695 } elsif ($flags & NUMERIC_RESULT) {
696 $stack[-1]->set_numeric(&$operator($left, $right));
697 } else {
698 # XXX Does this work?
699 runtime(sprintf("sv_setsv($left, %s);",
700 &$operator($left, $right)));
701 $stack[-1]->invalidate;
702 }
703 } else {
704 my $f;
705 if ($flags & INT_RESULT) {
706 $f = "sv_setiv";
707 } elsif ($flags & NUMERIC_RESULT) {
708 $f = "sv_setnv";
709 } else {
710 $f = "sv_setsv";
711 }
712 runtime(sprintf("%s(TOPs, %s);", $f, &$operator("TOPs", $right)));
713 }
714 } else {
715 my $targ = $pad[$op->targ];
716 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv));
717 if ($flags & INT_RESULT) {
718 $targ->set_int(&$operator("left", "right"));
719 } elsif ($flags & NUMERIC_RESULT) {
720 $targ->set_numeric(&$operator("left", "right"));
721 } else {
722 # XXX Does this work?
723 runtime(sprintf("sv_setsv(%s, %s);",
724 $targ->as_sv, &$operator("left", "right")));
725 $targ->invalidate;
726 }
727 push(@stack, $targ);
728 }
729 return $op->next;
730}
731
732sub bool_int_binop {
733 my ($op, $operator) = @_;
734 my $right = new B::Pseudoreg ("IV", "riv");
735 my $left = new B::Pseudoreg ("IV", "liv");
736 runtime(sprintf("$$right = %s; $$left = %s;", pop_int(), pop_int()));
737 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
738 $bool->set_int(&$operator($$left, $$right));
739 push(@stack, $bool);
740 return $op->next;
741}
742
743sub bool_numeric_binop {
744 my ($op, $operator) = @_;
745 my $right = new B::Pseudoreg ("double", "rnv");
746 my $left = new B::Pseudoreg ("double", "lnv");
747 runtime(sprintf("$$right = %s; $$left = %s;",
748 pop_numeric(), pop_numeric()));
749 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
750 $bool->set_numeric(&$operator($$left, $$right));
751 push(@stack, $bool);
752 return $op->next;
753}
754
755sub bool_sv_binop {
756 my ($op, $operator) = @_;
757 runtime(sprintf("right = %s; left = %s;", pop_sv(), pop_sv()));
758 my $bool = new B::Stackobj::Bool (new B::Pseudoreg ("int", "b"));
759 $bool->set_numeric(&$operator("left", "right"));
760 push(@stack, $bool);
761 return $op->next;
762}
763
764sub infix_op {
765 my $opname = shift;
766 return sub { "$_[0] $opname $_[1]" }
767}
768
769sub prefix_op {
770 my $opname = shift;
771 return sub { sprintf("%s(%s)", $opname, join(", ", @_)) }
772}
773
774BEGIN {
775 my $plus_op = infix_op("+");
776 my $minus_op = infix_op("-");
777 my $multiply_op = infix_op("*");
778 my $divide_op = infix_op("/");
779 my $modulo_op = infix_op("%");
780 my $lshift_op = infix_op("<<");
a0d31f98 781 my $rshift_op = infix_op(">>");
a798dbf2
MB
782 my $ncmp_op = sub { "($_[0] > $_[1] ? 1 : ($_[0] < $_[1]) ? -1 : 0)" };
783 my $scmp_op = prefix_op("sv_cmp");
784 my $seq_op = prefix_op("sv_eq");
785 my $sne_op = prefix_op("!sv_eq");
786 my $slt_op = sub { "sv_cmp($_[0], $_[1]) < 0" };
787 my $sgt_op = sub { "sv_cmp($_[0], $_[1]) > 0" };
788 my $sle_op = sub { "sv_cmp($_[0], $_[1]) <= 0" };
789 my $sge_op = sub { "sv_cmp($_[0], $_[1]) >= 0" };
790 my $eq_op = infix_op("==");
791 my $ne_op = infix_op("!=");
792 my $lt_op = infix_op("<");
793 my $gt_op = infix_op(">");
794 my $le_op = infix_op("<=");
795 my $ge_op = infix_op(">=");
796
797 #
798 # XXX The standard perl PP code has extra handling for
799 # some special case arguments of these operators.
800 #
801 sub pp_add { numeric_binop($_[0], $plus_op, INTS_CLOSED) }
802 sub pp_subtract { numeric_binop($_[0], $minus_op, INTS_CLOSED) }
803 sub pp_multiply { numeric_binop($_[0], $multiply_op, INTS_CLOSED) }
804 sub pp_divide { numeric_binop($_[0], $divide_op) }
805 sub pp_modulo { int_binop($_[0], $modulo_op) } # differs from perl's
806 sub pp_ncmp { numeric_binop($_[0], $ncmp_op, INT_RESULT) }
807
808 sub pp_left_shift { int_binop($_[0], $lshift_op) }
809 sub pp_right_shift { int_binop($_[0], $rshift_op) }
810 sub pp_i_add { int_binop($_[0], $plus_op) }
811 sub pp_i_subtract { int_binop($_[0], $minus_op) }
812 sub pp_i_multiply { int_binop($_[0], $multiply_op) }
813 sub pp_i_divide { int_binop($_[0], $divide_op) }
814 sub pp_i_modulo { int_binop($_[0], $modulo_op) }
815
816 sub pp_eq { bool_numeric_binop($_[0], $eq_op) }
817 sub pp_ne { bool_numeric_binop($_[0], $ne_op) }
818 sub pp_lt { bool_numeric_binop($_[0], $lt_op) }
819 sub pp_gt { bool_numeric_binop($_[0], $gt_op) }
820 sub pp_le { bool_numeric_binop($_[0], $le_op) }
821 sub pp_ge { bool_numeric_binop($_[0], $ge_op) }
822
823 sub pp_i_eq { bool_int_binop($_[0], $eq_op) }
824 sub pp_i_ne { bool_int_binop($_[0], $ne_op) }
825 sub pp_i_lt { bool_int_binop($_[0], $lt_op) }
826 sub pp_i_gt { bool_int_binop($_[0], $gt_op) }
827 sub pp_i_le { bool_int_binop($_[0], $le_op) }
828 sub pp_i_ge { bool_int_binop($_[0], $ge_op) }
829
830 sub pp_scmp { sv_binop($_[0], $scmp_op, INT_RESULT) }
831 sub pp_slt { bool_sv_binop($_[0], $slt_op) }
832 sub pp_sgt { bool_sv_binop($_[0], $sgt_op) }
833 sub pp_sle { bool_sv_binop($_[0], $sle_op) }
834 sub pp_sge { bool_sv_binop($_[0], $sge_op) }
835 sub pp_seq { bool_sv_binop($_[0], $seq_op) }
836 sub pp_sne { bool_sv_binop($_[0], $sne_op) }
837}
838
839
840sub pp_sassign {
841 my $op = shift;
842 my $backwards = $op->private & OPpASSIGN_BACKWARDS;
843 my ($dst, $src);
844 if (@stack >= 2) {
845 $dst = pop @stack;
846 $src = pop @stack;
847 ($src, $dst) = ($dst, $src) if $backwards;
848 my $type = $src->{type};
849 if ($type == T_INT) {
850 $dst->set_int($src->as_int);
851 } elsif ($type == T_DOUBLE) {
852 $dst->set_numeric($src->as_numeric);
853 } else {
854 $dst->set_sv($src->as_sv);
855 }
856 push(@stack, $dst);
857 } elsif (@stack == 1) {
858 if ($backwards) {
859 my $src = pop @stack;
860 my $type = $src->{type};
81009501 861 runtime("if (PL_tainting && PL_tainted) TAINT_NOT;");
a798dbf2
MB
862 if ($type == T_INT) {
863 runtime sprintf("sv_setiv(TOPs, %s);", $src->as_int);
864 } elsif ($type == T_DOUBLE) {
865 runtime sprintf("sv_setnv(TOPs, %s);", $src->as_double);
866 } else {
867 runtime sprintf("sv_setsv(TOPs, %s);", $src->as_sv);
868 }
869 runtime("SvSETMAGIC(TOPs);");
870 } else {
b8f1fa48 871 my $dst = $stack[-1];
a798dbf2
MB
872 my $type = $dst->{type};
873 runtime("sv = POPs;");
874 runtime("MAYBE_TAINT_SASSIGN_SRC(sv);");
875 if ($type == T_INT) {
876 $dst->set_int("SvIV(sv)");
877 } elsif ($type == T_DOUBLE) {
878 $dst->set_double("SvNV(sv)");
879 } else {
0bfcb1eb 880 runtime("SvSetMagicSV($dst->{sv}, sv);");
a798dbf2
MB
881 $dst->invalidate;
882 }
883 }
884 } else {
885 if ($backwards) {
886 runtime("src = POPs; dst = TOPs;");
887 } else {
888 runtime("dst = POPs; src = TOPs;");
889 }
890 runtime("MAYBE_TAINT_SASSIGN_SRC(src);",
891 "SvSetSV(dst, src);",
892 "SvSETMAGIC(dst);",
893 "SETs(dst);");
894 }
895 return $op->next;
896}
897
898sub pp_preinc {
899 my $op = shift;
900 if (@stack >= 1) {
901 my $obj = $stack[-1];
902 my $type = $obj->{type};
903 if ($type == T_INT || $type == T_DOUBLE) {
904 $obj->set_int($obj->as_int . " + 1");
905 } else {
906 runtime sprintf("PP_PREINC(%s);", $obj->as_sv);
907 $obj->invalidate();
908 }
909 } else {
910 runtime sprintf("PP_PREINC(TOPs);");
911 }
912 return $op->next;
913}
914
915sub pp_pushmark {
916 my $op = shift;
917 write_back_stack();
918 runtime("PUSHMARK(sp);");
919 return $op->next;
920}
921
922sub pp_list {
923 my $op = shift;
924 write_back_stack();
925 my $gimme = gimme($op);
a6f4eb0a 926 if ($gimme == G_ARRAY) { # sic
a798dbf2
MB
927 runtime("POPMARK;"); # need this even though not a "full" pp_list
928 } else {
929 runtime("PP_LIST($gimme);");
930 }
931 return $op->next;
932}
933
934sub pp_entersub {
935 my $op = shift;
936 write_back_lexicals(REGISTER|TEMPORARY);
937 write_back_stack();
938 my $sym = doop($op);
5cfd8ad4
VB
939 runtime("while (PL_op != ($sym)->op_next && PL_op != (OP*)0 ){");
940 runtime("PL_op = (*PL_op->op_ppaddr)(ARGS);");
941 runtime("SPAGAIN;}");
a798dbf2
MB
942 $know_op = 0;
943 invalidate_lexicals(REGISTER|TEMPORARY);
944 return $op->next;
945}
a6f4eb0a
VB
946sub pp_formline {
947 my $op = shift;
948 my $ppname = $op->ppaddr;
a6f4eb0a
VB
949 write_back_lexicals() unless $skip_lexicals{$ppname};
950 write_back_stack() unless $skip_stack{$ppname};
951 my $sym=doop($op);
952 # See comment in pp_grepwhile to see why!
953 $init->add("((LISTOP*)$sym)->op_first = $sym;");
0bfcb1eb
VB
954 runtime("if (PL_op == ((LISTOP*)($sym))->op_first){");
955 runtime( sprintf("goto %s;",label($op->first)));
a6f4eb0a
VB
956 runtime("}");
957 return $op->next;
958}
a798dbf2 959
5cfd8ad4
VB
960sub pp_goto{
961
962 my $op = shift;
963 my $ppname = $op->ppaddr;
964 write_back_lexicals() unless $skip_lexicals{$ppname};
965 write_back_stack() unless $skip_stack{$ppname};
966 my $sym=doop($op);
967 runtime("if (PL_op != ($sym)->op_next && PL_op != (OP*)0){return PL_op;}");
968 invalidate_lexicals() unless $skip_invalidate{$ppname};
969 return $op->next;
970}
a798dbf2
MB
971sub pp_enterwrite {
972 my $op = shift;
973 pp_entersub($op);
974}
975
976sub pp_leavewrite {
977 my $op = shift;
978 write_back_lexicals(REGISTER|TEMPORARY);
979 write_back_stack();
980 my $sym = doop($op);
981 # XXX Is this the right way to distinguish between it returning
982 # CvSTART(cv) (via doform) and pop_return()?
81009501 983 runtime("if (PL_op) PL_op = (*PL_op->op_ppaddr)(ARGS);");
a798dbf2
MB
984 runtime("SPAGAIN;");
985 $know_op = 0;
986 invalidate_lexicals(REGISTER|TEMPORARY);
987 return $op->next;
988}
989
990sub doeval {
991 my $op = shift;
992 $curcop->write_back;
993 write_back_lexicals(REGISTER|TEMPORARY);
994 write_back_stack();
995 my $sym = loadop($op);
996 my $ppaddr = $op->ppaddr;
997 runtime("PP_EVAL($ppaddr, ($sym)->op_next);");
998 $know_op = 1;
999 invalidate_lexicals(REGISTER|TEMPORARY);
1000 return $op->next;
1001}
1002
1003sub pp_entereval { doeval(@_) }
1004sub pp_require { doeval(@_) }
1005sub pp_dofile { doeval(@_) }
1006
1007sub pp_entertry {
1008 my $op = shift;
1009 $curcop->write_back;
1010 write_back_lexicals(REGISTER|TEMPORARY);
1011 write_back_stack();
1012 my $sym = doop($op);
1013 my $jmpbuf = sprintf("jmpbuf%d", $jmpbuf_ix++);
a6f4eb0a 1014 declare("JMPENV", $jmpbuf);
a798dbf2
MB
1015 runtime(sprintf("PP_ENTERTRY(%s,%s);", $jmpbuf, label($op->other->next)));
1016 invalidate_lexicals(REGISTER|TEMPORARY);
1017 return $op->next;
1018}
1019
a6f4eb0a
VB
1020sub pp_leavetry{
1021 my $op=shift;
1022 default_pp($op);
1023 runtime("PP_LEAVETRY;");
1024 return $op->next;
1025}
1026
a798dbf2
MB
1027sub pp_grepstart {
1028 my $op = shift;
1029 if ($need_freetmps && $freetmps_each_loop) {
1030 runtime("FREETMPS;"); # otherwise the grepwhile loop messes things up
1031 $need_freetmps = 0;
1032 }
1033 write_back_stack();
a2093a06
GS
1034 my $sym= doop($op);
1035 my $next=$op->next;
1036 $next->save;
1037 my $nexttonext=$next->next;
1038 $nexttonext->save;
1039 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1040 label($nexttonext)));
a798dbf2
MB
1041 return $op->next->other;
1042}
1043
1044sub pp_mapstart {
1045 my $op = shift;
1046 if ($need_freetmps && $freetmps_each_loop) {
1047 runtime("FREETMPS;"); # otherwise the mapwhile loop messes things up
1048 $need_freetmps = 0;
1049 }
1050 write_back_stack();
e0c90f07
VB
1051 # pp_mapstart can return either op_next->op_next or op_next->op_other and
1052 # we need to be able to distinguish the two at runtime.
1053 my $sym= doop($op);
1054 my $next=$op->next;
1055 $next->save;
1056 my $nexttonext=$next->next;
1057 $nexttonext->save;
a2093a06
GS
1058 runtime(sprintf("if (PL_op == (($sym)->op_next)->op_next) goto %s;",
1059 label($nexttonext)));
a798dbf2
MB
1060 return $op->next->other;
1061}
1062
1063sub pp_grepwhile {
1064 my $op = shift;
1065 my $next = $op->next;
1066 unshift(@bblock_todo, $next);
1067 write_back_lexicals();
1068 write_back_stack();
1069 my $sym = doop($op);
1070 # pp_grepwhile can return either op_next or op_other and we need to
1071 # be able to distinguish the two at runtime. Since it's possible for
1072 # both ops to be "inlined", the fields could both be zero. To get
1073 # around that, we hack op_next to be our own op (purely because we
1074 # know it's a non-NULL pointer and can't be the same as op_other).
1075 $init->add("((LOGOP*)$sym)->op_next = $sym;");
81009501 1076 runtime(sprintf("if (PL_op == ($sym)->op_next) goto %s;", label($next)));
a798dbf2
MB
1077 $know_op = 0;
1078 return $op->other;
1079}
1080
1081sub pp_mapwhile {
1082 pp_grepwhile(@_);
1083}
1084
1085sub pp_return {
1086 my $op = shift;
1087 write_back_lexicals(REGISTER|TEMPORARY);
1088 write_back_stack();
1089 doop($op);
a9b6343a 1090 runtime("PUTBACK;", "return PL_op;");
a798dbf2
MB
1091 $know_op = 0;
1092 return $op->next;
1093}
1094
1095sub nyi {
1096 my $op = shift;
1097 warn sprintf("%s not yet implemented properly\n", $op->ppaddr);
1098 return default_pp($op);
1099}
1100
1101sub pp_range {
1102 my $op = shift;
1103 my $flags = $op->flags;
4c1f658f 1104 if (!($flags & OPf_WANT)) {
a798dbf2
MB
1105 error("context of range unknown at compile-time");
1106 }
1107 write_back_lexicals();
1108 write_back_stack();
cfa4c8ee 1109 unless (($flags & OPf_WANT)== OPf_WANT_LIST) {
a798dbf2
MB
1110 # We need to save our UNOP structure since pp_flop uses
1111 # it to find and adjust out targ. We don't need it ourselves.
1112 $op->save;
81009501 1113 runtime sprintf("if (SvTRUE(PL_curpad[%d])) goto %s;",
a798dbf2
MB
1114 $op->targ, label($op->false));
1115 unshift(@bblock_todo, $op->false);
1116 }
1117 return $op->true;
1118}
1119
1120sub pp_flip {
1121 my $op = shift;
1122 my $flags = $op->flags;
4c1f658f 1123 if (!($flags & OPf_WANT)) {
a798dbf2
MB
1124 error("context of flip unknown at compile-time");
1125 }
cfa4c8ee 1126 if (($flags & OPf_WANT)==OPf_WANT_LIST) {
a798dbf2
MB
1127 return $op->first->false;
1128 }
1129 write_back_lexicals();
1130 write_back_stack();
1131 # We need to save our UNOP structure since pp_flop uses
1132 # it to find and adjust out targ. We don't need it ourselves.
1133 $op->save;
1134 my $ix = $op->targ;
1135 my $rangeix = $op->first->targ;
1136 runtime(($op->private & OPpFLIP_LINENUM) ?
81009501 1137 "if (PL_last_in_gv && SvIV(TOPs) == IoLINES(GvIOp(PL_last_in_gv))) {"
a798dbf2 1138 : "if (SvTRUE(TOPs)) {");
81009501 1139 runtime("\tsv_setiv(PL_curpad[$rangeix], 1);");
a798dbf2 1140 if ($op->flags & OPf_SPECIAL) {
81009501 1141 runtime("sv_setiv(PL_curpad[$ix], 1);");
a798dbf2 1142 } else {
81009501 1143 runtime("\tsv_setiv(PL_curpad[$ix], 0);",
a798dbf2
MB
1144 "\tsp--;",
1145 sprintf("\tgoto %s;", label($op->first->false)));
1146 }
1147 runtime("}",
81009501
GS
1148 qq{sv_setpv(PL_curpad[$ix], "");},
1149 "SETs(PL_curpad[$ix]);");
a798dbf2
MB
1150 $know_op = 0;
1151 return $op->next;
1152}
1153
1154sub pp_flop {
1155 my $op = shift;
1156 default_pp($op);
1157 $know_op = 0;
1158 return $op->next;
1159}
1160
1161sub enterloop {
1162 my $op = shift;
1163 my $nextop = $op->nextop;
1164 my $lastop = $op->lastop;
1165 my $redoop = $op->redoop;
1166 $curcop->write_back;
1167 debug "enterloop: pushing on cxstack" if $debug_cxstack;
1168 push(@cxstack, {
1169 type => CXt_LOOP,
1170 op => $op,
1171 "label" => $curcop->[0]->label,
1172 nextop => $nextop,
1173 lastop => $lastop,
1174 redoop => $redoop
1175 });
1176 $nextop->save;
1177 $lastop->save;
1178 $redoop->save;
1179 return default_pp($op);
1180}
1181
1182sub pp_enterloop { enterloop(@_) }
1183sub pp_enteriter { enterloop(@_) }
1184
1185sub pp_leaveloop {
1186 my $op = shift;
1187 if (!@cxstack) {
1188 die "panic: leaveloop";
1189 }
1190 debug "leaveloop: popping from cxstack" if $debug_cxstack;
1191 pop(@cxstack);
1192 return default_pp($op);
1193}
1194
1195sub pp_next {
1196 my $op = shift;
1197 my $cxix;
1198 if ($op->flags & OPf_SPECIAL) {
1199 $cxix = dopoptoloop();
1200 if ($cxix < 0) {
1201 error('"next" used outside loop');
1202 return $op->next; # ignore the op
1203 }
1204 } else {
1205 $cxix = dopoptolabel($op->pv);
1206 if ($cxix < 0) {
1207 error('Label not found at compile time for "next %s"', $op->pv);
1208 return $op->next; # ignore the op
1209 }
1210 }
1211 default_pp($op);
1212 my $nextop = $cxstack[$cxix]->{nextop};
1213 push(@bblock_todo, $nextop);
1214 runtime(sprintf("goto %s;", label($nextop)));
1215 return $op->next;
1216}
1217
1218sub pp_redo {
1219 my $op = shift;
1220 my $cxix;
1221 if ($op->flags & OPf_SPECIAL) {
1222 $cxix = dopoptoloop();
1223 if ($cxix < 0) {
1224 error('"redo" used outside loop');
1225 return $op->next; # ignore the op
1226 }
1227 } else {
1228 $cxix = dopoptolabel($op->pv);
1229 if ($cxix < 0) {
1230 error('Label not found at compile time for "redo %s"', $op->pv);
1231 return $op->next; # ignore the op
1232 }
1233 }
1234 default_pp($op);
1235 my $redoop = $cxstack[$cxix]->{redoop};
1236 push(@bblock_todo, $redoop);
1237 runtime(sprintf("goto %s;", label($redoop)));
1238 return $op->next;
1239}
1240
1241sub pp_last {
1242 my $op = shift;
1243 my $cxix;
1244 if ($op->flags & OPf_SPECIAL) {
1245 $cxix = dopoptoloop();
1246 if ($cxix < 0) {
1247 error('"last" used outside loop');
1248 return $op->next; # ignore the op
1249 }
1250 } else {
1251 $cxix = dopoptolabel($op->pv);
1252 if ($cxix < 0) {
1253 error('Label not found at compile time for "last %s"', $op->pv);
1254 return $op->next; # ignore the op
1255 }
1256 # XXX Add support for "last" to leave non-loop blocks
1257 if ($cxstack[$cxix]->{type} != CXt_LOOP) {
1258 error('Use of "last" for non-loop blocks is not yet implemented');
1259 return $op->next; # ignore the op
1260 }
1261 }
1262 default_pp($op);
1263 my $lastop = $cxstack[$cxix]->{lastop}->next;
1264 push(@bblock_todo, $lastop);
1265 runtime(sprintf("goto %s;", label($lastop)));
1266 return $op->next;
1267}
1268
1269sub pp_subst {
1270 my $op = shift;
1271 write_back_lexicals();
1272 write_back_stack();
1273 my $sym = doop($op);
1274 my $replroot = $op->pmreplroot;
1275 if ($$replroot) {
81009501 1276 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplroot) goto %s;",
a798dbf2
MB
1277 $sym, label($replroot));
1278 $op->pmreplstart->save;
1279 push(@bblock_todo, $replroot);
1280 }
1281 invalidate_lexicals();
1282 return $op->next;
1283}
1284
1285sub pp_substcont {
1286 my $op = shift;
1287 write_back_lexicals();
1288 write_back_stack();
1289 doop($op);
1290 my $pmop = $op->other;
0cc1d052
NIS
1291 # warn sprintf("substcont: op = %s, pmop = %s\n",
1292 # peekop($op), peekop($pmop));#debug
1293# my $pmopsym = objsym($pmop);
a798dbf2 1294 my $pmopsym = $pmop->save; # XXX can this recurse?
0cc1d052 1295# warn "pmopsym = $pmopsym\n";#debug
81009501 1296 runtime sprintf("if (PL_op == ((PMOP*)(%s))->op_pmreplstart) goto %s;",
a798dbf2
MB
1297 $pmopsym, label($pmop->pmreplstart));
1298 invalidate_lexicals();
1299 return $pmop->next;
1300}
1301
1302sub default_pp {
1303 my $op = shift;
1304 my $ppname = $op->ppaddr;
df2464c8
VB
1305 if ($curcop and $need_curcop{$ppname}){
1306 $curcop->write_back;
1307 }
a798dbf2
MB
1308 write_back_lexicals() unless $skip_lexicals{$ppname};
1309 write_back_stack() unless $skip_stack{$ppname};
1310 doop($op);
1311 # XXX If the only way that ops can write to a TEMPORARY lexical is
1312 # when it's named in $op->targ then we could call
1313 # invalidate_lexicals(TEMPORARY) and avoid having to write back all
1314 # the temporaries. For now, we'll play it safe and write back the lot.
1315 invalidate_lexicals() unless $skip_invalidate{$ppname};
1316 return $op->next;
1317}
1318
1319sub compile_op {
1320 my $op = shift;
1321 my $ppname = $op->ppaddr;
1322 if (exists $ignore_op{$ppname}) {
1323 return $op->next;
1324 }
1325 debug peek_stack() if $debug_stack;
1326 if ($debug_op) {
1327 debug sprintf("%s [%s]\n",
1328 peekop($op),
1329 $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
1330 }
1331 no strict 'refs';
1332 if (defined(&$ppname)) {
1333 $know_op = 0;
1334 return &$ppname($op);
1335 } else {
1336 return default_pp($op);
1337 }
1338}
1339
1340sub compile_bblock {
1341 my $op = shift;
1342 #warn "compile_bblock: ", peekop($op), "\n"; # debug
1343 write_label($op);
1344 $know_op = 0;
1345 do {
1346 $op = compile_op($op);
1347 } while (defined($op) && $$op && !exists($leaders->{$$op}));
1348 write_back_stack(); # boo hoo: big loss
1349 reload_lexicals();
1350 return $op;
1351}
1352
1353sub cc {
1354 my ($name, $root, $start, @padlist) = @_;
1355 my $op;
1356 init_pp($name);
1357 load_pad(@padlist);
1358 B::Pseudoreg->new_scope;
1359 @cxstack = ();
1360 if ($debug_timings) {
1361 warn sprintf("Basic block analysis at %s\n", timing_info);
1362 }
1363 $leaders = find_leaders($root, $start);
1364 @bblock_todo = ($start, values %$leaders);
1365 if ($debug_timings) {
1366 warn sprintf("Compilation at %s\n", timing_info);
1367 }
1368 while (@bblock_todo) {
1369 $op = shift @bblock_todo;
1370 #warn sprintf("Considering basic block %s\n", peekop($op)); # debug
1371 next if !defined($op) || !$$op || $done{$$op};
1372 #warn "...compiling it\n"; # debug
1373 do {
1374 $done{$$op} = 1;
1375 $op = compile_bblock($op);
1376 if ($need_freetmps && $freetmps_each_bblock) {
1377 runtime("FREETMPS;");
1378 $need_freetmps = 0;
1379 }
1380 } while defined($op) && $$op && !$done{$$op};
1381 if ($need_freetmps && $freetmps_each_loop) {
1382 runtime("FREETMPS;");
1383 $need_freetmps = 0;
1384 }
1385 if (!$$op) {
a9b6343a 1386 runtime("PUTBACK;","return PL_op;");
a798dbf2
MB
1387 } elsif ($done{$$op}) {
1388 runtime(sprintf("goto %s;", label($op)));
1389 }
1390 }
1391 if ($debug_timings) {
1392 warn sprintf("Saving runtime at %s\n", timing_info);
1393 }
1394 save_runtime();
1395}
1396
1397sub cc_recurse {
1398 my $ccinfo;
1399 my $start;
1400 $start = cc_queue(@_) if @_;
1401 while ($ccinfo = shift @cc_todo) {
1402 cc(@$ccinfo);
1403 }
1404 return $start;
1405}
1406
1407sub cc_obj {
1408 my ($name, $cvref) = @_;
1409 my $cv = svref_2object($cvref);
1410 my @padlist = $cv->PADLIST->ARRAY;
1411 my $curpad_sym = $padlist[1]->save;
1412 cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
1413}
1414
1415sub cc_main {
1416 my @comppadlist = comppadlist->ARRAY;
0cc1d052
NIS
1417 my $curpad_nam = $comppadlist[0]->save;
1418 my $curpad_sym = $comppadlist[1]->save;
1419 my $init_av = init_av->save;
a798dbf2 1420 my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
cfa4c8ee 1421 # Do save_unused_subs before saving inc_hv
0cc1d052 1422 save_unused_subs();
a798dbf2
MB
1423 cc_recurse();
1424
cfa4c8ee
VB
1425 my $inc_hv = svref_2object(\%INC)->save;
1426 my $inc_av = svref_2object(\@INC)->save;
a798dbf2
MB
1427 return if $errors;
1428 if (!defined($module)) {
81009501
GS
1429 $init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
1430 "PL_main_start = $start;",
5cfd8ad4 1431 "PL_curpad = AvARRAY($curpad_sym);",
0cc1d052
NIS
1432 "PL_initav = $init_av;",
1433 "GvHV(PL_incgv) = $inc_hv;",
1434 "GvAV(PL_incgv) = $inc_av;",
5cfd8ad4 1435 "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
44887cfa
NIS
1436 "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
1437 );
1438
a798dbf2 1439 }
73544139 1440 seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
a798dbf2
MB
1441 output_boilerplate();
1442 print "\n";
1443 output_all("perl_init");
1444 output_runtime();
1445 print "\n";
1446 output_main();
1447 if (defined($module)) {
1448 my $cmodule = $module;
1449 $cmodule =~ s/::/__/g;
1450 print <<"EOT";
1451
1452#include "XSUB.h"
1453XS(boot_$cmodule)
1454{
1455 dXSARGS;
1456 perl_init();
1457 ENTER;
1458 SAVETMPS;
81009501
GS
1459 SAVESPTR(PL_curpad);
1460 SAVESPTR(PL_op);
1461 PL_curpad = AvARRAY($curpad_sym);
1462 PL_op = $start;
a798dbf2
MB
1463 pp_main(ARGS);
1464 FREETMPS;
1465 LEAVE;
81009501 1466 ST(0) = &PL_sv_yes;
a798dbf2
MB
1467 XSRETURN(1);
1468}
1469EOT
1470 }
1471 if ($debug_timings) {
1472 warn sprintf("Done at %s\n", timing_info);
1473 }
1474}
1475
1476sub compile {
1477 my @options = @_;
1478 my ($option, $opt, $arg);
1479 OPTION:
1480 while ($option = shift @options) {
1481 if ($option =~ /^-(.)(.*)/) {
1482 $opt = $1;
1483 $arg = $2;
1484 } else {
1485 unshift @options, $option;
1486 last OPTION;
1487 }
1488 if ($opt eq "-" && $arg eq "-") {
1489 shift @options;
1490 last OPTION;
1491 } elsif ($opt eq "o") {
1492 $arg ||= shift @options;
ff06c60c 1493 open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
a798dbf2
MB
1494 } elsif ($opt eq "n") {
1495 $arg ||= shift @options;
1496 $module_name = $arg;
1497 } elsif ($opt eq "u") {
1498 $arg ||= shift @options;
0cc1d052 1499 mark_unused($arg,undef);
a798dbf2
MB
1500 } elsif ($opt eq "f") {
1501 $arg ||= shift @options;
1502 my $value = $arg !~ s/^no-//;
1503 $arg =~ s/-/_/g;
1504 my $ref = $optimise{$arg};
1505 if (defined($ref)) {
1506 $$ref = $value;
1507 } else {
1508 warn qq(ignoring unknown optimisation option "$arg"\n);
1509 }
1510 } elsif ($opt eq "O") {
1511 $arg = 1 if $arg eq "";
1512 my $ref;
1513 foreach $ref (values %optimise) {
1514 $$ref = 0;
1515 }
1516 if ($arg >= 2) {
1517 $freetmps_each_loop = 1;
1518 }
1519 if ($arg >= 1) {
1520 $freetmps_each_bblock = 1 unless $freetmps_each_loop;
1521 }
1522 } elsif ($opt eq "m") {
1523 $arg ||= shift @options;
1524 $module = $arg;
a9b6343a 1525 mark_unused($arg,undef);
a798dbf2
MB
1526 } elsif ($opt eq "p") {
1527 $arg ||= shift @options;
1528 $patchlevel = $arg;
1529 } elsif ($opt eq "D") {
1530 $arg ||= shift @options;
1531 foreach $arg (split(//, $arg)) {
1532 if ($arg eq "o") {
1533 B->debug(1);
1534 } elsif ($arg eq "O") {
1535 $debug_op = 1;
1536 } elsif ($arg eq "s") {
1537 $debug_stack = 1;
1538 } elsif ($arg eq "c") {
1539 $debug_cxstack = 1;
1540 } elsif ($arg eq "p") {
1541 $debug_pad = 1;
1542 } elsif ($arg eq "r") {
1543 $debug_runtime = 1;
1544 } elsif ($arg eq "S") {
1545 $debug_shadow = 1;
1546 } elsif ($arg eq "q") {
1547 $debug_queue = 1;
1548 } elsif ($arg eq "l") {
1549 $debug_lineno = 1;
1550 } elsif ($arg eq "t") {
1551 $debug_timings = 1;
1552 }
1553 }
1554 }
1555 }
1556 init_sections();
1557 $init = B::Section->get("init");
1558 $decl = B::Section->get("decl");
1559
1560 if (@options) {
1561 return sub {
1562 my ($objname, $ppname);
1563 foreach $objname (@options) {
1564 $objname = "main::$objname" unless $objname =~ /::/;
1565 ($ppname = $objname) =~ s/^.*?:://;
1566 eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
1567 die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
1568 return if $errors;
1569 }
1570 output_boilerplate();
1571 print "\n";
1572 output_all($module_name || "init_module");
1573 output_runtime();
1574 }
1575 } else {
1576 return sub { cc_main() };
1577 }
1578}
1579
15801;
7f20e9dd
GS
1581
1582__END__
1583
1584=head1 NAME
1585
1586B::CC - Perl compiler's optimized C translation backend
1587
1588=head1 SYNOPSIS
1589
1590 perl -MO=CC[,OPTIONS] foo.pl
1591
1592=head1 DESCRIPTION
1593
1a52ab62
MB
1594This compiler backend takes Perl source and generates C source code
1595corresponding to the flow of your program. In other words, this
1596backend is somewhat a "real" compiler in the sense that many people
1597think about compilers. Note however that, currently, it is a very
1598poor compiler in that although it generates (mostly, or at least
1599sometimes) correct code, it performs relatively few optimisations.
1600This will change as the compiler develops. The result is that
1601running an executable compiled with this backend may start up more
1602quickly than running the original Perl program (a feature shared
1603by the B<C> compiler backend--see F<B::C>) and may also execute
1604slightly faster. This is by no means a good optimising compiler--yet.
1605
1606=head1 OPTIONS
1607
1608If there are any non-option arguments, they are taken to be
1609names of objects to be saved (probably doesn't work properly yet).
1610Without extra arguments, it saves the main program.
1611
1612=over 4
1613
1614=item B<-ofilename>
1615
1616Output to filename instead of STDOUT
1617
1618=item B<-v>
1619
1620Verbose compilation (currently gives a few compilation statistics).
1621
1622=item B<-->
1623
1624Force end of options
1625
1626=item B<-uPackname>
1627
1628Force apparently unused subs from package Packname to be compiled.
1629This allows programs to use eval "foo()" even when sub foo is never
1630seen to be used at compile time. The down side is that any subs which
1631really are never used also have code generated. This option is
1632necessary, for example, if you have a signal handler foo which you
1633initialise with C<$SIG{BAR} = "foo">. A better fix, though, is just
1634to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
1635options. The compiler tries to figure out which packages may possibly
1636have subs in which need compiling but the current version doesn't do
1637it very well. In particular, it is confused by nested packages (i.e.
1638of the form C<A::B>) where package C<A> does not contain any subs.
1639
1640=item B<-mModulename>
1641
1642Instead of generating source for a runnable executable, generate
1643source for an XSUB module. The boot_Modulename function (which
1644DynaLoader can look for) does the appropriate initialisation and runs
1645the main part of the Perl source that is being compiled.
1646
1647
1648=item B<-D>
1649
1650Debug options (concatenated or separate flags like C<perl -D>).
1651
1652=item B<-Dr>
1653
1654Writes debugging output to STDERR just as it's about to write to the
1655program's runtime (otherwise writes debugging info as comments in
1656its C output).
1657
1658=item B<-DO>
1659
1660Outputs each OP as it's compiled
1661
1662=item B<-Ds>
1663
1664Outputs the contents of the shadow stack at each OP
1665
1666=item B<-Dp>
1667
1668Outputs the contents of the shadow pad of lexicals as it's loaded for
1669each sub or the main program.
1670
1671=item B<-Dq>
1672
1673Outputs the name of each fake PP function in the queue as it's about
1674to process it.
1675
1676=item B<-Dl>
1677
1678Output the filename and line number of each original line of Perl
1679code as it's processed (C<pp_nextstate>).
1680
1681=item B<-Dt>
1682
1683Outputs timing information of compilation stages.
1684
1685=item B<-f>
1686
1687Force optimisations on or off one at a time.
1688
1689=item B<-ffreetmps-each-bblock>
1690
1691Delays FREETMPS from the end of each statement to the end of the each
1692basic block.
1693
1694=item B<-ffreetmps-each-loop>
1695
1696Delays FREETMPS from the end of each statement to the end of the group
1697of basic blocks forming a loop. At most one of the freetmps-each-*
1698options can be used.
1699
1700=item B<-fomit-taint>
1701
1702Omits generating code for handling perl's tainting mechanism.
1703
1704=item B<-On>
1705
1706Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
1707Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
1708sets B<-ffreetmps-each-loop>.
1709
1710=back
1711
1712=head1 EXAMPLES
1713
1714 perl -MO=CC,-O2,-ofoo.c foo.pl
1715 perl cc_harness -o foo foo.c
1716
1717Note that C<cc_harness> lives in the C<B> subdirectory of your perl
1718library directory. The utility called C<perlcc> may also be used to
1719help make use of this compiler.
1720
1721 perl -MO=CC,-mFoo,-oFoo.c Foo.pm
1722 perl cc_harness -shared -c -o Foo.so Foo.c
1723
1724=head1 BUGS
1725
1726Plenty. Current status: experimental.
1727
1728=head1 DIFFERENCES
1729
1730These aren't really bugs but they are constructs which are heavily
1731tied to perl's compile-and-go implementation and with which this
1732compiler backend cannot cope.
1733
1734=head2 Loops
1735
1736Standard perl calculates the target of "next", "last", and "redo"
1737at run-time. The compiler calculates the targets at compile-time.
1738For example, the program
1739
1740 sub skip_on_odd { next NUMBER if $_[0] % 2 }
1741 NUMBER: for ($i = 0; $i < 5; $i++) {
1742 skip_on_odd($i);
1743 print $i;
1744 }
1745
1746produces the output
1747
1748 024
1749
1750with standard perl but gives a compile-time error with the compiler.
1751
1752=head2 Context of ".."
1753
1754The context (scalar or array) of the ".." operator determines whether
1755it behaves as a range or a flip/flop. Standard perl delays until
1756runtime the decision of which context it is in but the compiler needs
1757to know the context at compile-time. For example,
1758
1759 @a = (4,6,1,0,0,1);
1760 sub range { (shift @a)..(shift @a) }
1761 print range();
1762 while (@a) { print scalar(range()) }
1763
1764generates the output
1765
1766 456123E0
1767
1768with standard Perl but gives a compile-time error with compiled Perl.
1769
1770=head2 Arithmetic
1771
1772Compiled Perl programs use native C arithemtic much more frequently
1773than standard perl. Operations on large numbers or on boundary
1774cases may produce different behaviour.
1775
1776=head2 Deprecated features
1777
1778Features of standard perl such as C<$[> which have been deprecated
1779in standard perl since Perl5 was released have not been implemented
1780in the compiler.
7f20e9dd
GS
1781
1782=head1 AUTHOR
1783
1784Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1785
1786=cut