ext/B/B/CC.pm

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