Here is a patch that makes pbc2c generated code work with the bsr opcode. It creates a new opcode 'enternative', and uses this to support a mixed model of interpretation and execution of compiled C code.
Initially, an interpreter is created and started in order to execute a modified copy of the bytecode. At certain known branch target addresses, the original opcode is replaced by an 'enternative' opcode, which switches to execution of the compiled C code. If a branch to a target address not identified by pbc2c occurs, the compiled C code returns control to the interpreter which executes the original bytecode until another 'enternative' opcode is encountered. I'm also including a version of mops.pasm that includes a bsr opcode to test the changes to pbc2c. -- Jason
Index: core.ops =================================================================== RCS file: /home/perlcvs/parrot/core.ops,v retrieving revision 1.72 diff -u -r1.72 core.ops --- core.ops 9 Jan 2002 17:24:11 -0000 1.72 +++ core.ops 10 Jan 2002 22:56:19 -0000 @@ -2475,6 +2475,10 @@ goto NEXT(); } +op enternative() { + goto ADDRESS(run_native(interpreter, CUR_OPCODE, (opcode_t +*)interpreter->code->byte_code)); +} + ######################################## =item B<new>(out PMC, in INT) Index: pbc2c.pl =================================================================== RCS file: /home/perlcvs/parrot/pbc2c.pl,v retrieving revision 1.11 diff -u -r1.11 pbc2c.pl --- pbc2c.pl 3 Jan 2002 19:41:46 -0000 1.11 +++ pbc2c.pl 10 Jan 2002 22:56:19 -0000 @@ -18,6 +18,7 @@ use Parrot::PackFile::ConstTable; use Parrot::OpsFile; use Parrot::OpTrans::CGoto; +use Parrot::OpLib::core; my $trans = Parrot::OpTrans::CGoto->new; @@ -67,88 +68,46 @@ # compile_byte_code() # -my $pc; -my $new_pc = 1; my @args = (); sub compile_byte_code { - my ($pf) = @_; - - my $nconst = $pf->const_table->const_count; + my ($pf, $file_name) = @_; + my ($byte_code); + my $pc; + my $new_pc = 0; + my $offset=0; + my $op_code; + my $op; + my %leaders; + my @pc_list; + my @blocks; + my %opcodes; print <<END_C; #include "parrot/parrot.h" #include "parrot/string.h" END_C + print $trans->defines; print $ops->preamble; - print <<END_C; - -int -main(int argc, char **argv) { - int i; - struct Parrot_Interp * interpreter; - struct PackFile_Constant * c; - struct PackFile * pf; - - init_world(); - - interpreter = make_interpreter(0); - pf = PackFile_new(); - - interpreter->code = pf; - -END_C - - for(my $i = 0; $i < $nconst; $i++) { - my $const = $pf->const_table->constant($i); - my $value = $const->value; - - if ($const->type eq Parrot::PackFile::Constant::type_code('PFC_INTEGER')) { # TODO: Don't hardocde these codes. - print <<END_C; - c = PackFile_Constant_new_integer($value); -END_C - } elsif ($const->type eq Parrot::PackFile::Constant::type_code('PFC_NUMBER')) { # TODO: Don't hardocde these codes. - print <<END_C; - c = PackFile_Constant_new_number($value); -END_C - } elsif ($const->type eq Parrot::PackFile::Constant::type_code('PFC_STRING')) { # TODO: Don't hardocde these codes. - my $type = $value->type; - my $encoding = $value->encoding; - my $size = $value->size; - my $flags = $value->flags; - my $data = Dumper($value->data); - - $data = '"' . $data . '"' unless $data =~ m/^"/; - - print <<END_C; - c = PackFile_Constant_new_string(interpreter, string_make(interpreter, - $data, $size, $encoding, $flags, $type)); -END_C - } else { - die; - } - - print <<END_C; - PackFile_ConstTable_push_constant(pf->const_table, c); - -END_C - } - - my $cursor = 0; my $length = length($pf->byte_code); - my $offset=0; - - my $op_code; - my $op; + # First instruction in bytecode must be the leader of a block + $leaders{$new_pc} = 1; + # This loop tries to identify instructions that may be the target + # of control flow changing opcodes including the possible targets of ret + # opcodes while ($offset + sizeof('op') <= $length) { + my ($src, $is_branch); + $pc = $new_pc; $op_code = unpack "x$offset l", $pf->byte_code; $op = $ops->op($op_code) || die "Can't find an op for opcode $op_code\n"; $offset += sizeof('op'); + push @pc_list, $pc; + $opcodes{$pc}->{op} = $op; $new_pc = $pc + $op->size; @args = (); @@ -160,24 +119,154 @@ $offset += sizeof('op'); push @args, $arg; } + push @{$opcodes{$pc}->{args}}, @args; + + $src = $op->full_body(); + + # The regexes here correspond to the rewriting rules for the various + # forms of goto recognized by Parrot/OpsFile.pm and Parrot/Op.pm + + # absolute address goto + while($src =~ /{{=(.*?)}}/g){ + my $offset = $1; + $is_branch = 1; + } + # relative branch + while($src =~ /{{(\-|\+)=(.*?)}}/g){ + my $dir = $1; + my $forward_off = $2; + + # Substitute constant branch values + if($forward_off =~ /\@(\d+)/){ + $forward_off = $args[$1 - 1] + if $op->arg_type($1) eq 'ic'; + } + + if($forward_off =~ /^-?\d+$/){ + $forward_off = -$forward_off if $dir eq '-'; + + if($forward_off != $op->size){ + $leaders{$forward_off + $pc} = 1; + $is_branch = 1; + } + } + else { + $is_branch = 1; + } + } - $trans->pc($pc); - $trans->args(@args); - my $source = $op->source($trans); + $leaders{$new_pc} = 1 if $is_branch; + } - $source =~ s/^\s*goto PC_$new_pc;\s*$//mg; + my $enternative; - printf("PC_%d: { /* %s */\n%s}\n\n", $pc, $op->full_name, $source); +FINDENTERN: + foreach my $cur_op (@$Parrot::OpLib::core::ops) { + if($cur_op->full_name eq 'enternative'){ + $enternative = pack_op($cur_op->code); + last FINDENTERN; + } } + die "Could not locate enternative op!\n" unless defined $enternative; - print <<END_C; + # Copy original bytecode to edit it + $byte_code = $pf->byte_code; -PC_$new_pc: -PC_0: { - exit(0); + # First block + push @blocks, [shift @pc_list ]; + + # change instructions at block leaders to enternative calls + substr($byte_code, 0, sizeof('op')) = $enternative; + + while (@pc_list) { + my $instr_pc = shift @pc_list; + # block leader found, start new block + if(exists $leaders{$instr_pc}) { + substr($byte_code, $instr_pc, sizeof('op')) = $enternative; + push @blocks, [$instr_pc ]; + } + else { + push @{$blocks[-1]}, $instr_pc; + } + } + + print<<END_C; +static opcode_t* run_compiled(struct Parrot_Interp *interpreter, opcode_t +*cur_opcode, opcode_t *start_code); + +static char program_code[] = { +END_C + + $pf->byte_code($byte_code); + + # this is now packed PBC + $byte_code = $pf->pack(); + + $offset = 0; + while($offset < length($byte_code)){ + print join(',', unpack("c*", substr($byte_code, $offset, 20))); + print ",\n"; + $offset += 20; + } + print "};"; + + print <<'END_C'; + +int +main(int argc, char **argv) { + struct Parrot_Interp * interpreter; + struct PackFile * pf; + + init_world(); + + run_native = run_compiled; + interpreter = make_interpreter(0); + pf = PackFile_new(); + + if( !PackFile_unpack(interpreter, pf, program_code, + (opcode_t)sizeof(program_code)) ) { + printf( "Can't unpack.\n" ); + return 1; + } + interpreter->code = pf; + runops(interpreter, pf, 0); + exit(1); } - return 0; +static opcode_t* run_compiled(struct Parrot_Interp *interpreter, opcode_t +*cur_opcode, opcode_t *start_code){ + +switch_label: + switch((ptrcast_t)cur_opcode - (ptrcast_t)start_code) { + +END_C + + + foreach my $cur_blk (@blocks) { + printf "case %d: PC_%d: {\n", $cur_blk->[0], $cur_blk->[0]; + + foreach $pc (@{$cur_blk}) { + $op = $opcodes{$pc}->{op}; + $trans->pc($pc); + $trans->args(@{$opcodes{$pc}->{args}}); + my $source = $op->source($trans); + + $new_pc = $pc + $op->size; + $source =~ s/^\s*goto PC_$new_pc;\s*$//mg if defined($new_pc); + $source =~ s/\n/\n /mg; +# $source =~ s/#line.*\n//mg; + $source =~ s/CUR_OPCODE/(start_code + $pc)/mg; + + printf("\n /* %s */\n {\n%s}\n", $op->full_name, $source); + } + + print "}\n\n"; + } + print <<END_C; + break; + +default: + return cur_opcode; +} + return(0); } END_C @@ -196,13 +285,12 @@ $pf->unpack_file($file_name); # dump_const_table($pf); - compile_byte_code($pf); + compile_byte_code($pf, $file_name); undef $pf; return; } - # # MAIN PROGRAM: Index: Parrot/OpTrans/CGoto.pm =================================================================== RCS file: /home/perlcvs/parrot/Parrot/OpTrans/CGoto.pm,v retrieving revision 1.2 diff -u -r1.2 CGoto.pm --- Parrot/OpTrans/CGoto.pm 24 Dec 2001 03:46:53 -0000 1.2 +++ Parrot/OpTrans/CGoto.pm 10 Jan 2002 22:56:19 -0000 @@ -13,6 +13,13 @@ use vars qw(@ISA); @ISA = qw(Parrot::OpTrans); +sub defines +{ + return <<END; +#define CUR_OPCODE cur_opcode +END +} + # # pc() @@ -69,7 +76,7 @@ { my ($self, $addr) = @_; #print STDERR "pbcc: map_ret_abs($addr)\n"; - return sprintf("goto PC_%d", $addr); + return "cur_opcode = $addr;\ngoto switch_label"; } @@ -92,9 +99,8 @@ sub goto_pop { my ($self) = @_; - die "pbc2c.pl: Cannot handle 'goto POP()' ops!"; + return sprintf("cur_opcode = pop_dest(interpreter);\ngoto switch_label"); } - # # access_arg() Index: include/parrot/interpreter.h =================================================================== RCS file: /home/perlcvs/parrot/include/parrot/interpreter.h,v retrieving revision 1.20 diff -u -r1.20 interpreter.h --- include/parrot/interpreter.h 1 Jan 2002 17:22:55 -0000 1.20 +++ include/parrot/interpreter.h 10 Jan 2002 22:56:19 -0000 @@ -92,6 +92,8 @@ void runops(struct Parrot_Interp *, struct PackFile *, size_t offset); +VAR_SCOPE opcode_t* (*run_native)(struct Parrot_Interp *interpreter, opcode_t +*cur_opcode, opcode_t *start_code); + #endif /*
# # mops.pasm # # Copyright (C) 2001 The Parrot Team. All rights reserved. # This program is free software. It is subject to the same # license as The Parrot Interpreter. # # $Id: mops.pasm,v 1.5 2002/01/02 13:48:40 simon Exp $ # set I2, 0 set I3, 1 set I4, 100000000 print "Iterations: " print I4 print "\n" set I1, 2 mul I5, I4, I1 print "Estimated ops: " print I5 print "\n" time N1 REDO: sub I4, I4, I3 if I4, REDO DONE: time N5 sub N2, N5, N1 print "Elapsed time: " print N2 print "\n" if I4, BUG bsr CALC print "M op/s: " print N1 print "\n" end CALC: set N1, I5 div N1, N1, N2 set N2, 1000000.0 div N1, N1, N2 ret BUG: print "This can't happen\n" end