[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