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