[m-dev.] For review: implementation of collect for Opium-M

Erwan Jahier Erwan.Jahier at irisa.fr
Wed Oct 27 23:36:34 AEST 1999


Estimated hours taken: 100

This change implements the `collect/2' command for opium-M. `collect/2'
collects runtime information from Mercury program executions. It is intended to
let users easily implement their own monitors with acceptable performances. It
looks like the `fold/4' meta-predicate, except:

   (1)	It operates on-the fly on a sequence of events rather than on a
	list.
   (2)	The accumulator is initialized and updated via Mercury predicates 
	whose implementation is in a file pass down as the first argument 
	 of `collect/2'.


browser/collect_lib.m:
	New module that defines link_collect/7 that is used during a `collect' 
	request: it performs the dynamic linking between collect.so and the
	current execution.


browser/browser_library.m:
	Add `collect_lib' module in the list of modules that should be part of
	the browser library.


browser/debugger_interface.m:
	Add 2 new debugger requests `link_collect' and `collect':
	(1) `link_collect' to dynamically link the module collect.m with the 
	current execution; (2) `collect' to start the monitoring process.

	Add the new request `current_grade' which lets the external debugger
	know the grade the current execution has been compiled with; it is 
	necessary to be able to compile collect.m in the same grade as the 
	the program being monitored.


browser/dl.m:
	Move the type definition of the type `handle' to be able to use it in
	the collect_lib module.


trace/mercury_trace_external.c:
	Add support to handle the requests `link_collect', `collect' and 
	`current_grade'.

	Replace the global variable `searching' that was equal to TRUE when 
	searching for a forward matching event and FALSE when reading a request, 
	by a enum that is equal to `searching' when searching for a forward 
	matching event, `reading_request' when reading a request and `collecting'
	when processing a `collect' request.

	initialize_ptr(), filter_ptr(), send_collect_result_ptr() are the 3 
	pointers that points to the predicates initialize/1, filter/12 and 
	send_collect_result/2 that are defined in collect.m.


Opium-M/source/collect.op:
	The collect scenario that provides the primitives needed to run
	a collect request from opium-M.


Opium-M/source/collect.in:
	File that is used to generate collect.m (together with the file
	provided by the user that contains the definition of collected_type, 
	initialize/1 and filter/3). 


Index: browser/browser_library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/browser_library.m,v
retrieving revision 1.5
diff -u -r1.5 browser_library.m
--- browser_library.m	1999/08/20 06:47:23	1.5
+++ browser_library.m	1999/10/27 13:29:00
@@ -16,6 +16,7 @@
 :- import_module debugger_interface.
 :- import_module declarative_debugger, declarative_oracle, declarative_user.
 :- import_module interactive_query, dl, name_mangle.
+:- import_module collect_lib.
 
 % See library/library.m for why we implement this predicate this way.
 
Index: browser/collect_lib.m
===================================================================
RCS file: collect_lib.m
diff -N collect_lib.m
--- /dev/null	Wed May 28 10:49:58 1997
+++ collect_lib.m	Wed Oct 27 23:29:00 1999
@@ -0,0 +1,121 @@
+%-----------------------------------------------------------------------------%
+% Copyright (C) 1999 The University of Melbourne.
+% This file may only be copied under the terms of the GNU Library General
+% Public License - see the file COPYING.LIB in the Mercury distribution.
+%-----------------------------------------------------------------------------%
+% File: collect_lib.m
+% Author: jahier
+% Purpose:
+%	This module defines functions that are needed to implement the 
+%	`collect' primitive.
+%
+% 	`collect' collects runtime information from Mercury program executions.
+% 	It is intended to let users easily implement their own monitors with 
+% 	acceptable performances. 
+%
+%	To use it, users just need to define 4 things in a file, using the
+%	Mercury syntax:
+%		1) a `collected_type' which is the type of the collecting 
+%		   variable that will contain the result of the monitoring
+%		   activity.
+%		2) The predicate initialize/1 which initializes this 
+%		   collecting variable. initialize/1 should have the
+%		   following declarations:
+%			:- pred initialize(collected_type).
+%			:- mode initialize(out) is det.
+%		3) the predicate filter/3 which updates it at each execution 
+%		   event. filter/3 should have the following declarations:
+%			:- pred filter(event, collected_type, collected_type).
+%			:- mode filter(in, di, uo) is det.
+%		4) and eventually the mode definition of the second and the 
+%		   third arguments of filter/3: `acc_in' and `acc_out'. Those
+%		   mode have `di' and `uo' respectively as default values.
+%
+% 	Then, this file is used to generate the Mercury module `collect.m',
+% 	which is compiled and dynamically linked with the current execution.
+% 	When a `collect' request is made from the external debugger, a variable
+% 	of type collected_type is first initialized (with initialize/1) and
+% 	then updated (with filter/3) for all the events of the remaining
+% 	execution. When the end of the execution is reached, the last value of
+% 	the collecting variable is send to the debugger.
+
+:- module collect_lib.
+:- interface.
+:- import_module io, char.
+
+% dynamically link the collect module; 
+:- pred link_collect(c_pointer, c_pointer, c_pointer, c_pointer, char,
+	io__state, io__state).
+:- mode link_collect(out, out, out, out, out, di, uo) is det.
+
+%------------------------------------------------------------------------------%
+:- implementation.
+:- import_module int, list, std_util, io, char.
+:- import_module name_mangle, dl.
+
+:- pragma export(link_collect(out, out, out, out, out, di, uo), 
+	"ML_DI_link_collect").
+
+% We need Handle to be able to close the shared object (dlclose) later on.
+% When the link failed, we output NULL pointers instead of maybe pointers
+% for performance reasons; indeed, filter will be called at every events
+% so we don't want to pay the price of the maybe variable de-construction
+% at each event.
+link_collect(Filter, Initialize, SendResult, HandlePtr, Result) -->
+	%
+	% Link in the object code for the module `collect' from
+	% the file `collect.so'.
+	%
+	dl__open("./collect.so", lazy, local, MaybeHandle),
+	(	
+		{ MaybeHandle = error(Msg) },
+		print("dlopen failed: "), print(Msg), nl,
+		{ set_to_null_pointer(Initialize) },
+		{ set_to_null_pointer(Filter) },
+		{ set_to_null_pointer(SendResult) },
+		{ set_to_null_pointer(HandlePtr) },
+		{ Result = 'n' }
+	;
+		{ MaybeHandle = ok(Handle) },
+		%
+		% Look up the address of the first mode (mode number 0)
+		% of the predicates initialize/1 and filter/14  in the 
+		% module collect.
+		%
+		dl__sym(Handle, "Collect_initialize", MaybeInitialize),
+		dl__sym(Handle, "Collect_filter", MaybeFilter),
+		dl__sym(Handle, "Collect_send_collect_result", MaybeSendResult),
+		(
+			{ MaybeInitialize = ok(Initialize0) },
+			{ MaybeFilter = ok(Filter0) },
+			{ MaybeSendResult = ok(SendResult0) }
+		->
+			{ Result = 'y' },
+			{ Initialize = Initialize0 },
+			{ Filter = Filter0 },
+			{ SendResult = SendResult0 }
+		;
+			{ set_to_null_pointer(Initialize) },
+			{ set_to_null_pointer(Filter) },
+			{ set_to_null_pointer(SendResult) },
+			{ Result = 'n' }
+		),
+		{ Handle = handle(HandlePtr) }
+	).
+
+:- pred set_to_null_pointer(c_pointer::out) is det.
+:- pragma c_code(set_to_null_pointer(Pointer::out),
+		[will_not_call_mercury, thread_safe],
+		"(Pointer = (Word) NULL)").
+ 
+
+:- type io_pred == pred(io__state, io__state).
+:- inst io_pred == (pred(di, uo) is det).
+
+:- func inst_cast(io_pred) = io_pred.
+:- mode inst_cast(in) = out(io_pred) is det.
+
+:- pragma c_code(inst_cast(X::in) = (Y::out(io_pred)),
+	[will_not_call_mercury, thread_safe], "Y = X").
+
+
Index: browser/debugger_interface.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/debugger_interface.m,v
retrieving revision 1.12
diff -u -r1.12 debugger_interface.m
--- debugger_interface.m	1999/10/20 14:06:51	1.12
+++ debugger_interface.m	1999/10/27 13:29:03
@@ -25,7 +25,7 @@
 %	ML_DI_found_match_user
 %	ML_DI_found_match_comp
 %	ML_DI_read_request_from_socket
-% These are used by runtime/mercury_trace_external.c.
+% These are used by trace/mercury_trace_external.c.
 
 :- pred dummy_pred_to_avoid_warning_about_nothing_exported is det.
 
@@ -175,6 +175,14 @@
 	;	mmc_options(options)
 			% to call the term browser
 	;	browse(string)
+			% dynamically link the collect module with the 
+			% current execution
+	;	link_collect
+			% execute the collect command
+	;	collect
+			% retrieve the grade the current execution has been 
+			% compiled with
+	;	current_grade
 	.
 
 :- type event_number == int.
@@ -264,7 +272,15 @@
 	;	det(string)
 	;	end_stack
 	% responses to stack_regs
-	;	stack_regs(int, int, int).
+	;	stack_regs(int, int, int)
+	% responses to link_collect
+	;	link_collect_succeeded
+	;	link_collect_failed
+	% responses to collect
+	;	collect_linked
+	;	collect_not_linked
+	% responses to current_grade
+	;	grade(string).
 
 
 %-----------------------------------------------------------------------------%
@@ -639,6 +655,9 @@
 classify_request(io_query(_),15).
 classify_request(mmc_options(_),16).
 classify_request(browse(_),17).
+classify_request(link_collect,18).
+classify_request(collect,19).
+classify_request(current_grade,20).
 
 
 %-----------------------------------------------------------------------------%
Index: browser/dl.m
===================================================================
RCS file: /home/mercury1/repository/mercury/browser/dl.m,v
retrieving revision 1.2
diff -u -r1.2 dl.m
--- dl.m	1999/04/16 06:04:08	1.2
+++ dl.m	1999/10/27 13:29:03
@@ -24,6 +24,7 @@
 :- type handle.
 :- type result(T) ---> ok(T) ; error(string).
 :- type result ---> ok ; error(string).
+:- type handle ---> handle(c_pointer).
 
 % interface to the C function dlopen()
 :- pred dl__open(string::in, (mode)::in, scope::in, dl__result(handle)::out,
@@ -62,8 +63,6 @@
 	#include <dlfcn.h>
 #endif
 ").
-
-:- type handle ---> handle(c_pointer).
 
 :- pred is_null(c_pointer::in) is semidet.
 :- pragma c_code(is_null(Pointer::in),
Index: trace/mercury_trace_external.c
===================================================================
RCS file: /home/mercury1/repository/mercury/trace/mercury_trace_external.c,v
retrieving revision 1.25
diff -u -r1.25 mercury_trace_external.c
--- mercury_trace_external.c	1999/10/24 09:57:25	1.25
+++ mercury_trace_external.c	1999/10/27 13:29:09
@@ -30,6 +30,7 @@
 #include "mercury_trace_vars.h"
 
 #include "debugger_interface.h"
+#include "collect_lib.h"
 #include "std_util.h"
 
 #include <stdio.h>
@@ -42,6 +43,8 @@
 #include <arpa/inet.h>
 #include <netinet/in.h>
 #include <netdb.h>
+#include <dlfcn.h>
+#include <stdlib.h>
 
 /*
 ** This type must match the definition of classify_request in
@@ -76,7 +79,11 @@
 				 = 15,/* wait for a io interactive query      */
 	MR_REQUEST_MMC_OPTIONS	 = 16,/* pass down new options to compile
 					 queries with			      */
-	MR_REQUEST_BROWSE	 = 17 /* call the term browser	              */
+	MR_REQUEST_BROWSE	 = 17,/* call the term browser	              */
+	MR_REQUEST_LINK_COLLECT	 = 18,/* dynamically link the collect module  */
+	MR_REQUEST_COLLECT	 = 19,/* collecting monitoring informations   */
+	MR_REQUEST_CURRENT_GRADE = 20 /* retrieving the grade of the current
+					 program has been compiled with       */
 
 } MR_debugger_request_type;
 
@@ -84,6 +91,17 @@
 MercuryFile MR_debugger_socket_out;
 
 /*
+** Type of a local variable that indicates in which mode the external 
+** debugger is. When the external debugger is in mode:
+** - `searching', it tries to find an event that matches a forward move request,
+** - `reading_request', it reads a new request on the socket,
+** - `collecting', it is collecting information (after a `collect' request).
+*/
+typedef enum {
+	searching, reading_request, collecting
+} MR_external_debugger_mode_type;
+
+/*
 ** Use a GNU C extension to enforce static type checking
 ** for printf-style functions. 
 ** (See the "Function attributes" section of "C extensions"
@@ -271,9 +289,10 @@
 				"invalid port");
 		}
 
-		fprintf(stderr, "Mercury runtime: host = %s, port = %d\n",
+		if (MR_debug_socket) {
+			fprintf(stderr, "Mercury runtime: host = %s, port = %d\n",
 				hostname, port);
-	
+		}
 		inet_address.sin_family = AF_INET;
 		inet_address.sin_addr.s_addr = host_addr;
 		inet_address.sin_port = htons(port);
@@ -378,8 +397,17 @@
 Code *
 MR_trace_event_external(MR_Trace_Cmd_Info *cmd, MR_Event_Info *event_info)
 {
-	static bool	searching = FALSE;
+	static MR_external_debugger_mode_type 
+			external_debugger_mode = reading_request;
 	static Word	search_data;
+	static Word	collecting_variable;
+	static Word	(*initialize_ptr)(Word *) = NULL;
+	static Word    	(*filter_ptr)(Integer, Integer, Integer, MR_Trace_Port,
+				MR_PredFunc, String, String, String, Integer,
+				Integer, Integer, String, Word, Word *) = NULL;
+	static Word	(*send_collect_result_ptr)(Word, Word);
+	static Word    	*handle = NULL;
+	static bool    	collect_linked = FALSE;
 	Integer		debugger_request_type;
 	Integer		live_var_number;
 	Word		debugger_request;
@@ -403,14 +431,14 @@
 
 	MR_trace_enabled = FALSE;
 
-        /*
-        ** These globals can be overwritten when we call Mercury code,
-        ** such as the code in browser/debugger_interface.m.
+	/*
+	** These globals can be overwritten when we call Mercury code,
+	** such as the code in browser/debugger_interface.m.
 	** We therefore save them here and restore them before
 	** exiting from this function.  However, we store the
-        ** saved values in a structure that we pass to MR_trace_debug_cmd,
-        ** to allow them to be modified by MR_trace_retry().
-        */
+	** saved values in a structure that we pass to MR_trace_debug_cmd,
+	** to allow them to be modified by MR_trace_retry().
+	*/
 	event_details.MR_call_seqno = MR_trace_call_seqno;
 	event_details.MR_call_depth = MR_trace_call_depth;
 	event_details.MR_event_number = MR_trace_event_number;
@@ -424,18 +452,72 @@
 	MR_trace_init_point_vars(event_info->MR_event_sll,
 		event_info->MR_saved_regs);
 
-	if (searching) {
-		/* XXX should also pass registers here,
-		   since they're needed for checking for matches with the
-		   arguments */
-		if (MR_found_match(layout, port, seqno, depth,
-			/* XXX registers */ path, search_data))
-		{
-			MR_send_message_to_socket("forward_move_match_found");
-			searching = FALSE;
-		} else {
-			goto done;
-		}
+
+	switch((MR_external_debugger_mode_type) external_debugger_mode) {
+		case searching:
+			/* 
+			** XXX should also pass registers here, since they're 
+			** needed for checking for matches with the arguments 
+			*/
+			if (MR_found_match(layout, port, seqno, depth,
+				/* XXX registers, */ path, search_data))
+			{
+				MR_send_message_to_socket(
+					"forward_move_match_found");
+				external_debugger_mode = reading_request;
+			} else {
+				goto done;
+			}
+			break;
+
+		case collecting:
+			if (seqno == 1 && port == MR_PORT_EXIT) {
+				/* The end of the execution is reached */
+				(*send_collect_result_ptr)(
+						collecting_variable, 
+						(Word) &MR_debugger_socket_out);
+				#if defined(HAVE_DLFCN_H)&&defined(HAVE_DLCLOSE)
+					dlclose((void *)handle);
+				#endif
+			} else {
+				/* 
+				** XXX Add a another request that takes 
+				** arguments into account. We need two kinds 
+				** of request in order to not penalize the 
+				** performance of collect in the cases where 
+				** arguments are not used.
+				**  
+				** arguments = MR_make_var_list(layout, 
+				**	saved_regs);
+				*/
+				(*filter_ptr)(
+			MR_trace_event_number,
+			seqno,
+			depth,
+			port,
+			layout->MR_sll_entry->MR_sle_user.MR_user_pred_or_func,
+			(String)
+			layout->MR_sll_entry->MR_sle_user.MR_user_decl_module,
+			(String)
+			layout->MR_sll_entry->MR_sle_user.MR_user_def_module,
+			(String)
+			layout->MR_sll_entry->MR_sle_user.MR_user_name,
+			layout->MR_sll_entry->MR_sle_user.MR_user_arity,
+			layout->MR_sll_entry->MR_sle_user.MR_user_mode,
+			layout->MR_sll_entry->MR_sle_detism,
+			(String) path,
+			(Word) collecting_variable,
+			&collecting_variable);
+				goto done;
+			}
+			
+			break;
+
+		case reading_request:
+			break;
+
+		default:
+	       		fatal_error("Software error in the debugger.\n");
 	}
 
 	/* loop to process requests read from the debugger socket */
@@ -444,8 +526,7 @@
 			&debugger_request, &debugger_request_type);
 		switch((int) debugger_request_type) {
 			case MR_REQUEST_ABORT_PROG:
-				fatal_error("aborting the execution on "
-					"user request");
+				exit(EXIT_SUCCESS);
 
 			case MR_REQUEST_FORWARD_MOVE:
 				if (MR_debug_socket) {
@@ -453,7 +534,7 @@
 						"FORWARD_MOVE\n");
 				}
 				search_data = debugger_request;
-			        searching = TRUE;
+			        external_debugger_mode = searching;
 				goto done;
 
 			case MR_REQUEST_CURRENT_LIVE_VAR_NAMES:
@@ -646,6 +727,89 @@
 				cmd->MR_trace_cmd = MR_CMD_TO_END;
 				goto done;
 
+			case MR_REQUEST_LINK_COLLECT:
+			  {
+			        Char	result;
+
+				if (MR_debug_socket) {
+					fprintf(stderr, "\nMercury runtime: "
+						"REQUEST_LINK_COLLECT\n");
+				}
+				MR_TRACE_CALL_MERCURY(
+					ML_DI_link_collect(
+					    (Word *) &filter_ptr,
+					    (Word *) &initialize_ptr,
+					    (Word *) &send_collect_result_ptr,
+					    (Word *) &handle,
+					    (Char *) &result
+					    ));
+				collect_linked = (result == 'y');
+				if (collect_linked) {
+					MR_send_message_to_socket(
+						"link_collect_succeeded");
+				} else {
+					MR_send_message_to_socket(
+						"link_collect_failed");
+				}
+				break;
+			  }
+			case MR_REQUEST_COLLECT:
+			  {
+				static char *MERCURY_OPTIONS;
+
+				if (MR_debug_socket) {
+					fprintf(stderr, "\nMercury runtime: "
+						"REQUEST_COLLECT\n");
+				}
+				if (collect_linked) {
+					MR_send_message_to_socket(
+						"collect_linked");
+					external_debugger_mode = collecting;
+					MR_TRACE_CALL_MERCURY(
+					  (*initialize_ptr)(&collecting_variable));
+
+					/*
+					** In order to perform the collect from
+					** the current event, we need to call 
+					** filter once here.
+					*/
+					(*filter_ptr)(
+			MR_trace_event_number,
+			seqno,
+			depth,
+			port,
+			layout->MR_sll_entry->MR_sle_user.MR_user_pred_or_func,
+			(String)
+			layout->MR_sll_entry->MR_sle_user.MR_user_decl_module,
+			(String)
+			layout->MR_sll_entry->MR_sle_user.MR_user_def_module,
+			(String)
+			layout->MR_sll_entry->MR_sle_user.MR_user_name,
+			layout->MR_sll_entry->MR_sle_user.MR_user_arity,
+			layout->MR_sll_entry->MR_sle_user.MR_user_mode,
+			layout->MR_sll_entry->MR_sle_detism,
+			(String) path,
+			(Word) collecting_variable,
+			&collecting_variable);
+					goto done;
+				} else {
+					MR_send_message_to_socket(
+						"collect_not_linked");
+					break;
+				}
+			  }
+
+			case MR_REQUEST_CURRENT_GRADE:
+			  {
+				if (MR_debug_socket) {
+					fprintf(stderr, "\nMercury runtime: "
+						"REQUEST_CURRENT_GRADE\n");
+				}
+				MR_send_message_to_socket_format(
+						"grade(\"%s\").\n", 
+						MR_GRADE_OPT);
+				break;
+			  }
 			default:
 				fatal_error("unexpected request read from "
 					"debugger socket");



-------------- next part --------------
%------------------------------------------------------------------------------%
% Copyright (C) 1999 IRISA/INRIA.
% 
% Author : Erwan Jahier
% File   : collect.op
%
% This file implements the collect command.
%
% There are several things to do in order to be able to execute a 
% collect/1 command:
% 1) create a file that will that contain the definition of collected_type, 
%	initialize/1 and filter/3,
% 2) generate `collect.m' from this file (generate_collect/1),
% 3) compile collect.m (compile_collect/0),
% 4) dynamically link it with the current execution (dyn_link_collect/0).
% 5) run the command (run_command/1).

opium_scenario(
	name		: collect,
	files		: [collect],
	scenarios	: [],
	message		:
"Scenario that implements the collect/2 monitoring command that collects \
runtime information from Mercury program executions. It is intended to let \
users easily implement their own monitors with acceptable performances.\n\
\n\
To use it, users just need to define 4 things in a file, using the Mercury \
syntax:\n\
	(1) a `collected_type' which is the type of the collecting  \n\
	   variable that will contain the result of the monitoring\n\
	   activity.\n\
	(2) The predicate initialize/1 which initializes this \n\
	   collecting variable. initialize/1 have the \n\
	   following declarations:\n\
		:- pred initialize(collected_type).\n\
		:- mode initialize(out) is det.\n\
	(3) the predicate filter/3 which updates it at each execution \n\
	   event. filter/3 should have the following declarations:\n\
		:- pred filter(event, collected_type, collected_type).\n\
		:- mode filter(in, acc_in, acc_out) is det.\n\
	   where `acc_in' and `acc_out' have `in' and `out' respectively\n\
	   as default values.\n\
	(4) and optionally the mode definition of `acc_in' and `acc_out'\n\
	   in one want to override their default values.\n\
\n\
Then, this file is used to generate the Mercury module `collect.m', \
which is compiled and dynamically linked with the current execution. \
When a `collect' request is made from the external debugger, a variable \
of type collected_type is first initialized (with initialize/1) and \
then updated (with filter/3) for all the events of the remaining \
execution. When the end of the execution is reached, the last value of \
the collecting variable is send to Opium-M.\n\
\n\
collect/2 can be specified by the following pseudo Opium-M code: \n\
`	collect_spec(File, Result) :-\n\
		generate_collect(File),\n\
		compile_collect,\n\
		dyn_link_collect,\n\
		get_event_list(EventList),\n\
		initialize(Start),\n\
		foldl(filter, EventList, Start, Result).\n\
'\n\
where: \n\
 *) generate_collect/1 generates from `File' the Mercury module \
`collect.m'; \n\
 *) compile_collect/0 compiles `collect.m' (generating `File.so'); \n\
 *) dynamically_link_collect/0 links the corresponding object file \n\
(`File.so') with the current program execution; \n\
 *) get_event_list/1 collects in a list all the events from the current \
event until the end of the execution; \n\
 *) foldl/4 is the classical fold predicate operating left-to-right. \n\
 \n\
Hence, collect/2 does the same thing as collect_spec/2 except it operates \
on the fly without creating any list of events."
	).


%------------------------------------------------------------------------------%
opium_command(
	name		: collect,
	arg_list	: [File, Result],
	arg_type_list	: [is_atom_or_string, is_atom_or_var],
	abbrev		: _,
	interface	: button,
	command_type	: opium,
	implementation	: collect_Op,
	parameters	: [],
	message		:
"If File contains the implementation of the Mercury predicates initialize/1 \
and filter/3, collect(File, Result) calls filter/3 with each event of the \
execution and an accumulator initialized by initialize/1, and returns the \
final value in Result.\n\
\n\
Here is an example of a simple monitor that counts calls.\n\
If a file `count_call' contains the following statements:\n\
`\n\
	:- import_module int.\n\
	:- type collected_type == int.\n\
\n\
	initialize(0).\n\
\n\
	filter(Event, AccIn, AccOut) :-\n\
		( port(Event) = call ->\n\
			AccOut = AccIn + 1\n\
		;\n\
			AccOut = AccIn\n\
		).\n\
'\n\
Then the command `collect(count_call, Result)' will unify Result with the \
number of calls that occurs during the program execution.\
"
	).

collect_Op(File, Result) :-
	check_a_program_is_running("collect/2"),
	(
		% File might be an atom or a string.
		string(File),
		append_strings(File, ".so", File_so),
		!
	;
		atom_string(File, FileStr),
		append_strings(FileStr, ".so", File_so)
	),
	( 
		% We don't generate again collect.so if the collect input 
		% file has already been collected and if it has not been 
		% modified.
		get_file_info(File, mtime, Time),
		get_file_info(File_so, mtime, Time_so),
		Time < Time_so,
		concat_string(["cp ", File_so, " collect.so"], Cmd1),
		sh(Cmd1),
		!
	;
		generate_collect(File),
		compile_collect,
		concat_string(["cp collect.so ", File_so], Cmd2),
		sh(Cmd2)
	),
	dyn_link_collect,
	run_collect(Result).


%------------------------------------------------------------------------------%
opium_primitive(
	name		: compile_collect,
	arg_list	: [],
	arg_type_list	: [],
	abbrev		: _,
	implementation	: compile_collect_Op,
	message		:
"Compile the module `collect.m'."
	).

compile_collect_Op :-
	write("Compiling collect.m...\n"),
	sh("rm -f collect.so  collect.o"),
	current_grade(Grade),
	concat_string([
		"mmc --grade ", 
		Grade,
		" -O6",
		" -c --pic-reg collect.m"], Command1),
	sh(Command1), 
	print(Command1), nl,
	concat_string([
		"ml --grade ", 
		Grade, 
		" --make-shared-lib ",
		"--pic-reg -o collect.so collect.o"], Command2),
	sh(Command2), 
	print(Command2), nl,
	exists("collect.so"),
	!,
	opium_write_debug("collect.m has been compiled successfully.\n").

compile_collect_Op :-
	write("\n\n***** Compilation of module collect failed.\n"),
	abort.

%------------------------------------------------------------------------------%
opium_primitive(
	name		: current_grade,
	arg_list	: [Grade],
	arg_type_list	: [var],
	abbrev		: _,
	implementation	: current_grade_Op,
	message		:
"Retrieves the grade the current program execution has been compiled with."
	).

current_grade_Op(Grade) :-
	check_a_program_is_running("current_grade/1"),
	send_message_to_socket(current_grade),
	read_message_from_socket(grade(Grade)).


%------------------------------------------------------------------------------%
opium_primitive(
	name		: generate_collect,
	arg_list	: [File],
	arg_type_list	: [is_atom_or_var],
	abbrev		: _,
	implementation	: generate_collect_Op,
	message		:
"Generates a Mercury module named `collect.m' from file File; File should \
contain the definition of the accumulator type (collected_type), \
initialize/1 and filter/3 predicates."
	).

generate_collect_Op(File) :-
	sh("rm -f collect.m"),
	open("collect.m", write, collect),
	getenv("MERCURY_OPIUM_DIR", OpiumDir),
	append_strings(OpiumDir, "/source/collect.in", CollectIn),
	open(CollectIn, read, collect_in),
	open(File, read, collect_body),
	read_string(collect_in, "", _, In),
	read_string(collect_body, "", _, Body),
	write(collect, In),
	write(collect, ""),
	write(collect, "\n\n%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n\n"),
	( 
		is_there_any_mode_declaration(File)
	;
		% Add a mode definition of `acc_in' and `acc_out' if not
		% present in File.
		write(collect, ":- mode acc_in :: in.\n"),
		write(collect, ":- mode acc_out :: out.\n\n")
	),
	write(collect, Body),
	close(collect),
	close(collect_in).

	
% Check if there is a mode definition of `acc_in' and `acc_out' in the 
% file `File'. Those are to let users specify di and uo as modes for filter.
is_there_any_mode_declaration(File) :-
	open(File, read, S),
	(
		is_there_any_mode_declaration_do(S),
		close(S), 
		!
	;
		close(S),
		fail
	).

is_there_any_mode_declaration_do(S) :-
	read_mercury_term(S, Term),
	(
		Term =.. [':-', ModeDecl|_],
		term_string(ModeDecl, ModeDeclStr),
		(
			substring(ModeDeclStr, "mode ::(acc_in",_),
			!
		;
			substring(ModeDeclStr, "mode ::(acc_out",_)
		)
	;
		Term = end_of_file,
		!,
		fail
	;
		is_there_any_mode_declaration_do(S)
	).


%------------------------------------------------------------------------------%
opium_primitive(
	name		: dyn_link_collect,
	arg_list	: [],
	arg_type_list	: [],
	abbrev		: _,
	implementation	: dyn_link_collect_Op,
	message		:
"Dynamically links the collect module with the currently run program."
	).

dyn_link_collect_Op :-
	check_a_program_is_running("dyn_link_collect/0"),
	(
		exists("collect.so"),
		!
	;
		exists("collect.m"),
		compile_collect,
		exists("collect.so"),
		!
	;
		write("Can't find `collect.m'; you should "),
		write("use generate_collect/1 primitive before.\n"),
		fail
	),
	send_message_to_socket(link_collect),
	read_message_from_socket(Result),
	( Result = link_collect_succeeded ->
		opium_write_debug("collect.so has been linked successfully.\n")
	;
		print("**** collect.so has not been linked.\n"),
		abort
	).


%------------------------------------------------------------------------------%
opium_primitive(
	name		: run_collect,
	arg_list	: [Result],
	arg_type_list	: [var],
	abbrev		: _,
	implementation	: run_collect_Op,
	message		:
"Executes the collect command provided that collect.m has been correctly, \
generated, compiled and dynamically linked with the current program \
execution."
	).

run_collect_Op(Result) :-
	check_a_program_is_running("run_collect/1"),
	send_message_to_socket(collect),
	read_message_from_socket(CollectLinked),
	( 
		CollectLinked == collect_linked,
		read_message_from_socket(Msg),
		( 
			Msg = collected(Result),
			!
		;
			print("unexpected message from the Mercury "),
			printf("process: %w\n", [Result]),
			end_connection,
			abort
		),
		!
	;
		CollectLinked == collect_not_linked,
		print("You can't call run_collect/1; "),
		print("The collect module has not been linked with "),
		print("the current execution (cf dyn_link_collect/0).\n"),
		!,
		fail
	;
		write("unexpected message from the Mercury "),
		printf("process: %w\n", [CollectLinked]),
		end_connection,
		abort
	).


check_a_program_is_running(CommandStr) :-
	(
		getval(state_of_opium, State),
		State = running,
		!
	;
		printf("You can't call %w; no program is running.\n", 
			[CommandStr]),
		fail
	).
-------------- next part --------------
:- module collect.

:- interface.

:- type collected_type.

:- pred initialize(collected_type).
:- mode initialize(out) is det.


:- pred filter(event_number, call_number, depth_number, trace_port_type,
        pred_or_func, declarated_module_name, defined_module_name, proc_name,
        arity, mode_number, determinism, goal_path_string, collected_type,
        collected_type).

:- mode filter(in, in, in, in, in, in, in, in, in, in, in, in, acc_in, acc_out)
        is det.

:- pred send_collect_result(collected_type, io__output_stream, io__state,
	io__state).  
:- mode send_collect_result(in, in, di, uo) is det.

%------------------------------------------------------------------------------%
:- implementation.

:- pragma export(initialize(out), "Collect_initialize").

:- pragma export(filter(in, in, in, in, in, in, in, in, in, in, in, in, 
	acc_in, acc_out), "Collect_filter").

:- pragma export(send_collect_result(in, in, di, uo), 
	"Collect_send_collect_result").

:- import_module int, io.

:- type event_number == int.
:- type call_number == int.
:- type depth_number == int.

% The stuff defined below is similar to types goal_path and trace_port
% defined in modules compiler/hlds_goal.m and compiler/trace.m.
% This enumeration must be EXACTLY the same as the MR_trace_port enum in
% runtime/mercury_trace_base.h, and in the same order, since the code
% assumes the representation is the same.
:- type trace_port_type
	--->	call
	;	exit
	;	redo
	;	fail
	;	ite_cond
	;	ite_then
	;	ite_else
	;	neg_enter
	;	neg_success
	;	neg_failure
	;	disj
	;	switch
	;	nondet_pragma_first
	;	nondet_pragma_later
	;	exception
	.

% This enumeration must be EXACTLY the same as the MR_PredFunc enum in
% runtime/mercury_stack_layout.h, and in the same order, since the code
% assumes the representation is the same.
:- type pred_or_func
	--->	predicate
	;	function.

:- type declarated_module_name == string.
:- type defined_module_name == string.
:- type proc_name == string.

:- type arity == int.
:- type mode_number == int.

% encoded as specified in ../runtime/mercury_stack_layout.h
% and ../compiler/stack_layout.m.
:- type determinism == int. 
	
:- type goal_path_string == string.

:- type procedure ---> 
	proc(pred_or_func, declarated_module_name, proc_name, arity, mode_number).

:- type event ---> 
	event(
		event_number,
		call_number,
		depth_number,
		trace_port_type,
		pred_or_func,
		declarated_module_name,
		defined_module_name,	
		proc_name,
		arity,
		mode_number,
		determinism,
		goal_path_string).

:- func chrono(event::in) = (event_number::out) is det.
:- func call(event::in) = (call_number::out) is det.
:- func depth(event::in) = (depth_number::out) is det.
:- func port(event::in) = (trace_port_type::out) is det.
:- func proc_type(event::in) = (pred_or_func::out) is det.
:- func decl_module(event::in) = (declarated_module_name::out) is det.
:- func def_module(event::in) = (defined_module_name::out) is det.
:- func proc_name(event::in) = (proc_name::out) is det.
:- func proc_arity(event::in) = (arity::out) is det.
:- func proc_mode_number(event::in) = (mode_number::out) is det.
:- func determinism(event::in) = (determinism::out) is det.
:- func goal_path(event::in) = (goal_path_string::out) is det.


% XXX check if those pragma really improve the efficiency.
:- pragma inline(chrono/1).
:- pragma inline(call/1).
:- pragma inline(depth/1).
:- pragma inline(port/1).
:- pragma inline(proc_type/1).
:- pragma inline(decl_module/1).
:- pragma inline(def_module/1).
:- pragma inline(proc_name/1).
:- pragma inline(proc_arity/1).
:- pragma inline(proc_mode_number/1).
:- pragma inline(determinism/1).
:- pragma inline(goal_path/1).

chrono(Event) = Chrono :-
	Event = event(Chrono, _, _, _, _, _, _, _, _, _, _, _).

call(Event) = Call :-
	Event = event(_, Call, _, _, _, _, _, _, _, _, _, _).

depth(Event) = Depth :-
	Event = event(_, _, Depth, _, _, _, _, _, _, _, _, _).

port(Event) = Port :-
	Event = event(_, _, _, Port, _, _, _, _, _, _, _, _).

proc_type(Event) = ProcType :-
	Event = event(_, _, _, _, ProcType, _, _, _, _, _, _, _).

decl_module(Event) = DeclModule :-
	Event = event(_, _, _, _, _, DeclModule, _, _, _, _, _, _).

def_module(Event) = DefModule :-
	Event = event(_, _, _, _, _, _, DefModule, _, _, _, _, _).

proc_name(Event) = ProcName :-
	Event = event(_, _, _, _, _, _, _, ProcName, _, _, _, _).

proc_arity(Event) = ProcArity :-
	Event = event(_, _, _, _, _, _, _, _, ProcArity, _, _, _).

proc_mode_number(Event) = ModeNumber :-
	Event = event(_, _, _, _, _, _, _, _, _, ModeNumber, _, _).

% XXX problems caused by the precedence of the `:'.
% proc(Event) = (ProcType-DeclModule:Name/Arity-ModeNum) :-
% 	Event = event(_, _, _, ProcType, DeclModule, _, _, Name, Arity,
%			ModeNum, _, _).

determinism(Event) = Determinism :-
	Event = event(_, _, _, _, _, _, _, _, _, _, Determinism, _).

goal_path(Event) = GoalPath :-
	Event = event(_, _, _, _, _, _, _, _, _, _, _, GoalPath).


filter(EventNumber, CallNumber, DepthNumber, Port, PredOrFunc, DeclModuleName,
		DefModuleName, PredName, Arity, ModeNum, Determinism, Path,
		AccIn, AccOut) :- 
	filter(event(EventNumber, CallNumber, DepthNumber, Port, PredOrFunc,
		DeclModuleName, DefModuleName, PredName, Arity, ModeNum,
		Determinism, Path), AccIn, AccOut).


% This predicate is called when the end of the execution is reached after a
% `collect' request in the external debugger.
send_collect_result(Result, OutputStream) -->
	{ Collected = collected(Result) },
	io__write(OutputStream, Collected),
	io__print(OutputStream, ".\n"),
	io__flush_output(OutputStream).

:- type collect_result --->
	collected(collected_type).

:- pred filter(event, collected_type, collected_type).
:- mode filter(in, acc_in, acc_out) is det.
:- pragma inline(filter/3).
-------------- next part --------------
R1.


More information about the developers mailing list