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