[svn:parrot] r48266 - branches/gsoc_instrument/tools/build
khairul at svn.parrot.org
khairul at svn.parrot.org
Tue Aug 3 03:19:24 UTC 2010
Author: khairul
Date: Tue Aug 3 03:19:24 2010
New Revision: 48266
URL: https://trac.parrot.org/parrot/changeset/48266
Log:
Updated generator scripts.
Modified:
branches/gsoc_instrument/tools/build/gen_gc_stubs.pl
branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl
Modified: branches/gsoc_instrument/tools/build/gen_gc_stubs.pl
==============================================================================
--- branches/gsoc_instrument/tools/build/gen_gc_stubs.pl Tue Aug 3 03:18:11 2010 (r48265)
+++ branches/gsoc_instrument/tools/build/gen_gc_stubs.pl Tue Aug 3 03:19:24 2010 (r48266)
@@ -36,6 +36,13 @@
flock($dynpmc_fh, LOCK_EX) or die "Cannot lock $dynpmc_file!";
flock($source_fh, LOCK_EX) or die "Cannot lock $source_file!";
+my %param_type = (
+ 'PMC*' => 'P',
+ 'INTVAL' => 'I',
+ 'FLOATVAL' => 'F',
+ 'STRING*' => 'S'
+);
+
my(%groups, @entries, @prototypes, @stubs, %stub_memory_sizes);
init_stub_memory_sizes(\%stub_memory_sizes);
@@ -56,6 +63,7 @@
if(/^\s*(.*)\s*\(\*(.+)\)\s*\((.*)\)$/) {
my @data = ($1, $2, $3);
$data[2] = fix_params($data[2]);
+ @data = map { chomp;$_; } @data;
# Ignore is_blocked_mark, is_blocked_sweep, get_gc_info.
next if $data[1] eq 'is_blocked_mark'
@@ -152,14 +160,15 @@
}
sub gen_stub {
- my($ret, $name, $params, $group) = @_;
+ my($ret, $name, $args, $group) = @_;
# Process the parameter list.
+ my @param_formats = ();
my @param_types = ();
my @param_names = ();
my $param;
my $param_count = 0;
- foreach $param (split /\s*,\s*/, $params) {
+ foreach $param (split /\s*,\s*/, $args) {
$param_count++;
chomp $param;
@@ -169,12 +178,14 @@
if($param eq 'PARROT_INTERP') {
push @param_types, 'Parrot_Interp';
push @param_names, 'interp';
+ push @param_formats, 'V';
next;
}
elsif($param_count == 1) {
my @tokens = split(/\s+/, $param);
push @param_types, $tokens[0];
push @param_names, 'interp';
+ push @param_formats, 'V';
next;
}
@@ -184,71 +195,58 @@
if(scalar(@tokens) > 2) {
push @param_names, pop(@tokens);
push @param_types, join(' ', @tokens);
+ push @param_formats, 'V';
}
else {
push @param_types, $tokens[0];
push @param_names, $tokens[1];
+ push @param_formats, ($param_type{$tokens[0]} || 'V');
}
}
-
- my $param_list_flat = (scalar(@param_names)) ? join(', ', @param_names) : '';
+ my $param_format = join('', @param_formats);
+ my $param_flat = (scalar(@param_names)) ? join(', ', @param_names) : '';
$param_count = 0;
- $params = join(', ', map { $_.' '.$param_names[$param_count++] } @param_types);
+ $args = join(', ', map { $_.' '.$param_names[$param_count++] } @param_types);
- my($ret_dec, $ret_ret, $ret_last) = ('','','');
- if ($ret !~ /^\s*void\s*$/) {
- $ret_dec = ' '.$ret.' ret;'."\n";
- $ret_ret = ' ret =';
- $ret_last = ' ret';
- }
-
- # Prepare to pass the parameter list to instrument.
- my $instr_params = '';
- for(my $i = 1; $i < @param_types; $i++) {
- if($param_types[$i] eq 'size_t' || $param_types[$i] eq 'UINTVAL') {
- $instr_params .= <<INTEGER;
- temp = Parrot_pmc_new(supervisor, enum_class_Integer);
- VTABLE_set_integer_native(supervisor, temp, $param_names[$i]);
- VTABLE_push_pmc(supervisor, params, temp);
-INTEGER
- }
- else {
- # Assume pointer.
- $instr_params .= <<POINTER;
- temp = Parrot_pmc_new(supervisor, enum_class_Pointer);
- VTABLE_set_pointer(supervisor, temp, $param_names[$i]);
- VTABLE_push_pmc(supervisor, params, temp);
-POINTER
- }
+ # Prepare the return value.
+ my($ret_declaration, $ret_receive, $ret_return, $ret_pack) = ('', '', '', '');
+ if($ret !~ /^\s*void\s*$/) {
+ $ret_declaration = "\n $ret ret;\n PMC *ret_pack;";
+ $ret_receive = "ret = ";
+ $ret_return = "\n return ret;";
+
+ my $type = ($param_type{$ret} || 'V');
+ $ret_pack = "\n".<<PACK;
+ ret_pack = instrument_pack_params(supervisor, "$type", ret);
+ VTABLE_set_pmc_keyed_str(supervisor, data, CONST_STRING(supervisor, "return"), ret_pack);
+PACK
}
# For allocations and reallocations, expose the size of the allocation.
my $alloc = $stub_memory_sizes{$name} || '';
+ my $event = 'GC::'.$group.'::'.$name;
return <<STUB;
-$ret stub_$name($params) {
- GC_Subsystem *gc_orig = ((InstrumentGC_Subsystem *) interp->gc_sys)->original;
- Parrot_Interp supervisor = ((InstrumentGC_Subsystem *) interp->gc_sys)->supervisor;
-
- PMC *event_data;
- PMC *temp;
- PMC *params = Parrot_pmc_new(supervisor, enum_class_ResizablePMCArray);
-$ret_dec
-
- $ret_ret gc_orig->$name($param_list_flat);
+$ret stub_$name($args) {
+ GC_Subsystem *gc_orig = ((InstrumentGC_Subsystem *) interp->gc_sys)->original;
+ Parrot_Interp supervisor = ((InstrumentGC_Subsystem *) interp->gc_sys)->supervisor;
+ PMC *instrumentgc = ((InstrumentGC_Subsystem *) interp->gc_sys)->instrument_gc;
+ PMC *instrument, *recall, *event_data, *temp, *params, *event_array;
+ STRING *raise_event, *event;$ret_declaration
-$instr_params
+ params = instrument_pack_params(supervisor, "$param_format", $param_flat);
event_data = Parrot_pmc_new(supervisor, enum_class_Hash);
- VTABLE_set_string_keyed_str(supervisor, event_data,
- CONST_STRING(supervisor, "type"),
- CONST_STRING(supervisor, "$name"));
- VTABLE_set_pmc_keyed_str(supervisor, event_data,
- CONST_STRING(supervisor, "parameters"),
- params);
+ VTABLE_set_pmc_keyed_str(supervisor, event_data, CONST_STRING(supervisor, "parameters"),params);
$alloc
- raise_gc_event(supervisor, interp, CONST_STRING(supervisor, "$group"), event_data);
-
- return$ret_last;
+ event = CONST_STRING(supervisor, "$event");
+ raise_event = CONST_STRING(supervisor, "raise_event");
+ GETATTR_InstrumentGC_instrument(supervisor, instrumentgc, instrument);
+ Parrot_pcc_invoke_method_from_c_args(supervisor, instrument, raise_event,
+ "SP->P", event, event_data, &recall);
+ $ret_receive(gc_orig->$name($param_flat));
+ Parrot_pcc_invoke_method_from_c_args(supervisor, instrument, raise_event,
+ "SPP->P", event, event_data, recall, &recall);
+ probe_list_delete_list(supervisor, (probe_list_t *)VTABLE_get_pointer(supervisor, recall));$ret_return
}
STUB
@@ -328,17 +326,14 @@
}
sub gen_mapping_item_groups {
-my @entries = @_;
+ my @entries = @_;
return join("\n", map {
my $name = @{$_}[1];
my $group = @{$_}[3];
my $stub = <<STUB;
- temp = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
- VTABLE_push_string(interp, temp,
- CONST_STRING(interp, "$group"));
parrot_hash_put(interp, gc_item_groups,
CONST_STRING(interp, "$name"),
- temp);
+ CONST_STRING(interp, "$group"));
STUB
chomp $stub;
$stub;
@@ -396,12 +391,8 @@
for $key (keys %sources) {
my $source = $sources{$key};
$ref->{$key} = <<SIZE;
- temp = Parrot_pmc_new(supervisor, enum_class_Integer);
- VTABLE_set_integer_native(supervisor, temp,
- $source);
- VTABLE_set_pmc_keyed_str(supervisor, event_data,
- CONST_STRING(supervisor, "size"),
- temp);
+ VTABLE_set_integer_keyed_str(supervisor, event_data, CONST_STRING(supervisor, "size"),
+ $source);
SIZE
}
}
Modified: branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl
==============================================================================
--- branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl Tue Aug 3 03:18:11 2010 (r48265)
+++ branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl Tue Aug 3 03:19:24 2010 (r48266)
@@ -18,68 +18,43 @@
=cut
-use warnings;
use strict;
-
+use warnings;
+use FindBin;
+use lib "$FindBin::Bin/../../lib";
+use Parrot::Vtable;
use IO::File;
use Fcntl qw(:DEFAULT :flock);
-my $dynpmc_file = 'src/dynpmc/instrumentvtable.pmc';
-my $vtable_file = 'src/vtable.tbl';
+my %param_type = (
+ 'PMC*' => 'P',
+ 'INTVAL' => 'I',
+ 'FLOATVAL' => 'F',
+ 'STRING*' => 'S'
+);
+my $dynpmc_file = 'src/dynpmc/instrumentvtable.pmc';
my $dynpmc_fh = IO::File->new($dynpmc_file, O_RDWR | O_CREAT);
-my $vtable_fh = IO::File->new('src/vtable.tbl', O_RDWR | O_CREAT);
die "Could not open $dynpmc_file!" if !$dynpmc_fh;
-die "Could not open $vtable_file!" if !$vtable_fh;
flock($dynpmc_fh, LOCK_EX) or die "Cannot lock $dynpmc_file!";
-flock($vtable_fh, LOCK_EX) or die "Cannot lock $vtable_file!";
-
-my(%groups, @entries, @prototypes, @stubs);
-my $cur_group = 'CORE';
-while(<$vtable_fh>) {
- # Remove whitespace and go on to the next line
- # for comments and empty lines.
- chomp;
- if(m/^#/) { next; }
- if(m/^\s*$/) { next; }
- # Check for group change.
- if(m/^\[(\w+)\]$/) {
- $cur_group = $1;
- next;
- }
+# Parse the vtable entries.
+my $vtbl = parse_vtable("$FindBin::Bin/../../src/vtable.tbl");
- # Separate out the components.
- # type name(params) annotations
- if(m/^(.+)\s+(.+)\s*\((.*)\)\s*(.*)$/) {
- # Generate the components.
- my @data = ($1, $2, $3, $4);
- #print "($1) ($2) ($3) ($4)\n";
-
- # Prepend the first 2 parameters that all vtable entries will
- # receive: PARROT_INTERP, PMC *pmc
- $data[2] = ($data[2] eq '')
- ? 'PARROT_INTERP, PMC* pmc'
- : 'PARROT_INTERP, PMC* pmc, '.$data[2];
-
- # Set the groups that this vtable entry belongs to.
- my @groups = ($cur_group);
- my $annotation;
- foreach $annotation (split /\s+/, $data[3]) {
- $annotation =~ s/://;
- push @{$groups{$annotation}}, $data[1];
- push @groups, $annotation;
- }
- push @{$groups{'all'}}, $data[1];
- push @{$groups{$cur_group}}, $data[1];
- push @data, \@groups;
-
- push @prototypes, gen_prototype(@data);
- push @stubs, gen_stub(@data);
- push @entries, \@data;
- }
+# Process the entries.
+my(%groups, @entries, @prototypes, @stubs);
+for (@$vtbl) {
+ my @entry = @$_;
+ $entry[3] = lc $entry[3]; # lowercase group
+
+ push @{$groups{'all'}}, $entry[1];
+ push @{$groups{$entry[3]}}, $entry[1];
+
+ push @prototypes, gen_prototype(@entry);
+ push @stubs, gen_stub(@entry);
+ push @entries, \@entry;
}
my %placeholders = (
@@ -119,10 +94,8 @@
}
flock($dynpmc_fh, LOCK_UN) or die "Cannot unlock $dynpmc_file!";
-flock($vtable_fh, LOCK_UN) or die "Cannot unlock $vtable_file!";
$dynpmc_fh->close();
-$vtable_fh->close();
# Write to the file.
$dynpmc_fh = IO::File->new($dynpmc_file, O_WRONLY | O_CREAT | O_TRUNC)
@@ -137,122 +110,82 @@
sub gen_prototype {
my($ret, $name, $params, $anno) = @_;
+ if(length $params > 0) { $params = ', '.$params; }
+
return <<PROTO;
-static $ret stub_$name($params);
+static $ret stub_$name(PARROT_INTERP, PMC *pmc$params);
PROTO
}
sub gen_stub {
- my($ret, $name, $params, $anno, $groups) = @_;
+ my($ret, $name, $args, $group) = @_;
# Process the parameter list.
my @param_types = ();
my @param_names = ();
- my $param;
- foreach $param (split /\s*,\s*/, $params) {
- chomp $param;
-
- if($param eq '') { next; }
-
- if($param eq 'PARROT_INTERP') {
- push @param_types, 'Parrot_Interp';
- push @param_names, 'interp';
- next;
- }
+ my $param_flat;
+ my $param_format;
+ my $arg;
+ foreach $arg (split /\s*,\s*/, $args) {
+ chomp $arg;
+ if($arg eq '') { next; }
- my @tokens = split(/\s+/, $param);
- push @param_types, $tokens[0];
+ my @tokens = split(/\s+/, $arg);
+ push @param_types, ($param_type{$tokens[0]} || 'V');
push @param_names, $tokens[1];
}
-
- my $param_list_flat = (scalar(@param_names)) ? join(', ', @param_names) : '';
-
- my($ret_dec, $ret_ret, $ret_last) = ('','','');
- if ($ret ne 'void') {
- $ret_dec = ' '.$ret.' ret;'."\n";
- $ret_ret = ' ret =';
- $ret_last = ' ret';
+ unshift @param_names, 'pmc';
+ $param_flat = join(', ', @param_names);
+ $param_format = "P".join('', @param_types);
+ if($args ne '') { $args = ', '.$args; }
+
+ # Prepare the return value.
+ my($ret_declaration, $ret_receive, $ret_return, $ret_pack) = ('', '', '', '');
+ if($ret ne 'void') {
+ $ret_declaration = "\n $ret ret;\n PMC *ret_pack;";
+ $ret_receive = "ret = ";
+ $ret_return = "\n return ret;";
+
+ my $type = ($param_type{$ret} || 'V');
+ $ret_pack = "\n".<<PACK;
+ ret_pack = instrument_pack_params(supervisor, "$type", ret);
+ VTABLE_set_pmc_keyed_str(supervisor, data, CONST_STRING(supervisor, "return"), ret_pack);
+PACK
}
- # Prepare to pass the parameter list to instrument.
- my $instr_params = '';
- for(my $i = 1; $i < @param_types; $i++) {
- if($param_types[$i] eq 'size_t' || $param_types[$i] eq 'UINTVAL'
- || $param_types[$i] eq 'INTVAL') {
- $instr_params .= <<INTEGER;
- temp = Parrot_pmc_new(supervisor, enum_class_Integer);
- VTABLE_set_integer_native(supervisor, temp, $param_names[$i]);
- VTABLE_push_pmc(supervisor, params, temp);
-INTEGER
- }
- elsif($param_types[$i] eq 'FLOATVAL') {
- $instr_params .= <<FLOAT;
- temp = Parrot_pmc_new(supervisor, enum_class_Float);
- VTABLE_set_number_native(supervisor, temp, $param_names[$i]);
- VTABLE_push_pmc(supervisor, params, temp);
-FLOAT
- }
- elsif($param_types[$i] eq 'PMC*') {
- $instr_params .= <<PMC;
- VTABLE_push_pmc(supervisor, params, $param_names[$i]);
-PMC
- }
- elsif($param_types[$i] eq 'STRING*') {
- $instr_params .= <<STRING;
- temp = Parrot_pmc_new(supervisor, enum_class_String);
- VTABLE_set_string_native(supervisor, temp, $param_names[$i]);
- VTABLE_push_pmc(supervisor, params, temp);
-STRING
- }
- else {
- # Assume pointer.
- $instr_params .= <<POINTER;
- temp = Parrot_pmc_new(supervisor, enum_class_Pointer);
- VTABLE_set_pointer(supervisor, temp, $param_names[$i]);
- VTABLE_push_pmc(supervisor, params, temp);
-POINTER
- }
- }
-
- # Set up the individual group events for this
- # stub.
- my $events = '';
- my $group;
- foreach $group (@{$groups}) {
- $group = lc $group;
- $events .= <<EVENT;
- raise_vtable_event(supervisor, interp, instr_vt, pmc, data,
- CONST_STRING(supervisor, "$group"),
- CONST_STRING(supervisor, "$name"));
-EVENT
- }
+ # Prepare the event string to be appended to the the event prefix.
+ my $event_entry = join '::', ('vtable',$group,$name);
+ # Return the generated stub.
return <<CODE;
static
-$ret stub_$name($params) {
- PMC *instr_vt, *data;
- void *orig_vtable;
+$ret stub_$name(PARROT_INTERP, PMC *pmc$args) {
+ PMC *instrument, *instrumentvt, *params, *data, *event_array, *recall;
Parrot_Interp supervisor;
- PMC *temp;
- PMC *params;
-$ret_dec
- instr_vt = (PMC *) parrot_hash_get(interp, vtable_registry, pmc->vtable);
-
- GETATTR_InstrumentVtable_original_struct(interp, instr_vt, orig_vtable);
- GETATTR_InstrumentVtable_supervisor(interp, instr_vt, supervisor);
-
- params = Parrot_pmc_new(supervisor, enum_class_ResizablePMCArray);
-$instr_params
-
- data = Parrot_pmc_new(supervisor, enum_class_Hash);
- VTABLE_set_pmc_keyed_str(supervisor, data,
- CONST_STRING(supervisor, "parameters"),
- params);
-
-$events
+ STRING *raise_event, *event;
+ void *orig_vtable;$ret_declaration
- $ret_ret ((_vtable *)orig_vtable)->$name($param_list_flat);
- return$ret_last;
+ instrumentvt = (PMC *) parrot_hash_get(interp, vtable_registry, pmc->vtable);
+ GETATTR_InstrumentVtable_original_struct(interp, instrumentvt, orig_vtable);
+ GETATTR_InstrumentVtable_supervisor(interp, instrumentvt, supervisor);
+ GETATTR_InstrumentVtable_event_prefix(interp, instrumentvt, event_array);
+
+ params = instrument_pack_params(supervisor, "$param_format", $param_flat);
+ data = Parrot_pmc_new(supervisor, enum_class_Hash);
+ VTABLE_set_pmc_keyed_str(supervisor, data, CONST_STRING(supervisor, "parameters"), params);
+
+ event_array = VTABLE_clone(supervisor, event_array);
+ VTABLE_push_string(supervisor, event_array,
+ CONST_STRING(supervisor, "$event_entry"));
+
+ raise_event = CONST_STRING(supervisor, "raise_event");
+ event = Parrot_str_join(supervisor, CONST_STRING(supervisor, "::"), event_array);
+ Parrot_pcc_invoke_method_from_c_args(supervisor, instrument, raise_event, "SP->P",
+ event, data, &recall);
+ $ret_receive((_vtable *)orig_vtable)->$name(interp, $param_flat);$ret_pack
+ Parrot_pcc_invoke_method_from_c_args(supervisor, instrument, raise_event, "SPP->P",
+ event, data, recall, &recall);
+ probe_list_delete_list(supervisor, (probe_list_t *)VTABLE_get_pointer(supervisor, recall));$ret_return
}
CODE
@@ -264,8 +197,7 @@
my $name = @{$_}[1];
my $stub = <<STUB;
parrot_hash_put(interp, vtable_name_stubs,
- CONST_STRING(interp, "$name"),
- stub_$name);
+ CONST_STRING(interp, "$name"), stub_$name);
STUB
chomp $stub;
$stub;
@@ -278,8 +210,7 @@
my $name = @{$_}[1];
my $stub = <<STUB;
parrot_hash_put(interp, orig_hash,
- CONST_STRING(interp, "$name"),
- vt_orig->$name);
+ CONST_STRING(interp, "$name"), vt_orig->$name);
STUB
chomp $stub;
$stub;
@@ -292,8 +223,7 @@
my $name = @{$_}[1];
my $stub = <<STUB;
parrot_hash_put(interp, instr_hash,
- CONST_STRING(interp, "$name"),
- &(vt_instr->$name));
+ CONST_STRING(interp, "$name"), &(vt_instr->$name));
STUB
chomp $stub;
$stub;
@@ -313,16 +243,14 @@
foreach $item (@{$groups{$key}}) {
$entry .= <<ENTRY;
- VTABLE_push_string(interp, temp,
- CONST_STRING(interp, "$item"));
+ VTABLE_push_string(interp, temp, CONST_STRING(interp, "$item"));
ENTRY
}
$key = lc $key;
$entry .= <<POST;
parrot_hash_put(interp, vtable_group_items,
- CONST_STRING(interp, "$key"),
- temp);
+ CONST_STRING(interp, "$key"), temp);
POST
chomp $entry;
@@ -334,35 +262,16 @@
sub gen_mapping_item_groups {
my @entries = @_;
-
- my $data;
- my @ret;
- foreach $data (@entries) {
- my $item;
- my $name = $data->[1];
- my $entry = <<PRE;
- temp = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
-PRE
-
- foreach $item (@{$data->[4]}) {
- $item = lc $item;
- $entry .= <<ENTRY;
- VTABLE_push_string(interp, temp,
- CONST_STRING(interp, "$item"));
-ENTRY
- }
-
- $entry .= <<POST;
- parrot_hash_put(interp, vtable_item_groups,
- CONST_STRING(interp, "$name"),
- temp);
-POST
-
- chomp $entry;
- push @ret, $entry;
- }
-
- return join("\n\n", @ret);
+ return join("\n", map {
+ my $name = @{$_}[1];
+ my $group = @{$_}[3];
+ my $stub = <<STUB;
+ parrot_hash_put(interp, vtable_item_groups, CONST_STRING(interp, "$name"),
+ CONST_STRING(interp, "$group"));
+STUB
+ chomp $stub;
+ $stub;
+ } @entries);
}
# Local Variables:
More information about the parrot-commits
mailing list