[svn:parrot] r47732 - in branches/gsoc_instrument: examples/library runtime/parrot/library/Instrument src/dynpmc
khairul at svn.parrot.org
khairul at svn.parrot.org
Sun Jun 20 16:41:15 UTC 2010
Author: khairul
Date: Sun Jun 20 16:41:14 2010
New Revision: 47732
URL: https://trac.parrot.org/parrot/changeset/47732
Log:
Update probes on dynop loading so that hooks for dynops can be set + tab removal
Modified:
branches/gsoc_instrument/examples/library/tracer.nqp
branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp
branches/gsoc_instrument/runtime/parrot/library/Instrument/Event.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/Instrument.pir
branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp
branches/gsoc_instrument/src/dynpmc/instrument.pmc
Modified: branches/gsoc_instrument/examples/library/tracer.nqp
==============================================================================
--- branches/gsoc_instrument/examples/library/tracer.nqp Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/examples/library/tracer.nqp Sun Jun 20 16:41:14 2010 (r47732)
@@ -31,7 +31,7 @@
$instr.attach($probe);
$instr.run($args[0], $args);
-sub tracer ($op, $instr_obj) {
+sub tracer ($op, $instr_obj, $probe) {
my $sprintf_args := [$op.pc()];
my $pc_hex := pir::sprintf__SSP("%04x", $sprintf_args);
my $op_name := $op.family();
@@ -56,7 +56,7 @@
# Constant keys are int constants or strings.
if pir::band__III($arg_type, 2) == 2 {
# String constant key.
- my $arg_val := $op.get_arg($cur_arg);
+ my $arg_val := pir::escape__SS($op.get_arg($cur_arg));
$arg_str := '["' ~ $arg_val ~ '"]';
} else {
@@ -82,7 +82,7 @@
&& pir::band__III($arg_type, 2) != 2 {
if pir::band__III($arg_type, 1) == 1 {
- my $arg_val := $op.get_arg($cur_arg);
+ my $arg_val := pir::escape__SS($op.get_arg($cur_arg));
$arg_str := '"' ~ $arg_val ~ '"';
} else {
@@ -116,13 +116,9 @@
$cur_arg++;
}
- my $prefix := ' ';
- for $arg_list {
- $params := $params ~ $prefix ~ $_;
- $prefix := ', '
- }
+ $params := pir::join__SSP(', ', $arg_list);
- say($pc_hex ~ ' ' ~ $op_name ~ $params);
+ say($pc_hex ~ ' ' ~ $op_name ~ ' ' ~ $params);
};
# 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 Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp Sun Jun 20 16:41:14 2010 (r47732)
@@ -37,24 +37,24 @@
=end
- method new () {
- self := Q:PIR {
- $P0 = self.'HOW'()
- $P1 = getattribute $P0, 'parrotclass'
- %r = new $P1
- };
-
- if !pir::defined__IP($id_count) {
- $id_count := 0;
- }
-
- my $id := $id_count++;
- $!identifier := "Instrument-" ~ $id;
-
- self._self_init();
-
- return self;
- };
+ method new () {
+ self := Q:PIR {
+ $P0 = self.'HOW'()
+ $P1 = getattribute $P0, 'parrotclass'
+ %r = new $P1
+ };
+
+ if !pir::defined__IP($id_count) {
+ $id_count := 0;
+ }
+
+ my $id := $id_count++;
+ $!identifier := "Instrument-" ~ $id;
+
+ self._self_init();
+
+ return self;
+ };
=begin
@@ -67,9 +67,9 @@
=end
- method _self_init () {
- die("Abstract class Instrument::Base cannot be instantiated.");
- };
+ method _self_init () {
+ die("Abstract class Instrument::Base cannot be instantiated.");
+ };
=begin
@@ -114,7 +114,7 @@
=end
method set_data ($data) {
- $!data := $data;
+ $!data := $data;
};
=begin
@@ -126,9 +126,9 @@
=cut
=end
- method _on_attach () {
- die("Method _on_attach is unimplemented for abstract class Instrument::Base.");
- };
+ method _on_attach () {
+ die("Method _on_attach is unimplemented for abstract class Instrument::Base.");
+ };
=begin
=item enable()
@@ -156,7 +156,7 @@
# Helper sub: returns the Sub PMC object of a given sub name.
sub get_sub_obj ($sub) {
- if !pir::defined__IP($sub) {
+ if !pir::defined__IP($sub) {
die('$sub is not defined.');
}
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/Event.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/Event.nqp Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Event.nqp Sun Jun 20 16:41:14 2010 (r47732)
@@ -18,7 +18,7 @@
=end
class Instrument::Event is Instrument::Base {
- has $!initialiser;
+ has $!initialiser;
has $!event_type;
has $!probe_obj;
@@ -34,8 +34,8 @@
=end
method _self_init () {
- die("Abstract class Instrument::Event cannot be instantiated.");
- };
+ die("Abstract class Instrument::Event cannot be instantiated.");
+ };
=begin
@@ -62,17 +62,17 @@
method _on_attach () {
if pir::defined__IP($!probe_obj) {
- $!instr_obj.attach($!probe_obj);
- }
+ $!instr_obj.attach($!probe_obj);
+ }
- my $dispatcher := Q:PIR {
- $P0 = getattribute self, '$!instr_obj'
- %r = $P0['eventdispatcher']
- };
-
- if pir::defined__IP($!callback) {
- $dispatcher.register($!event_type, $!callback);
- }
+ my $dispatcher := Q:PIR {
+ $P0 = getattribute self, '$!instr_obj'
+ %r = $P0['eventdispatcher']
+ };
+
+ if pir::defined__IP($!callback) {
+ $dispatcher.register($!event_type, $!callback);
+ }
};
=begin
@@ -108,14 +108,14 @@
=end
sub _raise_event ($evt, $data) {
- my $hash := Q:PIR { %r = new ['Hash'] };
- pir::set_p_k_p($hash, 'type', 'event');
- pir::set_p_k_p($hash, 'subtype', $evt);
- pir::set_p_k_p($hash, 'data', $data);
+ my $hash := Q:PIR { %r = new ['Hash'] };
+ pir::set_p_k_p($hash, 'type', 'event');
+ pir::set_p_k_p($hash, 'subtype', $evt);
+ pir::set_p_k_p($hash, 'data', $data);
- my $task := pir::new_p_s_p__PSP('Task', $hash);
+ my $task := pir::new_p_s_p__PSP('Task', $hash);
- pir::schedule($task);
+ pir::schedule($task);
}
};
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp Sun Jun 20 16:41:14 2010 (r47732)
@@ -8,7 +8,7 @@
runtime/parrot/library/Instrument/EventDispatcher.nqp
- Specific eventhandler to handle Instrument related events.
+ Specific eventhandler to handle Instrument related events.
=head1 SYNOPSIS
@@ -33,15 +33,15 @@
=end
- method _self_init () {
- $!events := Q:PIR { %r = new ['Hash'] };
-
- Q:PIR {
+ method _self_init () {
+ $!events := Q:PIR { %r = new ['Hash'] };
+
+ Q:PIR {
$P0 = get_global 'handler'
setattribute self, 'code', $P0
addhandler self
};
- };
+ };
=begin
@@ -73,11 +73,11 @@
=end
method register ($event, $callback) {
- my $list := Q:PIR {
- find_lex $P0, '$event'
- $P1 = getattribute self, '$!events'
- %r = $P1[$P0]
- };
+ my $list := Q:PIR {
+ find_lex $P0, '$event'
+ $P1 = getattribute self, '$!events'
+ %r = $P1[$P0]
+ };
if !pir::defined__IP($list) {
$list := Q:PIR { %r = new ['ResizablePMCArray'] };
@@ -103,11 +103,12 @@
my $subtype := pir::getattribute_p_p_s__PPS($task, "subtype");
my $events := pir::getattribute_p_p_s__PPS($handler, '$!events');
my $list := pir::set_p_p_kc__PPS($events, $subtype);
+ my $data := pir::getattribute_p_p_s__PPS($task, "data");
for $list {
- $_($task);
+ $_($data);
}
};
};
-# vim: ft=perl6 expandtab shiftwidth=4:
\ No newline at end of file
+# vim: ft=perl6 expandtab shiftwidth=4:
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp Sun Jun 20 16:41:14 2010 (r47732)
@@ -67,7 +67,7 @@
$!probe_obj.set_callback(pir::get_global__PS('callback'));
};
- sub callback ($op, $instr_obj) {
+ sub callback ($op, $instr_obj, $probe) {
my $class := $op.get_arg(1);
my $data := Q:PIR { %r = new ['ResizablePMCArray'] };
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/Instrument.pir
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/Instrument.pir Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Instrument.pir Sun Jun 20 16:41:14 2010 (r47732)
@@ -29,8 +29,8 @@
.end
.sub 'die'
- .param pmc msg
- die msg
+ .param pmc msg
+ die msg
.end
# Local Variables:
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp Sun Jun 20 16:41:14 2010 (r47732)
@@ -36,6 +36,9 @@
class Instrument::Probe is Instrument::Base {
has $!is_catchall;
has $!oplist;
+ has $!todo_oplist;
+ our $loadlib_evt;
+ our $loadlib_probelist := Q:PIR { %r = new ['ResizablePMCArray'] };
=begin
@@ -47,10 +50,11 @@
=end
- method _self_init () {
- $!oplist := Q:PIR { %r = new ['ResizablePMCArray'] };
- $!is_catchall := 0;
- };
+ method _self_init () {
+ $!todo_oplist := Q:PIR { %r = new ['ResizablePMCArray'] };
+ $!oplist := Q:PIR { %r = new ['ResizablePMCArray'] };
+ $!is_catchall := 0;
+ };
=begin
=item make_catchall()
@@ -71,12 +75,8 @@
op can be identified by op number, op short name and op full name.
A list of ops can also be passed, eg. in NQP, $p.inspect(['gt','lt']);
-If a non-existant op is found, a warning message is printed out.
-
-TODO: A problem will be dynops. Since we are checking ops before
- the code is even loaded, ops that exists in dynop libs are
- considered non-existent. Create a deferred list that the
- instrument pmc will run before the first opcode is executed.
+If a non-existant op is found, it is placed on a todo list which is reevaluated
+everytime a dynlib is loaded.
=cut
=end
@@ -116,12 +116,15 @@
}
}
}
- CATCH { say('Warning: Op ' ~ $op ~ ' does not exist.'); return; }
+ CATCH {
+ # Push to todo_oplist
+ $!todo_oplist.push($op);
+ }
};
- method _on_attach() {
- self.enable();
- };
+ method _on_attach() {
+ self.enable();
+ };
=begin
=item enable()
@@ -139,18 +142,41 @@
if !pir::defined__IP($!instr_obj) {
pir::die('Probe has not been attached to an Instrument object.');
}
-
+
+ # Check for any todo_oplist.
+ if pir::set_i_p__IP($!todo_oplist) != 0 {
+ # Double check the todo_oplist.
+ my $list := $!todo_oplist;
+ $!todo_oplist := Q:PIR { %r = new ['ResizablePMCArray'] };
+ for $list {
+ self.inspect($_);
+ }
+
+ # If there is still a todo_oplist,
+ # set up an event handler to update.
+ if pir::set_i_p__IP($!todo_oplist) != 0 {
+ $Instrument::Probe::loadlib_probelist.push(self);
+
+ if !pir::defined__IP($Instrument::Probe::loadlib_evt) {
+ $Instrument::Probe::loadlib_evt := Instrument::Event::Internal::loadlib.new();
+ $Instrument::Probe::loadlib_evt.set_callback(pir::get_global__PS('loadlib_callback'));
+ $Instrument::Probe::loadlib_evt.set_data(self);
+ $!instr_obj.attach($Instrument::Probe::loadlib_evt);
+ }
+ }
+ }
+
if !$!is_enabled {
if $!is_catchall {
# Attach a catchall hook.
- $!instr_obj.insert_op_catchall($!identifier, $!callback);
+ $!instr_obj.insert_op_catchall(self);
} else {
# Attach a hook to each op in @!oplist.
for $!oplist {
- $!instr_obj.insert_op_hook($!identifier, $_, $!callback);
+ $!instr_obj.insert_op_hook(self, $_);
}
}
-
+
$!is_enabled := 1;
}
};
@@ -173,21 +199,33 @@
if !pir::defined__IP($!instr_obj) {
pir::die('Probe has not been attached to an Instrument object.');
}
-
+
if $!is_enabled {
if $!is_catchall {
# Attach a catchall hook.
- $!instr_obj.remove_op_catchall($!identifier, $!callback);
+ $!instr_obj.remove_op_catchall(self);
} else {
# Attach a hook to each op in @!oplist.
for $!oplist {
- $!instr_obj.remove_op_hook($!identifier, $_, $!callback);
+ $!instr_obj.remove_op_hook(self, $_);
}
}
-
+
$!is_enabled := 0;
}
};
+
+ # Internal helper: Callback for loadlib events registered when the probe has
+ # any outstanding ops in $!todo_oplist.
+ sub loadlib_callback ($data) {
+ # Simply disable and reenable the probe.
+ my $list := $Instrument::Probe::loadlib_probelist;
+ $Instrument::Probe::loadlib_probelist := Q:PIR { %r = new ['ResizablePMCArray'] };
+ for $list {
+ $_.disable();
+ $_.enable();
+ }
+ }
};
# vim: ft=perl6 expandtab shiftwidth=4:
Modified: branches/gsoc_instrument/src/dynpmc/instrument.pmc
==============================================================================
--- branches/gsoc_instrument/src/dynpmc/instrument.pmc Sun Jun 20 15:09:15 2010 (r47731)
+++ branches/gsoc_instrument/src/dynpmc/instrument.pmc Sun Jun 20 16:41:14 2010 (r47732)
@@ -360,7 +360,7 @@
/*
-=item C<void *insert_op_hooks(PMC *id, INTVAL op_num, PMC *hook)>
+=item C<void *insert_op_hooks(PMC *probe, INTVAL op_num)>
Insert a hook for the given op number.
@@ -368,7 +368,7 @@
*/
- METHOD insert_op_hook(PMC *id, INTVAL op_num, PMC *hook) {
+ METHOD insert_op_hook(PMC *probe, INTVAL op_num) {
Parrot_Instrument_attributes * const attr = PARROT_INSTRUMENT(SELF);
Instrument_runcore_t *core = (Instrument_runcore_t *) attr->supervised->run_core;
probe_list_t **list = core->op_hooks;
@@ -383,12 +383,12 @@
list[index] = probe_list_create_list(INTERP);
}
- probe_list_push(INTERP, list[index], hook);
+ probe_list_push(INTERP, list[index], probe);
}
/*
-=item C<void *remove_op_hooks(PMC *id, INTVAL op_num, PMC *callback)>
+=item C<void *remove_op_hooks(PMC *probe, INTVAL op_num)>
Removes a hook for the given op number.
@@ -396,7 +396,7 @@
*/
- METHOD remove_op_hook(PMC *id, INTVAL op_num, PMC *callback) {
+ METHOD remove_op_hook(PMC *probe, INTVAL op_num) {
Parrot_Instrument_attributes * const attr = PARROT_INSTRUMENT(SELF);
Instrument_runcore_t *core = (Instrument_runcore_t *) attr->supervised->run_core;
probe_list_t **list = core->op_hooks;
@@ -409,7 +409,7 @@
}
if (list[index] != NULL) {
- node = probe_list_find(INTERP, list[index], callback);
+ node = probe_list_find(INTERP, list[index], probe);
if (node != NULL) {
probe_list_remove(INTERP, list[index], node);
@@ -418,8 +418,9 @@
if (node == NULL) {
/* Callback was not found. */
+ PMC *id = VTABLE_get_attr_str(INTERP, probe, CONST_STRING(INTERP, "$!identifier"));
Parrot_ex_throw_from_c_args(INTERP, NULL, 1,
- "Probe of '%S' not found in 'removal_op_hook'",
+ "Probe '%Ss' not found in 'remove_op_hook'",
VTABLE_get_string(INTERP, id));
}
}
@@ -449,41 +450,42 @@
}
/*
-=item C<void *insert_op_catchall(PMC *id, PMC *callback)>
+=item C<void *insert_op_catchall(PMC *probe)>
Register a catchall op callback
=cut
*/
- METHOD insert_op_catchall(PMC *id, PMC *callback) {
+ METHOD insert_op_catchall(PMC *probe) {
Parrot_Instrument_attributes * const attr = PARROT_INSTRUMENT(SELF);
Instrument_runcore_t *core = (Instrument_runcore_t *) attr->supervised->run_core;
probe_list_t *list = core->op_catchall;
- probe_list_push(INTERP, list, callback);
+ probe_list_push(INTERP, list, probe);
}
/*
-=item C<void *remove_op_catchall(PMC *id, PMC *callback)>
+=item C<void *remove_op_catchall(PMC *probe)>
Deregister a catchall op callback
=cut
*/
- METHOD remove_op_catchall(PMC *id, PMC *callback) {
+ METHOD remove_op_catchall(PMC *probe) {
Parrot_Instrument_attributes * const attr = PARROT_INSTRUMENT(SELF);
Instrument_runcore_t *core = (Instrument_runcore_t *) attr->supervised->run_core;
probe_list_t *list = core->op_catchall;
probe_node_t *node = NULL;
- node = probe_list_find(INTERP, list, callback);
+ node = probe_list_find(INTERP, list, probe);
if (node == NULL) {
/* Callback was not found. */
+ PMC *id = VTABLE_get_attr_str(INTERP, probe, CONST_STRING(INTERP, "$!identifier"));
Parrot_ex_throw_from_c_args(INTERP, NULL, 1,
- "Probe of '%S' not found in 'removal_op_hook'",
+ "Probe '%S' not found in 'remove_op_catchall'",
VTABLE_get_string(INTERP, id));
}
@@ -703,10 +705,14 @@
}
/* Fire the probe. */
- callback = cur_probe->list_obj;
+ callback = VTABLE_get_attr_str(supervisor, cur_probe->list_obj,
+ CONST_STRING(supervisor, "$!callback"));
next = cur_probe->next;
if (!PMC_IS_NULL(callback)) {
- Parrot_ext_call(supervisor, callback, "PP->", op_data, instrument);
+ /* Pass params: InstrumentOp, Instrument, Instrument::Probe */
+ Parrot_ext_call(supervisor, callback,
+ "PPP->",
+ op_data, instrument, cur_probe->list_obj);
}
cur_probe = next;
}
@@ -764,6 +770,7 @@
task_data = Parrot_pmc_new(supervisor, enum_class_ResizablePMCArray);
VTABLE_push_string(supervisor, task_data, VTABLE_get_string(interp, lib));
+ VTABLE_push_pmc(supervisor, task_data, core->supervisor_pmc);
task_hash = Parrot_pmc_new(supervisor, enum_class_Hash);
VTABLE_set_string_keyed_str(supervisor, task_hash,
More information about the parrot-commits
mailing list