mercury/extras/morphine/source/collect.op

%------------------------------------------------------------------------------%
% Copyright (C) 1999-2001 INRIA/INSA de Rennes/IFSIC.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file License in the Morphine distribution.
% 
% 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/4',
% 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/2').
% 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) `accumulator_type' which is the type of the accumulator. \n\
	(2) A predicate `initialize/1' which initializes this collecting \n\
	   variable. Predicate `initialize/1' should respect the \n\
	   following declarations:\n\
		:- pred initialize(accumulator_type).\n\
		:- mode initialize(out) is det.\n\
	(3) A predicate `filter/4' which updates the collecting variable at \n\
	   each execution event. The fourth argument of `filter/4' \n\
	   indicates whether to stop collecting. If this variable is set to \n\
	   `stop', the collect process stops; if it is set to `continue', it \n\
	   continues. If this variable is always set to `continue', the \n\
	   collecting processes until the last event is reached. `filter/4' \n\
	   should respect the following declarations:\n\
		:- pred filter(event, accumulator_type, accumulator_type, \n\
			stop_or_continue).\n\
		:- mode filter(in, acc_in, acc_out, out) is det.\n\
	   where modes `acc\_in' and `acc\_out' are equivalent to\n\
	   `in' and `out' respectively by default.\n\
	(4) Optionally, a `post_process/2' function that lets one post-process\n\
  	    the final value of the accumulator. `post_process/2' should respect\n\
	    the following declarations:\n\
	        :- pred post_process(accumulator_type, collected_type).\n\
	        :- mode post_process(in, out) is det.\n\
	    If `collected_type' is different from the `accumulator_type', \n\
	    `collected_type' should also be defined; otherwise by default,\n\
	    `collected_type' is automatically defined as being the same type\n\
	    as `accumulator_type'.\n\
	(5) And optionally, a mode definition for `acc_in' and `acc_out'\n\
	   if one wants 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 `accumulator_type' is first initialized (with `initialize/1') and \
then updated (with `filter/4') for all the remaining events of the \
execution. When the fourth argument of `filter/4' is equal to `stop', or when \
the end of the execution is reached, the last value of \
the collecting variable is send to Morphine.\n\
\n\
The event type is defined as follows (for more details about the meaning of \
each event attributes, please refer to the morphine Reference Manual):\n\
\n\
:- type event ---> \n\
	event(\n\
		event_number,\n\
		call_number,\n\
		depth_number,\n\
		trace_port_type,\n\
		pred_or_func,\n\
		declarated_module_name,\n\
		defined_module_name,	\n\
		proc_name,\n\
		arity,\n\
		mode_number,\n\
		determinism,\n\
		goal_path_string,\n\
	        line_number).\n\
\n\
:- type event_number == int.\n\
:- type call_number == int.\n\
:- type depth_number == int.\n\
:- type trace_port_type\n\
	--->	call\n\
	;	exit\n\
	;	redo\n\
	;	fail\n\
	;	ite_cond\n\
	;	ite_then\n\
	;	ite_else\n\
	;	neg_enter\n\
	;	neg_success\n\
	;	neg_failure\n\
	;	disj\n\
	;	switch\n\
	;	nondet_pragma_first\n\
	;	nondet_pragma_later\n\
	;	exception.\n\
:- type pred_or_func\n\
	--->	predicate\n\
	;	function.\n\
:- type declarated_module_name == string.\n\
:- type defined_module_name == string.\n\
:- type proc_name == string.\n\
:- type arity == int.\n\
:- type mode_number == int.\n\
:- type determinism == int. \n\
:- type goal_path_string == string.\n\
:- type line_number == int.\n\
:- type procedure ---> proc(\n\
	pred_or_func, \n\
	declarated_module_name, \n\
	proc_name, \n\
	arity, \n\
	mode_number).\n\
:- type arguments == list(univ).\n\
\n\
Here are functions that eases the access to event attributes:\n\
\n\
:- func chrono(event::in) = (event_number::out) is det.\n\
:- func call(event::in) = (call_number::out) is det.\n\
:- func depth(event::in) = (depth_number::out) is det.\n\
:- func port(event::in) = (trace_port_type::out) is det.\n\
:- func proc_type(event::in) = (pred_or_func::out) is det.\n\
:- func decl_module(event::in) = (declarated_module_name::out) is det.\n\
:- func def_module(event::in) = (defined_module_name::out) is det.\n\
:- func proc_name(event::in) = (proc_name::out) is det.\n\
:- func proc_arity(event::in) = (arity::out) is det.\n\
:- func proc_mode_number(event::in) = (mode_number::out) is det.\n\
:- func proc(event::in) = (procedure::out) is det.\n\
:- func determinism(event::in) = (determinism::out) is det.\n\
:- func goal_path(event::in) = (goal_path_string::out) is det.\n\
:- func line_number(event::in) = (line_number::out) is det.\n\
:- func arguments(event::in) = (arguments::out) is det. (*)\n\
\n\
(*) To be able to retrieve arguments, you to need to have the opium parameter \n\
`collect_arg' set to yes (`man collect_arg.' for more details).\n\
\n\
Predicate `collect/2' can be seen as a `foldl/4' operator except that \
it does not take a list as argument but operates on the fly on a list \
of events; and we can stop the process at anytime thanks the fourth \
argument of `filter/4'."
).

%------------------------------------------------------------------------------%
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	: [collect_arg],
	message		:
"If  File  contains  the  implementation of  the  Mercury  predicates \
`initialize/1' and `filter/4',  `collect(File, Result)' calls `filter/4'  \
with each remaining event of the  current execution and an accumulator \
initialized by  `initialize/1', and returns the final  value in `Result'. \
The fourth argument of filter is  a flag that is set to `continue' or \
`stop'  depending if  you want  to  continue or  stop the  monitoring \
process; this  useful if one wants  to be able to  stop the monitoring \
process before the last event is reached.\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 accumulator_type == int.\n\
\n\
	initialize(0).\n\
\n\
	filter(Event, AccIn, AccOut, continue) :-\n\
		( port(Event) = call ->\n\
			AccOut = AccIn + 1\n\
		;\n\
			AccOut = AccIn\n\
		).\n\
'\n\
Then the goal `run(queens), collect(count_call, Result)' will unify `Result' \
with the number of calls occurring during the execution of `queens' program.\
You can also post-process the last value of the accumalator by defining \
post_process(accumulator_type::in, collected_type::out) predicate. If collected_type \
is different from accumulator_type, you should also define it. For example, \
you can post-process the final value of the `count_call' monitor by adding \
the following statements to `count_call' file: \n\
`\n\
	:- type collected_type == string.\n\
	post_process(Int, String) :-\n\
		if Int > 100 then \n\
	              String = \"More than 100 calls have been done\"\n\
		else\n\
	              String = \"Less than 101 calls have been done\"\n\
'\n\
"
	).

collect_Op(File, Result) :-
	check_a_program_is_running("collect/2"),
	(
		% File might be an atom or a string.
		string(File)
	->
		File = FileStr
	;
		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(FileStr, File_so),
	run_collect(Result).

%------------------------------------------------------------------------------%

opium_parameter(
	name		: collect_arg,
	arg_list	: [YesOrNo],
	arg_type_list	: [member([yes, no])],
	parameter_type	: single,
	default		: [no],
	commands	: [collect],
	message		: 
"Specifies whether or not it is possible to use `arguments/1' within \
`collect:filter/4'. If you do not use arguments, it is better to set this \
parameter to `no' since when arguments are very big, it might slow down \
the execution of collect a lot."
	).


%------------------------------------------------------------------------------%
opium_primitive(
	name		: compile_collect,
	arg_list	: [],
	arg_type_list	: [],
	abbrev		: _,
	implementation	: compile_collect_Op,
	message		:
"Compiles 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 --no-warn-det-decls-too-lax --grade ",
		Grade,
		" -O6",
		" -c collect.m"], Command1),
	print(Command1), nl,
	sh(Command1),
	exists("collect.o"),
	concat_string([
		"ml --grade ", 
		Grade, 
		" --make-shared-lib ",
		"-o collect.so collect.o"], Command2),
	print(Command2), nl,
	sh(Command2), 
	exists("collect.so"),
	!,
	morphine_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(response_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 `collected_type', `initialize/1', and `filter/4'."
	).

generate_collect_Op(File) :-
	sh("rm -f collect.m"),
	open("collect.m", write, collect),
	getenv("MERCURY_MORPHINE_DIR", MorphineDir),
	append_strings(MorphineDir, "/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_collected_type_defined(File)
	;
		% Add a definition for collected_type if necessary
	        write(collect, ":- type collected_type == accumulator_type.\n")
	),
	( 
		is_post_process_pred_defined(File)
	;
		% Add a definition for post_process/2 if necessary
	        write(collect, "post_process(Acc, Acc).\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")
	),


	% From the Mercury Reference manual:
	%   The `source_file' pragma and `#line' directives provide
 	%   support for preprocessors and other tools that generate
 	%   Mercury code. The tool can insert these directives into the
 	%   generated Mercury code to allow the Mercury compiler to
 	%   report diagnostics (error and warning messages) at the
 	%   original source code location, rather than at the location in
 	%   the automatically generated Mercury code.
	printf(collect, ":- pragma source_file(\"%w\").\n", [File]),
	write(collect, "#1\n"),
	write(collect, Body),
	close(collect),
	close(collect_in).

% Check if accumulator_type is defined. 
is_collected_type_defined(File) :-
	open(File, read, S),
	(
		is_collected_type_defined_do(S),
		close(S), 
		!
	;
		close(S),
		fail
	).

is_collected_type_defined_do(S) :-
	read_mercury_term(S, Term),
	term_string(Term, String),
	(
		append_strings(":- type(--->(collected_type", _,  String),
		!
	;
		append_strings(":- type(collected_type", _,  String),
		!
	;
		Term = end_of_file,
		!,
		fail
	;
		is_collected_type_defined_do(S)
	).

% Check if post_process is defined. 
is_post_process_pred_defined(File) :-
	open(File, read, S),
	(
		is_post_process_pred_defined_do(S),
		close(S), 
		!
	;
		close(S),
		fail
	).

is_post_process_pred_defined_do(S) :-
	read_mercury_term(S, Term),
	(
		term_string(Term, String),
		append_strings("post_process", _,  String)
	;
		Term = end_of_file,
		!,
		fail
	;
		is_post_process_pred_defined_do(S)
	).

% 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	: [File, FileSo],
	arg_type_list	: [is_string, is_string],
	abbrev		: _,
	implementation	: dyn_link_collect_Op,
	message		:
"Dynamically links the collect module with the current execution."
	).

dyn_link_collect_Op(File, FileSo) :-
	check_a_program_is_running("dyn_link_collect/2"),
	(
		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("\"./collect.so\"")),
	read_message_from_socket(Result),
	( Result = response_link_collect_succeeded ->
		morphine_write_debug("collect.so has been linked successfully.\n")
	;
		% if the Mercury program has been compiled in another grade, the 
		% linking will fail here. So if it fails, we recompile the collect
		% module and try again.
	        touch(File),   % to make sure it really recompiles it
		print("Because the dynamic linking failed for some reasons, "),
		print("we recompile the collect module and retry.\n"),
		generate_collect(File),
		compile_collect,
		concat_string(["cp collect.so ", FileSo], Cmd3),
		sh(Cmd3),
		send_message_to_socket(link_collect("\"./collect.so\"")),
		read_message_from_socket(Result2),
		( Result2 = response_link_collect_succeeded ->
			morphine_write_debug("collect.so has been linked "),
			morphine_write_debug("successfully this time.\n")
		;
			print("**** collect.so has not been linked.\n"),
			abort
		)
	).

touch(File) :-
	append_strings("touch ", File, Cmd),
	morphine_write_debug(Cmd),
	sh(Cmd).


%------------------------------------------------------------------------------%
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 execution."
	).

run_collect_Op(Result) :-
	check_a_program_is_running("run_collect/1"),
	( 
		collect_arg(yes),
		send_message_to_socket(collect_arg_on),
		read_message_from_socket(response_collect_arg_on_ok),
		!
	;
		collect_arg(no),
		send_message_to_socket(collect_arg_off),
		read_message_from_socket(response_collect_arg_off_ok),
		!
	;
		print("Error in run_collect_Op.\n"),
		abort
	),
	send_message_to_socket(collect),
	read_message_from_socket(CollectLinked),
	( 
		CollectLinked == response_collect_linked,
		read_message_from_socket(Msg),
		( 
			Msg = response_collected(Result),
			read_message_from_socket(IsExecutionContinuing),
			(
				IsExecutionContinuing = execution_continuing,
				!
			;
				IsExecutionContinuing =  execution_terminated,
				end_connection
			),
			!
		;
			print("unexpected message from the Mercury "),
			printf("process: %w\n", [Result]),
			end_connection,
			abort
		),
		!
	;
		CollectLinked == response_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/2').\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_morphine, State),
		State = running,
		!
	;
		printf("You can't call %w; no program is running.\n", 
			[CommandStr]),
		fail
	).