[svn:parrot] r48079 - in branches/gsoc_instrument: examples/library runtime/parrot/library/Instrument t/dynpmc tools/build
khairul at svn.parrot.org
khairul at svn.parrot.org
Tue Jul 13 14:53:58 UTC 2010
Author: khairul
Date: Tue Jul 13 14:53:58 2010
New Revision: 48079
URL: https://trac.parrot.org/parrot/changeset/48079
Log:
Code changes as suggested by cotto++.
Modified:
branches/gsoc_instrument/examples/library/tracer.nqp
branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp
branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp
branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp
branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp
branches/gsoc_instrument/t/dynpmc/instrumentgc.t
branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl
Modified: branches/gsoc_instrument/examples/library/tracer.nqp
==============================================================================
--- branches/gsoc_instrument/examples/library/tracer.nqp Tue Jul 13 07:21:37 2010 (r48078)
+++ branches/gsoc_instrument/examples/library/tracer.nqp Tue Jul 13 14:53:58 2010 (r48079)
@@ -22,105 +22,131 @@
load_bytecode 'Instrument/InstrumentLib.pbc'
};
-my $args := pir::getinterp__p()[2];
-$args.shift();
+my @args := pir::getinterp__p()[2];
+ at args.shift();
my $probe := Instrument::Probe.new();
$probe.catchall(1);
$probe.callback('tracer');
-my $instr := Q:PIR { %r = new ['Instrument'] };
+my $instr := pir::new__PS('Instrument');
$instr.attach($probe);
-$instr.run($args[0], $args);
+$instr.run(@args[0], @args);
+##
+# Callback that is called by Instrument.
+##
sub tracer ($op, $instr_obj, $probe) {
- my $sprintf_args := [$op.pc()];
- my $pc_hex := pir::sprintf__SSP("%04x", $sprintf_args);
+ my $pc_hex := pir::sprintf__SSP("%04x", [$op.pc()]);
my $op_name := $op.family();
my $param_cnt := $op.count();
my $params := '';
my $cur_arg := 0;
- my $arg_list := [];
+ my @arg_list := ();
while $cur_arg < $param_cnt {
- my $arg_str;
- my $arg_type := $op.arg_type($cur_arg);
- my $arg := $op.get_arg($cur_arg, 1);
-
# Evaluate in order of:
# 1. keys
# 2. constants
# 3. regs.
- # TODO: There's probably a smarter way to do the code below. Messy!
- if pir::band__III($arg_type, 0x20) == 0x20 {
- # Keys.
- if pir::band__III($arg_type, 16) == 16 {
- # Constant keys are int constants or strings.
- if pir::band__III($arg_type, 2) == 2 {
- # String constant key.
- my $arg_val := pir::escape__SS($op.get_arg($cur_arg));
- $arg_str := '["' ~ $arg_val ~ '"]';
-
- } else {
- # Integer constant key.
- $arg_str := '[' ~ $arg ~ ']';
- }
- } else {
- # Non-constant keys. Reference regs only.
- if !$arg_type {
- # 0 is int reg.
- $arg_str := '[I' ~ $arg ~ ']';
-
- } elsif pir::band__III($arg_type, 2) == 2 {
- # 2 is pmc.
- $arg_str := '[P' ~ $arg ~ ']';
- }
- }
-
- my $prev := $arg_list.pop();
- $arg_str := $prev ~ $arg_str;
-
- } elsif pir::band__III($arg_type, 16) == 16
- && pir::band__III($arg_type, 2) != 2 {
-
- if pir::band__III($arg_type, 1) == 1 {
- my $arg_val := pir::escape__SS($op.get_arg($cur_arg));
- $arg_str := '"' ~ $arg_val ~ '"';
-
- } else {
- $arg_str := $arg;
- }
- } elsif !$arg_type {
- # 0 is int reg.
- $arg_str := 'I' ~ $arg;
-
- } elsif pir::band__III($arg_type, 1) == 1{
- # 1 is string reg.
- $arg_str := 'S' ~ $arg;
-
- } elsif pir::band__III($arg_type, 2) == 2 {
- # 2 is pmc.
- if pir::band__III($arg_type, 16) == 16 {
- # Constant pmc.
- $arg_str := 'PC' ~ $arg;
- } else {
- # Normal reg.
- $arg_str := 'P' ~ $arg;
- }
-
- } elsif pir::band__III($arg_type, 3) == 3 {
- # 3 is num reg.
- $arg_str := 'N' ~ $arg;
-
- }
+ my $arg_str := try_key($op, $cur_arg, @arg_list)
+ // try_constant($op, $cur_arg)
+ // try_register($op, $cur_arg);
- $arg_list.push($arg_str);
+ @arg_list.push($arg_str);
$cur_arg++;
}
- $params := pir::join__SSP(', ', $arg_list);
-
+ $params := pir::join__SSP(', ', @arg_list);
say($pc_hex ~ ' ' ~ $op_name ~ ' ' ~ $params);
};
+##
+# Try to evaluate current argument as a key.
+##
+sub try_key($op, $cur_arg, @arg_list) {
+ my $arg_type := $op.arg_type($cur_arg);
+ my $arg := $op.get_arg($cur_arg, 1);
+ my $arg_str;
+
+ # Keys have the flag 0x20 set.
+ if and($arg_type, 0x20) {
+ if and($arg_type, 16) {
+ # Constant keys are int constants or strings.
+ $arg_str := '[' ~ try_constant($op, $cur_arg) ~ ']';
+ }
+ else {
+ # Non-constant keys. Reference regs only.
+ $arg_str := '[' ~ try_register($op, $cur_arg) ~ ']';
+ }
+
+ my $prev := @arg_list.pop();
+ $arg_str := $prev ~ $arg_str;
+ }
+
+ return $arg_str;
+}
+
+##
+# Try to evaluate current argument as a constant.
+##
+sub try_constant($op, $cur_arg) {
+ my $arg_type := $op.arg_type($cur_arg);
+ my $arg := $op.get_arg($cur_arg, 1);
+ my $arg_str;
+
+ if and($arg_type, 16) {
+ if and($arg_type, 1) {
+ # String constant.
+ $arg_str := '"' ~ pir::escape__SS($op.get_arg($cur_arg)) ~ '"';
+ }
+ elsif and($arg_type, 2) {
+ # PMC constant.
+ $arg_str := 'PC' ~ $arg;
+ }
+ else {
+ # Either integer or float constant.
+ $arg_str := $arg;
+ }
+ }
+
+ return $arg_str;
+}
+
+##
+# Try to evaluate current argument as a register.
+##
+sub try_register($op, $cur_arg) {
+ my $arg_type := $op.arg_type($cur_arg);
+ my $arg := $op.get_arg($cur_arg, 1);
+ my $arg_str;
+
+ # Assume $arg is a register.
+ if !$arg_type {
+ # 0 is int reg.
+ $arg_str := 'I' ~ $arg;
+ }
+ elsif and($arg_type, 1) {
+ # 1 is string reg.
+ $arg_str := 'S' ~ $arg;
+ }
+ elsif and($arg_type, 2) {
+ # 2 is pmc.
+ $arg_str := 'P' ~ $arg;
+ }
+ elsif and($arg_type, 3) {
+ # 3 is num reg.
+ $arg_str := 'N' ~ $arg;
+ }
+
+ return $arg_str;
+}
+
+##
+# ANDs $a and $b and check that the result is $b.
+##
+sub and($a, $b) {
+ pir::band__III($a, $b) == $b;
+}
+
# vim: ft=perl6 expandtab shiftwidth=4:
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp Tue Jul 13 07:21:37 2010 (r48078)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp Tue Jul 13 14:53:58 2010 (r48079)
@@ -44,18 +44,15 @@
%r = new $P1
};
- if !pir::defined__IP($id_count) {
- $id_count := 0;
- }
+ $id_count := $id_count // 0;
my $id := $id_count++;
$!identifier := "Instrument-" ~ $id;
-
$!is_enabled := 0;
self._self_init();
- return self;
+ self;
};
=begin
@@ -89,7 +86,7 @@
if pir::defined__IP($sub) {
$!callback := get_sub_obj($sub);
}
- return $!callback;
+ $!callback;
};
=begin
@@ -110,7 +107,7 @@
if pir::defined__IP($sub) {
$!finalize := get_sub_obj($sub);
}
- return $!finalize;
+ $!finalize;
};
=begin
@@ -125,10 +122,7 @@
=end
method data ($data?) {
- if pir::defined__IP($data) {
- $!data := $data;
- }
- return $data;
+ $!data := $data // $!data;
};
=begin
@@ -174,19 +168,10 @@
die('$sub is not defined.');
}
- my $type := pir::typeof__PP($sub);
-
- if ($type eq 'String') {
- my $lookup;
-
- # Lookup the sub in the 3 namespaces.
- $lookup := pir::get_global__PS($sub);
- if !pir::defined__IP($lookup) {
- $lookup := pir::get_hll_global__PS($sub);
- }
- if !pir::defined__IP($lookup) {
- $lookup := pir::get_root_global__PS($sub);
- }
+ if pir::does__IPS($sub, 'string') {
+ my $lookup := pir::get_global__PS($sub)
+ // pir::get_hll_global__PS($sub)
+ // pir::get_root_global__PS($sub);
if !pir::defined__IP($lookup) {
die('Could not find sub ' ~ $sub ~ ' in the namespaces.');
@@ -196,9 +181,8 @@
}
# Ensure that $sub is of type 'Sub'.
- $type := pir::typeof__PP($sub);
- if $type ne 'Sub' {
- die('Type of $sub is not "Sub" but ' ~ $type ~ ' instead.');
+ if !pir::does__IPS($sub, 'invokable') {
+ die('Type of $sub is not invokable. (' ~ pir::typeof__SP($sub) ~ ')');
}
return $sub;
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp Tue Jul 13 07:21:37 2010 (r48078)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp Tue Jul 13 14:53:58 2010 (r48079)
@@ -79,8 +79,7 @@
=end
method can_handle ($task) {
- my $subtype := pir::getattribute__PPS($task, "subtype");
- return $subtype eq 'Instrument';
+ pir::getattribute__PPS($task, "subtype") eq 'Instrument';
};
=begin
@@ -116,7 +115,7 @@
my $index := 0;
for @list {
if pir::defined__IP($_) && $_ eq $callback {
- pir::delete_p_k(@list, $index);
+ pir::delete(@list, $index);
$found := 1;
break;
}
@@ -134,13 +133,17 @@
=item get_handlers ($event)
Returns a ResizablePMCArray of all the handlers registered for that event.
+$event can be an array or a string.
=cut
=end
method get_handlers ($event) {
- my @tokens := pir::split__PSS('::', $event);
+ my @tokens := $event;
+ if pir::does__IPS($event, 'string') {
+ @tokens := pir::split__PSS('::', $event);
+ }
# Get the lists and join them into 1 big list.
my @key := ();
@@ -167,19 +170,11 @@
=end
sub handler ($handler, $task) {
- my %callbacks := pir::getattribute__PPS($handler, '%!callbacks');
-
# Get the required subkeys.
my %data := pir::getattribute__PPS($task, "data");
- my @event := %data<event>;
- # Get the lists and join them into 1 big list.
- my @list := ();
- my @key;
- for @event {
- @key.push($_);
- @list.append(get_list(%callbacks, pir::join__SSP('::', @key)));
- }
+ # Get the list of callbacks for this event.
+ my @list := $handler.get_handlers(%data<event>);
# Call the callbacks.
for @list {
@@ -200,14 +195,8 @@
=end
sub get_list (%hash, $key) {
- my @list := %hash{$key};
-
- if !pir::defined__IP(@list) {
- @list := ();
- %hash{$key} := @list;
- }
-
- return @list;
+ %hash{$key} := %hash{$key} // ();
+ return %hash{$key};
};
};
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp Tue Jul 13 07:21:37 2010 (r48078)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp Tue Jul 13 14:53:58 2010 (r48079)
@@ -39,93 +39,12 @@
=end
class Instrument::Event::Internal::loadlib is Instrument::Event {
-
method _self_init() {
$!event_type := 'Internal::loadlib';
};
};
=begin
-=item Instrument::Event::Class:instantiate
-
-Raises an event whenever a class is instantiated.
-
-TODO: How about instantiations from C? Inspecting new opcodes
- don't really help that. Redo. Hold off until InstrumentPMC is done.
-
-=cut
-=end
-
-class Instrument::Event::Class::instantiate is Instrument::Event {
- method _self_init() {
- $!event_type := 'Instrument::Event::Class::instantiate';
-
- my $class_hash := Q:PIR { %r = new ['Hash'] };
- self.data($class_hash);
-
- $!probe_obj := Instrument::Probe.new();
- $!probe_obj.data(self);
-
- $!probe_obj.inspect('new');
- $!probe_obj.callback(pir::get_global__PS('callback'));
- };
-
- method inspect ($class) {
- pir::set_p_k_ic($!class_hash, $class, 1);
- };
-
- sub callback ($op, $instr_obj, $probe) {
- my $class := $op.get_arg(1);
-
- # Check if class is to be inspected.
- my $data := $probe.data().data();
- if pir::set__IP($data) == 0
- || pir::exists_i_p_k__IPP($data, $class) {
- my $data := Q:PIR { %r = new ['ResizablePMCArray'] };
- $data.push($class);
- $data.push($op);
- $data.push($instr_obj);
-
- Instrument::Event::_raise_event('Instrument::Event::Class::instantiate', $data);
- }
- };
-};
-
-=begin
-=item Instrument::Event::Class:callmethod
-
-Raises an event whenever a class method is called.
-
-TODO: Similarly, how about calling from C? Hold off until InstrumentPMC is done.
-
-=cut
-=end
-
-class Instrument::Event::Class::callmethod is Instrument::Event {
-
- method _self_init() {
- $!event_type := 'Instrument::Event::Class::callmethod';
-
- $!probe_obj := Instrument::Probe.new();
-
- $!probe_obj.inspect('callmethod');
- $!probe_obj.inspect('callmethodcc');
- $!probe_obj.callback(pir::get_global__PS('callback'));
- };
-
- sub callback ($op, $instr_obj) {
- my $method := $op.get_arg(1);
-
- my $data := Q:PIR { %r = new ['ResizablePMCArray'] };
- $data.push($method);
- $data.push($op);
- $data.push($instr_obj);
-
- Instrument::Event::_raise_event('Instrument::Event::Class::callmethod', $data);
- };
-};
-
-=begin
=item Instrument::Event::GC
Interface to register callbacks for any given GC event.
@@ -181,12 +100,7 @@
for @hooks {
$gc.insert_hook($_);
- my $tokens := pir::split__PSS('_', $_);
- my $group := $tokens[0];
- if $group ne 'allocate' && $group ne 'reallocate' && $group ne 'free' {
- $group := 'administration';
- }
-
+ my $group := $gc.get_hook_group($_).shift();
my $event := 'GC::' ~ $group ~ '::' ~ $_;
# Register the callback.
@@ -218,12 +132,7 @@
for @hooks {
$gc.remove_hook($_);
- my $tokens := pir::split__PSS('_', $_);
- my $group := $tokens[0];
- if $group ne 'allocate' && $group ne 'reallocate' && $group ne 'free' {
- $group := 'administration';
- }
-
+ my $group := $gc.get_hook_group($_).shift();
my $event := 'GC::' ~ $group ~ '::' ~ $_;
# Register the callback.
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp Tue Jul 13 07:21:37 2010 (r48078)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp Tue Jul 13 14:53:58 2010 (r48079)
@@ -9,7 +9,7 @@
runtime/parrot/library/Instrument/Probe.nqp - Helper class to automate inserting and removing hooks from the interpreter.
=head1 SYNOPSIS
-
+
## In PIR.
.local pmc probe_class
probe_class = get_hll_global ['Instrument'], 'Probe'
@@ -21,7 +21,7 @@
probe.'inspect'('gt')
probe.'set_callback'('specific_callback')
probe.'set_finalize'('specific_finalize')
-
+
# Create a catchall probe which will be called for
# each op.
probe = probe_class.'new'()
@@ -36,7 +36,7 @@
class Instrument::Probe is Instrument::Base {
has $!is_catchall;
has @!oplist;
- has @!todo_oplist;
+ has @!op_todo_list;
our $loadlib_evt;
our @loadlib_probelist := ();
@@ -51,7 +51,7 @@
=end
method _self_init () {
- @!todo_oplist := ();
+ @!op_todo_list := ();
@!oplist := ();
$!is_catchall := 0;
};
@@ -64,12 +64,9 @@
=cut
=end
-
+
method catchall ($catchall?) {
- if pir::defined__IP($catchall) {
- $!is_catchall := $catchall;
- }
- return $!is_catchall
+ $!is_catchall := $catchall // $!iscatchall;
}
=begin
@@ -94,15 +91,14 @@
}
else {
# $op is singular.
- my $oplib := pir::new__PS('OpLib');
- my $type := pir::typeof__PP($op);
+ my %oplib := pir::new__PS('OpLib');
- if $type eq 'Integer' {
+ if pir::does__IPS($op, 'integer') {
# $op = op number.
- if $op > pir::set__IP($oplib) {
+ if $op > +%oplib {
# op number is invalid.
# Put it in the todo list.
- @!todo_oplist.push($op);
+ @!op_todo_list.push($op);
}
else {
@!oplist.push($op);
@@ -110,28 +106,22 @@
}
else {
# Lookup the op.
- my $op_ret;
- my $op_num;
-
- $op_ret := $oplib.op_family($op);
- if pir::defined__IP($op_ret) {
+ my @op_ret := %oplib.op_family($op);
+ if pir::defined__IP(@op_ret) {
# $op = short name.
- for $op_ret {
- $op_num := pir::set__IP($_);
- @!oplist.push($op_num);
+ for @op_ret {
+ @!oplist.push(pir::set__IP($_));
}
}
else {
# $op = long name.
- $op_ret := pir::set_p_p_k__PPP($oplib, $op);
- $op_num := pir::set__IP($op_ret);
- @!oplist.push($op_num);
+ @!oplist.push(pir::set__IP(%oplib{$op}));
}
}
}
CATCH {
- # Push to todo_oplist
- @!todo_oplist.push($op);
+ # Push to op_todo_list
+ @!op_todo_list.push($op);
}
};
@@ -156,18 +146,18 @@
pir::die('Probe has not been attached to an Instrument object.');
}
- # Check for any todo_oplist.
- if pir::set__IP(@!todo_oplist) != 0 {
- # Double check the todo_oplist.
- my @list := @!todo_oplist;
- @!todo_oplist := ();
+ # Check for any op_todo_list.
+ if pir::set__IP(@!op_todo_list) != 0 {
+ # Double check the op_todo_list.
+ my @list := @!op_todo_list;
+ @!op_todo_list := ();
for @list {
self.inspect($_);
}
- # If there is still a todo_oplist,
+ # If there is still a op_todo_list,
# set up an event handler to update.
- if pir::set__IP(@!todo_oplist) != 0 {
+ if +@!op_todo_list != 0 {
@Instrument::Probe::loadlib_probelist.push(self);
if !pir::defined__IP($Instrument::Probe::loadlib_evt) {
@@ -203,7 +193,7 @@
eg,
instr_obj = new ['Instrument']
instr_obj.'attach'(probe)
-
+
You can dynamically attach and remove hooks dynamically.
=cut
@@ -238,7 +228,7 @@
=end
method get_op_list () {
- return @!oplist;
+ @!oplist;
}
=begin
@@ -250,11 +240,11 @@
=end
method get_op_todo_list () {
- return @!todo_oplist;
+ @!op_todo_list;
}
# Internal helper: Callback for loadlib events registered when the probe has
- # any outstanding ops in $!todo_oplist.
+ # any outstanding ops in @!op_todo_list.
sub loadlib_callback ($data) {
# Simply disable and reenable the probe.
my @list := @Instrument::Probe::loadlib_probelist;
Modified: branches/gsoc_instrument/t/dynpmc/instrumentgc.t
==============================================================================
--- branches/gsoc_instrument/t/dynpmc/instrumentgc.t Tue Jul 13 07:21:37 2010 (r48078)
+++ branches/gsoc_instrument/t/dynpmc/instrumentgc.t Tue Jul 13 14:53:58 2010 (r48079)
@@ -328,6 +328,10 @@
gc_event = gc_class.'new'()
instr = new ['Instrument']
+ # Set up the globals.
+ $P0 = new ['Hash']
+ set_global '%!notifications', $P0
+
# Test do_gc_mark
gc_event.'inspect'('do_gc_mark')
gc_event.'callback'('sample_notification_callback')
@@ -335,15 +339,13 @@
instr.'attach'(gc_event)
instr.'run'($S0, args)
-.end
-
-.sub sample_notification_callback
- .param pmc data
+ # Check that the event was fired.
+ .local pmc data
+ data = get_global '%!notifications'
# Event fired.
- ok(1, 'Event: Event fired.')
-
- ## Test the interesting bits.
+ $I0 = data['fired']
+ is($I0, 1, 'Event: Event fired.')
# Test line.
$I0 = data['line']
@@ -362,6 +364,25 @@
is($S0, 'do_gc_mark', 'Event: Type ok.')
.end
+.sub sample_notification_callback
+ .param pmc data
+
+ .local pmc results
+ results = get_global '%!notifications'
+
+ # Save the parameters.
+ results['fired'] = 1
+ $I0 = data['line']
+ results['line'] = $I0
+ $S0 = data['file']
+ results['file'] = $S0
+ $S0 = data['sub']
+ results['sub'] = $S0
+ $S0 = data['type']
+ results['type'] = $S0
+
+.end
+
# Helper sub: Check if 2 sets with unique items are the same.
.sub is_same_set
.param pmc arr1
Modified: branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl
==============================================================================
--- branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl Tue Jul 13 07:21:37 2010 (r48078)
+++ branches/gsoc_instrument/tools/build/gen_vtable_stubs.pl Tue Jul 13 14:53:58 2010 (r48079)
@@ -53,7 +53,7 @@
# Separate out the components.
# type name(params) annotations
- if(m/^(.+)\s+(.+)\s*\((.+)\)\s*(.*)$/) {
+ if(m/^(.+)\s+(.+)\s*\((.*)\)\s*(.*)$/) {
# Generate the components.
my @data = ($1, $2, $3, $4);
#print "($1) ($2) ($3) ($4)\n";
More information about the parrot-commits
mailing list