[svn:parrot] r47530 - in branches/gsoc_instrument: . config/gen/makefiles examples/library runtime/parrot/library/Instrument src/dynpmc
khairul at svn.parrot.org
khairul at svn.parrot.org
Thu Jun 10 12:36:24 UTC 2010
Author: khairul
Date: Thu Jun 10 12:36:23 2010
New Revision: 47530
URL: https://trac.parrot.org/parrot/changeset/47530
Log:
Made the runtime library a single pbc + event notification
Added:
branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp (contents, props changed)
branches/gsoc_instrument/runtime/parrot/library/Instrument/Event.nqp (contents, props changed)
branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp (contents, props changed)
branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp (contents, props changed)
Modified:
branches/gsoc_instrument/MANIFEST
branches/gsoc_instrument/config/gen/makefiles/root.in
branches/gsoc_instrument/examples/library/tracer.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/MANIFEST
==============================================================================
--- branches/gsoc_instrument/MANIFEST Thu Jun 10 12:34:01 2010 (r47529)
+++ branches/gsoc_instrument/MANIFEST Thu Jun 10 12:36:23 2010 (r47530)
@@ -1155,6 +1155,10 @@
runtime/parrot/library/Getopt/Obj.pir [library]
runtime/parrot/library/HTTP/Daemon.pir [library]
runtime/parrot/library/HTTP/Message.pir [library]
+runtime/parrot/library/Instrument/Base.nqp [library]
+runtime/parrot/library/Instrument/Event.nqp [library]
+runtime/parrot/library/Instrument/EventDispatcher.nqp [library]
+runtime/parrot/library/Instrument/EventLibrary.nqp [library]
runtime/parrot/library/Instrument/Instrument.pir [library]
runtime/parrot/library/Instrument/Probe.nqp [library]
runtime/parrot/library/Iter.pir [library]
Modified: branches/gsoc_instrument/config/gen/makefiles/root.in
==============================================================================
--- branches/gsoc_instrument/config/gen/makefiles/root.in Thu Jun 10 12:34:01 2010 (r47529)
+++ branches/gsoc_instrument/config/gen/makefiles/root.in Thu Jun 10 12:36:23 2010 (r47530)
@@ -327,8 +327,13 @@
$(LIBRARY_DIR)/STM.pbc \
$(LIBRARY_DIR)/libpcre.pbc \
$(LIBRARY_DIR)/postgres.pbc \
- $(LIBRARY_DIR)/Instrument/Instrument.pbc \
- $(LIBRARY_DIR)/Instrument/Probe.pbc
+ $(LIBRARY_DIR)/Instrument/InstrumentLib.pbc \
+ $(LIBRARY_DIR)/Instrument/Instrument.pbc \
+ $(LIBRARY_DIR)/Instrument/Base.pbc \
+ $(LIBRARY_DIR)/Instrument/Probe.pbc \
+ $(LIBRARY_DIR)/Instrument/Event.pbc \
+ $(LIBRARY_DIR)/Instrument/EventDispatcher.pbc \
+ $(LIBRARY_DIR)/Instrument/EventLibrary.pbc
FLUID_FILES_1 = \
$(GEN_HEADERS) \
@@ -1122,9 +1127,30 @@
#
###############################################################################
+$(LIBRARY_DIR)/Instrument/InstrumentLib.pbc: $(LIBRARY_DIR)/Instrument/Instrument.pbc \
+ $(LIBRARY_DIR)/Instrument/Base.pbc $(LIBRARY_DIR)/Instrument/Probe.pbc \
+ $(LIBRARY_DIR)/Instrument/EventDispatcher.pbc $(LIBRARY_DIR)/Instrument/Event.pbc \
+ $(LIBRARY_DIR)/Instrument/EventLibrary.pbc
+ $(PBC_MERGE) -o $@ $(LIBRARY_DIR)/Instrument/Instrument.pbc \
+ $(LIBRARY_DIR)/Instrument/Base.pbc $(LIBRARY_DIR)/Instrument/Probe.pbc \
+ $(LIBRARY_DIR)/Instrument/EventDispatcher.pbc $(LIBRARY_DIR)/Instrument/Event.pbc \
+ $(LIBRARY_DIR)/Instrument/EventLibrary.pbc
+
+$(LIBRARY_DIR)/Instrument/Base.pir: $(LIBRARY_DIR)/Instrument/Base.nqp $(NQP_RX)
+ $(NQP_RX) --target=pir $(LIBRARY_DIR)/Instrument/Base.nqp > $@
+
$(LIBRARY_DIR)/Instrument/Probe.pir: $(LIBRARY_DIR)/Instrument/Probe.nqp $(NQP_RX)
$(NQP_RX) --target=pir $(LIBRARY_DIR)/Instrument/Probe.nqp > $@
+$(LIBRARY_DIR)/Instrument/EventDispatcher.pir: $(LIBRARY_DIR)/Instrument/EventDispatcher.nqp $(NQP_RX)
+ $(NQP_RX) --target=pir $(LIBRARY_DIR)/Instrument/EventDispatcher.nqp > $@
+
+$(LIBRARY_DIR)/Instrument/Event.pir: $(LIBRARY_DIR)/Instrument/Event.nqp $(NQP_RX)
+ $(NQP_RX) --target=pir $(LIBRARY_DIR)/Instrument/Event.nqp > $@
+
+$(LIBRARY_DIR)/Instrument/EventLibrary.pir: $(LIBRARY_DIR)/Instrument/EventLibrary.nqp $(NQP_RX)
+ $(NQP_RX) --target=pir $(LIBRARY_DIR)/Instrument/EventLibrary.nqp > $@
+
runtime/parrot/include/interpflags.pasm : $(INC_DIR)/interpreter.h $(H2INC)
$(PERL) $(H2INC) $(INC_DIR)/interpreter.h $@
runtime/parrot/include/interpdebug.pasm : $(INC_DIR)/interpreter.h $(H2INC)
Modified: branches/gsoc_instrument/examples/library/tracer.nqp
==============================================================================
--- branches/gsoc_instrument/examples/library/tracer.nqp Thu Jun 10 12:34:01 2010 (r47529)
+++ branches/gsoc_instrument/examples/library/tracer.nqp Thu Jun 10 12:36:23 2010 (r47530)
@@ -18,8 +18,7 @@
=cut
Q:PIR {
- load_bytecode 'Instrument/Instrument.pbc'
- load_bytecode 'Instrument/Probe.pbc'
+ load_bytecode 'Instrument/InstrumentLib.pbc'
};
my $args := pir::getinterp__p()[2];
Added: branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Base.nqp Thu Jun 10 12:36:23 2010 (r47530)
@@ -0,0 +1,194 @@
+#! nqp
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=begin
+
+=head1 NAME
+
+runtime/parrot/library/Instrument/Base.nqp - Abstract class for the Instruments library
+
+=head1 SYNOPSIS
+
+ Abstract class for the Instruments library.
+
+=cut
+
+=end
+
+class Instrument::Base {
+ has $!instr_obj;
+ has $!identifier;
+ has $!is_enabled;
+ has $!callback;
+ has $!finalize;
+ has $!data;
+ our $id_count;
+
+=begin
+
+=item new ()
+
+Overrides the default constructor provided in P6object.pbc.
+Initialises $!identifer and then calls the subclass specific
+_self_init method.
+
+=cut
+
+=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;
+ };
+
+=begin
+
+=item _self_init ()
+
+Private method to perform additional initialisation.
+Stub method for abstract base class.
+
+=cut
+
+=end
+
+ method _self_init () {
+ die("Abstract class Instrument::Base cannot be instantiated.");
+ };
+
+=begin
+
+=item set_callback(sub) or set_callback('sub')
+
+Set the sub callback to be called when the desired op is
+encountered. sub can be passed by name or reference through a
+Sub PMC object.
+
+=cut
+
+=end
+
+ method set_callback ($sub) {
+ $!callback := get_sub_obj($sub);
+ };
+
+=begin
+
+=item set_finalize(sub) or set_finalize('sub')
+
+Set the sub callback to be called at the end of execution.
+sub can be passed by name or reference through a Sub PMC object.
+Sub will only be called if the probe is enabled at the end of execution.
+
+=cut
+
+=end
+
+ method set_finalize ($sub) {
+ $!finalize := get_sub_obj($sub);
+ };
+
+=begin
+
+=item set_data(data)
+
+Sets the data attribute.
+
+=cut
+
+=end
+
+ method set_data ($data) {
+ $!data := $data;
+ };
+
+=begin
+=item _on_attach()
+
+Private method that is called on attaching to the Instrument dynpmc.
+Stub method. To be implemented by child classes.
+
+=cut
+=end
+
+ method _on_attach () {
+ die("Method _on_attach is unimplemented for abstract class Instrument::Base.");
+ };
+
+=begin
+=item enable()
+
+Stub method. To be implemented by child classes.
+
+=cut
+=end
+
+ method enable () {
+ die("Method enable is unimplemented for abstract class Instrument::Base.");
+ };
+
+=begin
+=item disable()
+
+Stub method. To be implemented by child classes.
+
+=cut
+=end
+
+ method disable () {
+ die("Method disable is unimplemented for abstract class Instrument::Base.");
+ };
+
+ # Helper sub: returns the Sub PMC object of a given sub name.
+ sub get_sub_obj ($sub) {
+ if !pir::defined__IP($sub) {
+ 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::defined__IP($lookup) {
+ pir::die('Could not find sub ' ~ $sub ~ ' in the namespaces.');
+ }
+
+ $sub := $lookup;
+ }
+
+ # 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.');
+ }
+
+ return $sub;
+ };
+};
+
+# vim: ft=perl6 expandtab shiftwidth=4:
\ No newline at end of file
Added: branches/gsoc_instrument/runtime/parrot/library/Instrument/Event.nqp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Event.nqp Thu Jun 10 12:36:23 2010 (r47530)
@@ -0,0 +1,120 @@
+#! nqp
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=begin
+
+=head1 NAME
+
+runtime/parrot/library/Instrument/Event.nqp - Abstract class for the Instruments library
+
+=head1 SYNOPSIS
+
+ Abstract class for the Instruments library.
+ Provides event specific methods.
+
+=cut
+
+=end
+
+class Instrument::Event is Instrument::Base {
+ has $!initialiser;
+ has $!event_type;
+ has $!probe_obj;
+
+=begin
+
+=item _self_init ()
+
+Private method to perform additional initialisation.
+Stub method for abstract base Instrument::Event class.
+
+=cut
+
+=end
+
+ method _self_init () {
+ die("Abstract class Instrument::Event cannot be instantiated.");
+ };
+
+=begin
+
+=item inspect ($item)
+
+Stub method for abstract base Instrument::Event class.
+
+=cut
+
+=end
+
+ method inspect ($item) {
+ die("Method inspect is unimplemented for abstract class Instrument::Event.");
+ };
+
+=begin
+=item _on_attach()
+
+Private method that is called on attaching to the Instrument dynpmc.
+Registers callbacks with the EventDispatcher Object in the Instrument dynpmc.
+
+=cut
+=end
+
+ method _on_attach () {
+ $!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);
+ }
+ };
+
+=begin
+=item enable()
+
+Make the event hooks active.
+
+=cut
+=end
+
+ method enable () {
+ $!probe_obj.enable();
+ };
+
+=begin
+=item disable()
+
+Remove the event hooks.
+
+=cut
+=end
+
+ method disable () {
+ $!probe_obj.disable();
+ };
+
+=begin
+=item _raise_event($event, $data)
+
+Helper sub that creates a Task instance and schedules it.
+
+=cut
+=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 $task := pir::new_p_s_p__PSP('Task', $hash);
+
+ pir::schedule($task);
+ }
+};
+
+# vim: ft=perl6 expandtab shiftwidth=4:
\ No newline at end of file
Added: branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/EventDispatcher.nqp Thu Jun 10 12:36:23 2010 (r47530)
@@ -0,0 +1,113 @@
+#! nqp
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=begin
+
+=head1 NAME
+
+runtime/parrot/library/Instrument/EventDispatcher.nqp
+
+ Specific eventhandler to handle Instrument related events.
+
+=head1 SYNOPSIS
+
+ Each Instrument instance has an instance of this class,
+ which will intercept all events raised and handle those which
+ has eventhandlers registered with it.
+
+=cut
+
+=end
+
+class Instrument::EventDispatcher is EventHandler {
+ has $!events;
+
+=begin
+
+=item _self_init ()
+
+Private method to perform required initialisation.
+
+=cut
+
+=end
+
+ method _self_init () {
+ $!events := Q:PIR { %r = new ['Hash'] };
+
+ Q:PIR {
+ $P0 = get_global 'handler'
+ setattribute self, 'code', $P0
+ addhandler self
+ };
+ };
+
+=begin
+
+=item can_handle ($task)
+
+Overrides the can_handle method of parent EventHandler
+and checks if there is a handler(s) registered with it
+to handle that task.
+
+=cut
+
+=end
+
+ method can_handle ($task) {
+ my $subtype := pir::getattribute_p_p_s__PPS($task, "subtype");
+ my $list := pir::set_p_p_kc__PPS($!events, $subtype);
+
+ return pir::defined__IP($list);
+ };
+
+=begin
+
+=item register ($event, $callback)
+
+Registers the handler for the given event.
+
+=cut
+
+=end
+
+ method register ($event, $callback) {
+ 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'] };
+ pir::set_p_k_p($!events, $event, $list);
+ }
+
+ $list.push($callback);
+ };
+
+=begin
+
+=item handler ($event, $callback)
+
+Helper sub that acts as the callback for the EventDispatcher
+to dispatch the events to all the appropriate handler(s) registered
+with it.
+
+=cut
+
+=end
+
+ sub handler ($handler, $task) {
+ 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);
+
+ for $list {
+ $_($task);
+ }
+ };
+};
+
+# vim: ft=perl6 expandtab shiftwidth=4:
\ No newline at end of file
Added: branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/EventLibrary.nqp Thu Jun 10 12:36:23 2010 (r47530)
@@ -0,0 +1,145 @@
+#! nqp
+# Copyright (C) 2010, Parrot Foundation.
+# $Id$
+
+=begin
+
+=head1 NAME
+
+runtime/parrot/library/Instrument/EventLibrary.nqp
+
+ Library for the many classes that provide handlers for Events.
+
+=head1 SYNOPSIS
+
+ Each class in this library provides an interface to hook into
+ a particular event.
+
+ Example usage:
+
+ # Create a catchall probe which will be called for
+ # each op.
+ evt = new ['Instrument';'Event';'Internal';'loadlib']
+ evt.'set_callback'('loadlib_callback')
+
+ instr = new ['Instrument']
+ instr.attach(evt)
+
+=cut
+
+=end
+
+
+=begin
+=item Instrument::Event::Internal::loadlib
+
+Raises an event whenever a dynlib is loaded.
+
+TODO: Need some C code for .loadlib directives. Not sure how to yet.
+
+=cut
+=end
+
+class Instrument::Event::Internal::loadlib is Instrument::Event {
+
+ method _self_init() {
+ $!event_type := 'Instrument::Event::Internal::loadlib';
+
+ $!probe_obj := Instrument::Probe.new();
+
+ $!probe_obj.inspect('loadlib');
+ $!probe_obj.set_callback(pir::get_global__PS('callback'));
+ };
+
+ sub callback ($pc, $op, $instr_obj) {
+ my $op_lib := Q:PIR { %r = new ['OpLib'] };
+ my $op_code := pir::set_p_p_ki__PPI($op_lib, $op[0]);
+ my $arg_type := pir::set_i_p_ki__IPI($op_code, 1);
+ my $lib := $instr_obj.get_op_arg($op[2], $arg_type);
+
+ my $data := Q:PIR { %r = new ['ResizablePMCArray'] };
+ $data.push($lib);
+ $data.push($pc);
+ $data.push($op);
+ $data.push($instr_obj);
+
+ Instrument::Event::_raise_event('Instrument::Event::Internal::loadlib', $data);
+ };
+};
+
+=begin
+=item Instrument::Event::Class:instantiate
+
+Raises an event whenever a class is instantiated.
+
+TODO: Add inspect so that specific classes can be targetted.
+
+=cut
+=end
+
+class Instrument::Event::Class::instantiate is Instrument::Event {
+
+ method _self_init() {
+ $!event_type := 'Instrument::Event::Class::instantiate';
+
+ $!probe_obj := Instrument::Probe.new();
+
+ $!probe_obj.inspect('new');
+ $!probe_obj.set_callback(pir::get_global__PS('callback'));
+ };
+
+ sub callback ($pc, $op, $instr_obj) {
+ my $op_lib := Q:PIR { %r = new ['OpLib'] };
+ my $op_code := pir::set_p_p_ki__PPI($op_lib, $op[0]);
+ my $arg_type := pir::set_i_p_ki__IPI($op_code, 1);
+ my $class := $instr_obj.get_op_arg($op[2], $arg_type);
+
+ my $data := Q:PIR { %r = new ['ResizablePMCArray'] };
+ $data.push($class);
+ $data.push($pc);
+ $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: Add inspect so that specific methods and classes can be targetted.
+
+=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.set_callback(pir::get_global__PS('callback'));
+ };
+
+ sub callback ($pc, $op, $instr_obj) {
+ my $op_lib := Q:PIR { %r = new ['OpLib'] };
+ my $op_code := pir::set_p_p_ki__PPI($op_lib, $op[0]);
+ my $arg_type := pir::set_i_p_ki__IPI($op_code, 1);
+ my $method := $instr_obj.get_op_arg($op[2], $arg_type);
+
+ my $data := Q:PIR { %r = new ['ResizablePMCArray'] };
+ $data.push($method);
+ $data.push($pc);
+ $data.push($op);
+ $data.push($instr_obj);
+
+ Instrument::Event::_raise_event('Instrument::Event::Class::callmethod', $data);
+ };
+};
+
+# vim: ft=perl6 expandtab shiftwidth=4:
\ No newline at end of file
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/Instrument.pir
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/Instrument.pir Thu Jun 10 12:34:01 2010 (r47529)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Instrument.pir Thu Jun 10 12:36:23 2010 (r47530)
@@ -8,7 +8,7 @@
=head1 SYNOPSIS
# Load the instrument dynpmc and required libraries.
- load_bytecode 'Instrument/Instrument.pbc'
+ load_bytecode 'Instrument/InstrumentLib.pbc'
=cut
@@ -28,6 +28,11 @@
say msg
.end
+.sub 'die'
+ .param pmc msg
+ die msg
+.end
+
# Local Variables:
# mode: pir
# fill-column: 100
Modified: branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp
==============================================================================
--- branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp Thu Jun 10 12:34:01 2010 (r47529)
+++ branches/gsoc_instrument/runtime/parrot/library/Instrument/Probe.nqp Thu Jun 10 12:36:23 2010 (r47530)
@@ -31,49 +31,26 @@
=end
-class Instrument::Probe {
- has $!instr_obj;
- has $!identifier;
- has $!is_enabled;
+class Instrument::Probe is Instrument::Base {
has $!is_catchall;
- has $!callback;
- has $!finalize;
has $!oplist;
- our $id_count;
=begin
-=item set_callback(sub) or set_callback('sub')
+=item _self_init ()
-Set the sub callback to be called when the desired op is
-encountered. sub can be passed by name or reference through a
-Sub PMC object.
+Private method to perform additional initialisation.
=cut
=end
- method set_callback ($sub) {
- $!callback := get_sub_obj($sub);
- };
+ method _self_init () {
+ $!oplist := Q:PIR { %r = new ['ResizablePMCArray'] };
+ $!is_catchall := 0;
+ };
=begin
-
-=item set_finalize(sub) or set_finalize('sub')
-
-Set the sub callback to be called at the end of execution.
-sub can be passed by name or reference through a Sub PMC object.
-Sub will only be called if the probe is enabled at the end of execution.
-
-=cut
-
-=end
-
- method set_finalize ($sub) {
- $!finalize := get_sub_obj($sub);
- };
-
-=begin
=item make_catchall()
Set this probe to catch all ops.
@@ -111,9 +88,6 @@
} else {
# $op is singular.
my $type := pir::typeof__PP($op);
- if !pir::defined__IP($!oplist) {
- $!oplist := Q:PIR { %r = new ['ResizablePMCArray'] };
- }
if $type eq 'Integer' {
# $op = op number.
@@ -143,6 +117,10 @@
CATCH { say('Warning: Op ' ~ $op ~ ' does not exist.'); return; }
};
+ method _on_attach() {
+ self.enable();
+ };
+
=begin
=item enable()
@@ -151,14 +129,11 @@
eg,
instr_obj = new ['Instrument']
instr_obj.'attach'(probe)
-
-Additionally, attach will call this method automatically.
=cut
=end
method enable () {
- if !pir::defined__IP($!identifier) { $!identifier := get_id(); }
if !pir::defined__IP($!instr_obj) {
pir::die('Probe has not been attached to an Instrument object.');
}
@@ -193,7 +168,6 @@
=end
method disable () {
- if !pir::defined__IP($!identifier) { $!identifier := get_id(); }
if !pir::defined__IP($!instr_obj) {
pir::die('Probe has not been attached to an Instrument object.');
}
@@ -212,46 +186,6 @@
$!is_enabled := 0;
}
};
-
- # Helper sub: returns the next available probe id.
- sub get_id () {
- if !$id_count { $id_count := 0; }
- my $id := $id_count++;
- return "Probe-" ~ $id;
- };
-
- # Helper sub: returns the Sub PMC object of a given sub name.
- sub get_sub_obj ($sub) {
- 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::defined__IP($lookup) {
- pir::die('Could not find sub ' ~ $sub ~ ' in the namespaces.');
- }
-
- $sub := $lookup;
- }
-
- # Ensure that $sub is of type 'Sub'.
- $type := pir::typeof__PP($sub);
- if $type ne 'Sub' {
- pir::die('Type of $sub is not "Sub" but ' ~ $type ~ ' instead.');
- }
-
- return $sub;
- };
-
};
# vim: ft=perl6 expandtab shiftwidth=4:
Modified: branches/gsoc_instrument/src/dynpmc/instrument.pmc
==============================================================================
--- branches/gsoc_instrument/src/dynpmc/instrument.pmc Thu Jun 10 12:34:01 2010 (r47529)
+++ branches/gsoc_instrument/src/dynpmc/instrument.pmc Thu Jun 10 12:36:23 2010 (r47530)
@@ -78,6 +78,7 @@
pmclass Instrument auto_attrs dynpmc provides hash {
ATTR Parrot_Interp supervised; /* The interpreter running the code */
ATTR PMC *probes; /* A list of probes registered. */
+ ATTR PMC *evt_dispatcher;
/*
@@ -91,10 +92,23 @@
VTABLE void init() {
Parrot_Instrument_attributes * const attr = PARROT_INSTRUMENT(SELF);
+ PMC *evt_key1, *evt_key2, *nothing;
+ INTVAL evt_class_type;
+
+ /* Obtain the class type of Instrument::EventDispatcher. */
+ evt_key1 = key_new_cstring(INTERP, "Instrument");
+ evt_key2 = key_new_cstring(INTERP, "EventDispatcher");
+ key_append(INTERP, evt_key1, evt_key2);
+
+ evt_class_type = Parrot_pmc_get_type(INTERP, evt_key1);
/* Create the child interpreter PMC */
- attr->supervised = Parrot_new(INTERP);
- attr->probes = Parrot_pmc_new(INTERP, enum_class_Hash);
+ attr->supervised = Parrot_new(INTERP);
+ attr->probes = Parrot_pmc_new(INTERP, enum_class_Hash);
+ attr->evt_dispatcher = Parrot_pmc_new(INTERP, evt_class_type);
+
+ /* Initialise the event dispatcher */
+ (PMC *nothing) = PCCINVOKE(INTERP, attr->evt_dispatcher, "_self_init");
/* Initialize the runcore for the child interpreter */
Instrument_runcore_init(attr->supervised, INTERP, SELF);
@@ -144,6 +158,7 @@
/* Mark attributes as alive */
Parrot_gc_mark_PMC_alive_fun(INTERP, attr->probes);
+ Parrot_gc_mark_PMC_alive_fun(INTERP, attr->evt_dispatcher);
}
/*
@@ -153,7 +168,8 @@
Get the property with the key.
Keys:
-probes: returns the hash of probes currently registered.
+probes : returns the hash of probes currently registered.
+eventdispatcher : return the event dispatcher instance.
Unknown keys are sent to the supervised interpreter.
@@ -172,6 +188,12 @@
if (Parrot_str_equal(INTERP, name, item)) {
return attr->probes;
}
+
+ /* eventdispatcher: return the event dispatcher instance */
+ name = CONST_STRING(INTERP, "eventdispatcher");
+ if (Parrot_str_equal(INTERP, name, item)) {
+ return attr->evt_dispatcher;
+ }
/* push to the supervised interpreter. */
supervised_pmc = VTABLE_get_pmc_keyed_int(attr->supervised,
@@ -297,12 +319,12 @@
SELF);
/* Find the enable method */
- enable_method = VTABLE_find_method(INTERP, obj, CONST_STRING(INTERP, "enable"));
+ enable_method = VTABLE_find_method(INTERP, obj, CONST_STRING(INTERP, "_on_attach"));
if (PMC_IS_NULL(enable_method)) {
/* Error! Could not find the enable method. */
Parrot_ex_throw_from_c_args(
INTERP, NULL, 1,
- "Could not locate the method 'enable'."
+ "Could not locate the method '_on_attach'."
);
}
@@ -600,6 +622,13 @@
supervisor->op_count = interp->op_count;
supervisor->op_func_table = interp->op_func_table;
supervisor->op_info_table = interp->op_info_table;
+
+ if(supervisor->evc_func_table != NULL) {
+ mem_gc_free(supervisor, supervisor->evc_func_table);
+
+ supervisor->evc_func_table = NULL;
+ supervisor->save_func_table = NULL;
+ }
}
Instrument_fire_hooks(pc, interp);
More information about the parrot-commits
mailing list