cc.pm

Altera recommends the following system configuration: * Pentium II 400 with 512-MB system memory (fa

    my $ppname = "pp_" . $op->name;
    if ($curcop and $need_curcop{$ppname}){
	$curcop->write_back;
    }
    write_back_lexicals() unless $skip_lexicals{$ppname};
    write_back_stack() unless $skip_stack{$ppname};
    doop($op);
    # XXX If the only way that ops can write to a TEMPORARY lexical is
    # when it's named in $op->targ then we could call
    # invalidate_lexicals(TEMPORARY) and avoid having to write back all
    # the temporaries. For now, we'll play it safe and write back the lot.
    invalidate_lexicals() unless $skip_invalidate{$ppname};
    return $op->next;
}

sub compile_op {
    my $op = shift;
    my $ppname = "pp_" . $op->name;
    if (exists $ignore_op{$ppname}) {
	return $op->next;
    }
    debug peek_stack() if $debug_stack;
    if ($debug_op) {
	debug sprintf("%s [%s]\n",
		     peekop($op),
		     $op->flags & OPf_STACKED ? "OPf_STACKED" : $op->targ);
    }
    no strict 'refs';
    if (defined(&$ppname)) {
	$know_op = 0;
	return &$ppname($op);
    } else {
	return default_pp($op);
    }
}

sub compile_bblock {
    my $op = shift;
    #warn "compile_bblock: ", peekop($op), "\n"; # debug
    save_or_restore_lexical_state($$op);
    write_label($op);
    $know_op = 0;
    do {
	$op = compile_op($op);
    } while (defined($op) && $$op && !exists($leaders->{$$op}));
    write_back_stack(); # boo hoo: big loss
    reload_lexicals();
    return $op;
}

sub cc {
    my ($name, $root, $start, @padlist) = @_;
    my $op;
    if($done{$$start}){ 
    	#warn "repeat=>".ref($start)."$name,\n";#debug
	$decl->add(sprintf("#define $name  %s",$done{$$start}));
	return;
    }
    init_pp($name);
    load_pad(@padlist);
    %lexstate=();
    B::Pseudoreg->new_scope;
    @cxstack = ();
    if ($debug_timings) {
	warn sprintf("Basic block analysis at %s\n", timing_info);
    }
    $leaders = find_leaders($root, $start);
    my @leaders= keys %$leaders; 
    if ($#leaders > -1) { 
    	@bblock_todo = ($start, values %$leaders) ;
    } else{
	runtime("return PL_op?PL_op->op_next:0;");
    }
    if ($debug_timings) {
	warn sprintf("Compilation at %s\n", timing_info);
    }
    while (@bblock_todo) {
	$op = shift @bblock_todo;
	#warn sprintf("Considering basic block %s\n", peekop($op)); # debug
	next if !defined($op) || !$$op || $done{$$op};
	#warn "...compiling it\n"; # debug
	do {
	    $done{$$op} = $name;
	    $op = compile_bblock($op);
	    if ($need_freetmps && $freetmps_each_bblock) {
		runtime("FREETMPS;");
		$need_freetmps = 0;
	    }
	} while defined($op) && $$op && !$done{$$op};
	if ($need_freetmps && $freetmps_each_loop) {
	    runtime("FREETMPS;");
	    $need_freetmps = 0;
	}
	if (!$$op) {
	    runtime("PUTBACK;","return PL_op;");
	} elsif ($done{$$op}) {
    	    save_or_restore_lexical_state($$op);
	    runtime(sprintf("goto %s;", label($op)));
	}
    }
    if ($debug_timings) {
	warn sprintf("Saving runtime at %s\n", timing_info);
    }
    declare_pad(@padlist) ;
    save_runtime();
}

sub cc_recurse {
    my $ccinfo;
    my $start;
    $start = cc_queue(@_) if @_;
    while ($ccinfo = shift @cc_todo) {
	cc(@$ccinfo);
    }
    return $start;
}    

sub cc_obj {
    my ($name, $cvref) = @_;
    my $cv = svref_2object($cvref);
    my @padlist = $cv->PADLIST->ARRAY;
    my $curpad_sym = $padlist[1]->save;
    cc_recurse($name, $cv->ROOT, $cv->START, @padlist);
}

sub cc_main {
    my @comppadlist = comppadlist->ARRAY;
    my $curpad_nam  = $comppadlist[0]->save;
    my $curpad_sym  = $comppadlist[1]->save;
    my $init_av     = init_av->save; 
    my $start = cc_recurse("pp_main", main_root, main_start, @comppadlist);
    # Do save_unused_subs before saving inc_hv
    save_unused_subs();
    cc_recurse();

    my $inc_hv      = svref_2object(\%INC)->save;
    my $inc_av      = svref_2object(\@INC)->save;
    my $amagic_generate= amagic_generation;
    return if $errors;
    if (!defined($module)) {
	$init->add(sprintf("PL_main_root = s\\_%x;", ${main_root()}),
		   "PL_main_start = $start;",
		   "PL_curpad = AvARRAY($curpad_sym);",
		   "PL_initav = (AV *) $init_av;",
		   "GvHV(PL_incgv) = $inc_hv;",
		   "GvAV(PL_incgv) = $inc_av;",
		   "av_store(CvPADLIST(PL_main_cv),0,SvREFCNT_inc($curpad_nam));",
		   "av_store(CvPADLIST(PL_main_cv),1,SvREFCNT_inc($curpad_sym));",
		   "PL_amagic_generation= $amagic_generate;",
		     );
                 
    }
    seek(STDOUT,0,0); #prevent print statements from BEGIN{} into the output
    output_boilerplate();
    print "\n";
    output_all("perl_init");
    output_runtime();
    print "\n";
    output_main();
    if (defined($module)) {
	my $cmodule = $module;
	$cmodule =~ s/::/__/g;
	print <<"EOT";

#include "XSUB.h"
XS(boot_$cmodule)
{
    dXSARGS;
    perl_init();
    ENTER;
    SAVETMPS;
    SAVEVPTR(PL_curpad);
    SAVEVPTR(PL_op);
    PL_curpad = AvARRAY($curpad_sym);
    PL_op = $start;
    pp_main(aTHX);
    FREETMPS;
    LEAVE;
    ST(0) = &PL_sv_yes;
    XSRETURN(1);
}
EOT
    }
    if ($debug_timings) {
	warn sprintf("Done at %s\n", timing_info);
    }
}

sub compile {
    my @options = @_;
    my ($option, $opt, $arg);
  OPTION:
    while ($option = shift @options) {
	if ($option =~ /^-(.)(.*)/) {
	    $opt = $1;
	    $arg = $2;
	} else {
	    unshift @options, $option;
	    last OPTION;
	}
	if ($opt eq "-" && $arg eq "-") {
	    shift @options;
	    last OPTION;
	} elsif ($opt eq "o") {
	    $arg ||= shift @options;
	    open(STDOUT, ">$arg") or return "open '>$arg': $!\n";
	} elsif ($opt eq "n") {
	    $arg ||= shift @options;
	    $module_name = $arg;
	} elsif ($opt eq "u") {
	    $arg ||= shift @options;
	    mark_unused($arg,undef);
	} elsif ($opt eq "f") {
	    $arg ||= shift @options;
	    my $value = $arg !~ s/^no-//;
	    $arg =~ s/-/_/g;
	    my $ref = $optimise{$arg};
	    if (defined($ref)) {
		$$ref = $value;
	    } else {
		warn qq(ignoring unknown optimisation option "$arg"\n);
	    }
	} elsif ($opt eq "O") {
	    $arg = 1 if $arg eq "";
	    my $ref;
	    foreach $ref (values %optimise) {
		$$ref = 0;
	    }
	    if ($arg >= 2) {
		$freetmps_each_loop = 1;
	    }
	    if ($arg >= 1) {
		$freetmps_each_bblock = 1 unless $freetmps_each_loop;
	    }
	} elsif ($opt eq "m") {
	    $arg ||= shift @options;
	    $module = $arg;
	    mark_unused($arg,undef);
	} elsif ($opt eq "p") {
	    $arg ||= shift @options;
	    $patchlevel = $arg;
	} elsif ($opt eq "D") {
            $arg ||= shift @options;
	    foreach $arg (split(//, $arg)) {
		if ($arg eq "o") {
		    B->debug(1);
		} elsif ($arg eq "O") {
		    $debug_op = 1;
		} elsif ($arg eq "s") {
		    $debug_stack = 1;
		} elsif ($arg eq "c") {
		    $debug_cxstack = 1;
		} elsif ($arg eq "p") {
		    $debug_pad = 1;
		} elsif ($arg eq "r") {
		    $debug_runtime = 1;
		} elsif ($arg eq "S") {
		    $debug_shadow = 1;
		} elsif ($arg eq "q") {
		    $debug_queue = 1;
		} elsif ($arg eq "l") {
		    $debug_lineno = 1;
		} elsif ($arg eq "t") {
		    $debug_timings = 1;
		}
	    }
	}
    }
    init_sections();
    $init = B::Section->get("init");
    $decl = B::Section->get("decl");

    if (@options) {
	return sub {
	    my ($objname, $ppname);
	    foreach $objname (@options) {
		$objname = "main::$objname" unless $objname =~ /::/;
		($ppname = $objname) =~ s/^.*?:://;
		eval "cc_obj(qq(pp_sub_$ppname), \\&$objname)";
		die "cc_obj(qq(pp_sub_$ppname, \\&$objname) failed: $@" if $@;
		return if $errors;
	    }
	    output_boilerplate();
	    print "\n";
	    output_all($module_name || "init_module");
	    output_runtime();
	}
    } else {
	return sub { cc_main() };
    }
}

1;

__END__

=head1 NAME

B::CC - Perl compiler's optimized C translation backend

=head1 SYNOPSIS

	perl -MO=CC[,OPTIONS] foo.pl

=head1 DESCRIPTION

This compiler backend takes Perl source and generates C source code
corresponding to the flow of your program. In other words, this
backend is somewhat a "real" compiler in the sense that many people
think about compilers. Note however that, currently, it is a very
poor compiler in that although it generates (mostly, or at least
sometimes) correct code, it performs relatively few optimisations.
This will change as the compiler develops. The result is that
running an executable compiled with this backend may start up more
quickly than running the original Perl program (a feature shared
by the B<C> compiler backend--see F<B::C>) and may also execute
slightly faster. This is by no means a good optimising compiler--yet.

=head1 OPTIONS

If there are any non-option arguments, they are taken to be
names of objects to be saved (probably doesn't work properly yet).
Without extra arguments, it saves the main program.

=over 4

=item B<-ofilename>

Output to filename instead of STDOUT

=item B<-v>

Verbose compilation (currently gives a few compilation statistics).

=item B<-->

Force end of options

=item B<-uPackname>

Force apparently unused subs from package Packname to be compiled.
This allows programs to use eval "foo()" even when sub foo is never
seen to be used at compile time. The down side is that any subs which
really are never used also have code generated. This option is
necessary, for example, if you have a signal handler foo which you
initialise with C<$SIG{BAR} = "foo">.  A better fix, though, is just
to change it to C<$SIG{BAR} = \&foo>. You can have multiple B<-u>
options. The compiler tries to figure out which packages may possibly
have subs in which need compiling but the current version doesn't do
it very well. In particular, it is confused by nested packages (i.e.
of the form C<A::B>) where package C<A> does not contain any subs.

=item B<-mModulename>

Instead of generating source for a runnable executable, generate
source for an XSUB module. The boot_Modulename function (which
DynaLoader can look for) does the appropriate initialisation and runs
the main part of the Perl source that is being compiled.


=item B<-D>

Debug options (concatenated or separate flags like C<perl -D>).

=item B<-Dr>

Writes debugging output to STDERR just as it's about to write to the
program's runtime (otherwise writes debugging info as comments in
its C output).

=item B<-DO>

Outputs each OP as it's compiled

=item B<-Ds>

Outputs the contents of the shadow stack at each OP

=item B<-Dp>

Outputs the contents of the shadow pad of lexicals as it's loaded for
each sub or the main program.

=item B<-Dq>

Outputs the name of each fake PP function in the queue as it's about
to process it.

=item B<-Dl>

Output the filename and line number of each original line of Perl
code as it's processed (C<pp_nextstate>).

=item B<-Dt>

Outputs timing information of compilation stages.

=item B<-f>

Force optimisations on or off one at a time.

=item B<-ffreetmps-each-bblock>

Delays FREETMPS from the end of each statement to the end of the each
basic block.

=item B<-ffreetmps-each-loop>

Delays FREETMPS from the end of each statement to the end of the group
of basic blocks forming a loop. At most one of the freetmps-each-*
options can be used.

=item B<-fomit-taint>

Omits generating code for handling perl's tainting mechanism.

=item B<-On>

Optimisation level (n = 0, 1, 2, ...). B<-O> means B<-O1>.
Currently, B<-O1> sets B<-ffreetmps-each-bblock> and B<-O2>
sets B<-ffreetmps-each-loop>.

=back

=head1 EXAMPLES

        perl -MO=CC,-O2,-ofoo.c foo.pl
        perl cc_harness -o foo foo.c

Note that C<cc_harness> lives in the C<B> subdirectory of your perl
library directory. The utility called C<perlcc> may also be used to
help make use of this compiler.

        perl -MO=CC,-mFoo,-oFoo.c Foo.pm
        perl cc_harness -shared -c -o Foo.so Foo.c

=head1 BUGS

Plenty. Current status: experimental.

=head1 DIFFERENCES

These aren't really bugs but they are constructs which are heavily
tied to perl's compile-and-go implementation and with which this
compiler backend cannot cope.

=head2 Loops

Standard perl calculates the target of "next", "last", and "redo"
at run-time. The compiler calculates the targets at compile-time.
For example, the program

    sub skip_on_odd { next NUMBER if $_[0] % 2 }
    NUMBER: for ($i = 0; $i < 5; $i++) {
        skip_on_odd($i);
        print $i;
    }

produces the output

    024

with standard perl but gives a compile-time error with the compiler.

=head2 Context of ".."

The context (scalar or array) of the ".." operator determines whether
it behaves as a range or a flip/flop. Standard perl delays until
runtime the decision of which context it is in but the compiler needs
to know the context at compile-time. For example,

    @a = (4,6,1,0,0,1);
    sub range { (shift @a)..(shift @a) }
    print range();
    while (@a) { print scalar(range()) }

generates the output

    456123E0

with standard Perl but gives a compile-time error with compiled Perl.

=head2 Arithmetic

Compiled Perl programs use native C arithemtic much more frequently
than standard perl. Operations on large numbers or on boundary
cases may produce different behaviour.

=head2 Deprecated features

Features of standard perl such as C<$[> which have been deprecated
in standard perl since Perl5 was released have not been implemented
in the compiler.

=head1 AUTHOR

Malcolm Beattie, C<[e-mail]>

=cut