mercury/extras/morphine/source/current_slots.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 <jahier@irisa.fr>
%
% This file implements all the predicates that deal with non-argument 
% attributes retrieval.


% The same declaration has been done in forward_move.op
:- op(900, xfy, and).

%------------------------------------------------------------------------------%
opium_command(
	name		: current,
	arg_list	: [AttributesConjunctOrList],
	arg_type_list	: [is_list_or_conj_of_attributes_current],
	abbrev		: curr,
	interface	: button,
	command_type	: opium,
	implementation	: current_Op,
	parameters	: [],
	message		:
"Gets or checks the values of the event attributes specified in \
`AttributesConjunctOrList'. `AttributesConjunctOrList' is a conjunction or a list \
of terms of the form `attribute = Value'. \n\
If `Value' is a free variable, it is unified with the current value of the \
attribute. If `Value' is a ground term, the current value of the attribute \
is retrieved and checked against `Value'.\n\
\n\
The different attributes of `current/1' are:  \n\
 \n\
chrono: \n\
    chronological event number of the event, \n\
call: \n\
    call event number of the event, \n\
depth: \n\
    depth in the proof tree (number of ancestors - 1) of the event, \n\
port: \n\
    type of the event, \n\
proc_type: \n\
    tells if the current procedure is a predicate or a function, \n\
decl_module: \n\
    module name where the procedure is declared, \n\
def_module: \n\
    module name where the procedure is defined, \n\
name: \n\
    procedure name, \n\
arity: \n\
    procedure arity, \n\
mode_number: \n\
    procedure mode number, \n\
proc: \n\
    procedure ([proc_type->][decl_module:](name[/arity][-mode_number]) where \
only the attribute name is mandatory), \n\
det: \n\
    procedure determinism, \n\
goal_path: \n\
    goal path of the call of the procedure, \n\
line_number: \n\
    line number of the call of the procedure, \n\
args: \n\
    list of procedure arguments (*), \n\
arg_names: \n\
    list of procedure argument names, \n\
arg_types: \n\
    list of procedure argument types, \n\
vars: \n\
    list of the currently live variables, \n\
var_names_and_types: \n\
    list of the currently live variable names and types, \n\
local_vars: \n\
    list of the currently non-argument local live variables. \n\
stack: \n\
    list of the stack element. \n\
\n\
For example, \
current(chrono = Chrono and name = Name)  (or current([chrono = Chrono, \
name = Name])) will unify Chrono with the chronological \
event number and Name with the procedure name of the current event. \
current(depth = 3) will succeed if and only if the depth of the current \
event is 3. \
current(args = [Arg1, -, -]) will unify Arg1 with the first argument of the \
current procedure if is live. \n\
 \n\
(*) Non lived arguments are unified with `-'. Moreover, if you do not want \
to retrieve all the arguments (because one of them is very big for example), \
you can use the atom `-': for example, `current(arg = [X, -, -])' only \
retrieves the first argument. Note that `current(arg = [X, _, _])' produces the \
same result, except arguments are effectively retrieved, which can take \
some times."
	).

current_Op(ListOrConj) :-
	getval(state_of_morphine, running),
	(
		is_list(ListOrConj),
		current_list(ListOrConj),
		!
	;
		conj_to_list(ListOrConj, List),
		current_list(List)
	),
	!.

current_list([H|T]) :-
	% We retrieve attributes one by one which is quite ineffective only if we 
	% have a lot of attributes to retrieve. In that case, it is better to 
	% use current_attributes/13.
	current_one(H),
	current_list(T),
	!.
current_list([]).


%------------------------------------------------------------------------------%
opium_primitive(
	name		: current_attributes,
	arg_list	: [Chrono, Call, Depth, Port, PredOrFunc, DeclModule, 
				DefModule, Name, Arity, ModeNumber, Det, 
				GoalPath, LineNumber],
	arg_type_list	: [is_integer_or_var, is_integer_or_var,
				is_integer_or_var, is_port_or_var, 
				is_atom_or_var, is_atom_or_var, 
				is_atom_or_var, is_atom_or_var,
				is_integer_or_var, is_integer_or_var,
				is_det_marker_or_var, is_goal_path_or_var ,
				is_integer_or_var],
	abbrev		: _,
	implementation	: current_attributes_Op,
	message		:
"Retrieves all the event attributes except the argument attributes."
	).

% :- pred current_attributes(atom, ..., atom).
% :- mode current_attributes(?, ..., ?) is nondet.
	% Determinism is coded by an integer so we need to wrap the
	% the call of current_attributes with determinism conversion.
current_attributes_Op(Chrono, Call, Depth, Port, PredOrFunc, DeclModule, 
		DefModule, Name, Arity, ModeNumber, Det, GoalPath, 
		LineNumber) :-
    		
	send_message_to_socket(current_slots),
	read_message_from_socket(Response),
	(
		Response = response_current_slots_comp(RetrievedChrono, RetrievedCall, 
				RetrievedDepth, RetrievedPort,
				RetrievedTypeNameStr, RetrievedTypeModuleStr,
				RetrievedDefModuleStr, RetrievedNameStr, 
				RetrievedArity, RetrievedModeNumber, 
				RetrievedDeterminism, RetrievedGoalPath,
				RetrievedLineNumber)
	->
		write("The current event is compiler generated event, "),
		write("they are not handled yet in Morphine.\n"),
		fail
		% XXX 
		% Anyway, this should never arrive here as long as we 
		% do not send any forward_move_comp requests.
	;
		Response = response_current_slots_user(RetrievedChrono, RetrievedCall, 
				RetrievedDepth, RetrievedPort,
				RetrievedPredOrFunc, RetrievedDeclModuleStr,
				RetrievedDefModuleStr, RetrievedNameStr, 
				RetrievedArity, RetrievedModeNumber, 
				RetrievedDeterminism, RetrievedGoalPath,
				RetrievedLineNumber)
	->
		% for 'decl_module', 'def_module' and 'name' attributes, 
		% Mercury sends string whereas we prefer to manipulate 
		% Prolog atoms; so we convert them.
		atom_string(RetrievedDeclModule, 
			RetrievedDeclModuleStr),
		atom_string(RetrievedDefModule, RetrievedDefModuleStr),
		atom_string(RetrievedName, RetrievedNameStr),
		
		% for 'det' attributes, Mercury process sends an integer that
		% codes the determinism. 
		( not(Det == '-') ->
			convert_integer_determinism_exact(
				RetrievedDeterminism, UncodedDet)
		;
			% No use to pay the cost of the conversion if it
			% needed
			true
		),

		% for 'port' attribute, the name the Mercury process sends is 
		% not the ones we use at the Morphine side.
		( not(Port == '-') ->
			convert_mercury_port_morphine_port_exact(
				RetrievedPort, MorphinePort)
		;
			true
		),

		% for 'goal_path' attribute, Mercury sends a string whereas 
		% we want a list.
		( not(GoalPath == '-') ->
			convert_goal_path_string_to_list(RetrievedGoalPath, 
			GoalPathList)
		;
			true
		),

		% For each argument of current_attributes, if it is
		%	* '-', we do nothing.
		%	* a variable, it is unified with the retrieved value.
		%	* an instantiated term, we check if the retrieved value 
		%	  is the same.
		unify_attribute(RetrievedChrono, Chrono),
		unify_attribute(RetrievedCall, Call),
		unify_attribute(RetrievedDepth, Depth),
		unify_attribute(MorphinePort, Port),
		unify_attribute(RetrievedPredOrFunc, PredOrFunc),
		unify_attribute(RetrievedDeclModule, DeclModule),
		unify_attribute(RetrievedDefModule, DefModule),
		unify_attribute(RetrievedName, Name),
		unify_attribute(RetrievedArity, Arity),
		unify_attribute(RetrievedModeNumber, ModeNumber),
		unify_attribute(UncodedDet, Det),
		unify_attribute(GoalPathList, GoalPath),
		unify_attribute(RetrievedLineNumber, LineNumber)
	;
	%	I should uncomment that when [EOT] is fix.
	%	Response = eot
	%->
	%	write(stderr, "eot: you can't retrieve any attributes"),
	%	fail
	%;
		Response = response_error(ErrorMessage)
	->
		write(stderr, "Error in current_attributes/13 (current_slots.op)\n"),
		write(stderr, "   An error occured in the Mercury process: "),
		write(stderr, ErrorMessage),
		morphine_abort
	 ;
		write(stderr, "Error in current_attributes/13 (current_slots.op)\n"),
		write(stderr, "The Mercury process sends: "),
		write(Response),
		write(stderr, "\n"),
		morphine_abort
	).


% :- pred unify_attribute(atom, atom).
% :- mode unify_attribute(in, out) is det.
% :- mode unify_attribute(in, in) is semidet.
	% If Attribute is free, binds it with RetrievedAttribute.
	% If Attribute is '-', just succeeds.
	% If Attribute is bound and different from '-', check if Attribute and 
	% RetrievedAttribute unifies.
unify_attribute(RetrievedAttribute, Attribute) :-
	( 
		free(Attribute),
		Attribute = RetrievedAttribute,
		!
	; 
		Attribute = '-',
		!
	;
		Attribute = RetrievedAttribute
	).

		
%:- pred convert_goal_path_string_to_list(string, list(T)).
%:- mode convert_goal_path_string_to_list(in, out) is det.
convert_goal_path_string_to_list("", []) :- !.
convert_goal_path_string_to_list(String, [X|Xs]) :-
	find_next_point_dot(String, N),
	N1 is N - 1,
	substring(String, 1, N1, Str),
	append_strings(Str, ";", S1),
	append_strings(S1, NewString, String),
	atom_string(X, Str),
	convert_goal_path_string_to_list(NewString, Xs).

% find the position of the first point dot in the string String.
find_next_point_dot(String, Position) :-
	generate(Position),
	substring(String, Position, 1, ";"),
	!.

generate(N) :-
	generate(1, N).
generate(N, M) :-
	(
		M = N
	;
		T is N + 1,
		generate(T, M)
	).


%------------------------------------------------------------------------------%
current_one(Attribute = X) :-
	is_alias_for(stack, Attribute),
	stack1(X),
	!.

current_one(Attribute = X) :-
	is_alias_for(args, Attribute),
	current_arg(X),
	!.

current_one(Attribute = X) :-
	is_alias_for(arg_names, Attribute),
	current_arg_names(X),
	!.

current_one(Attribute = X) :-
	is_alias_for(arg_types, Attribute),
	current_arg_types(X),
	!.

current_one(Attribute = Z) :-
	is_alias_for(vars, Attribute),
	current_vars(X, Y),
	append(X, Y, Z),
	!.

current_one(Attribute = LVN) :-
	is_alias_for(var_names_and_types, Attribute),
	current_live_var_names_and_types(LVN),
	!.

current_one(Attribute = OtherVar) :-
	is_alias_for(local_vars, Attribute),
	current_vars(_, OtherVar),
	!.

current_one(Attribute = Chrono) :-
	is_alias_for(chrono, Attribute),
	current_attributes(Chrono, -, -, -, -, -, -, -, -, -, -, - , -),
	!.

current_one(Attribute = Call) :-
	is_alias_for(call, Attribute),
	current_attributes(-, Call, -, -, -, -, -, -, -, -, -, - , -),
	!.

current_one(Attribute = Depth) :-
	is_alias_for(depth, Attribute),
	current_attributes(-, -, Depth, -, -, -, -, -, -, -, -, - , -),
	!.

current_one(Attribute = Port) :-
	is_alias_for(port, Attribute),
	current_attributes(-, -, -, Port, -, -, -, -, -, -, -, - , -),
	!.

current_one(Attribute = PredOrFunc) :-
	is_alias_for(proc_type, Attribute),
	current_attributes(-, -, -, -, PredOrFunc, -, -, -, -, -, -, - 
		, -),
	!.

current_one(Attribute = DeclModule) :-
	is_alias_for(decl_module, Attribute),
	current_attributes(-, -, -, -, -, DeclModule, -, -, -, -, -, - 
		, -),
	!.

current_one(Attribute = DefModule) :-
	is_alias_for(def_module, Attribute),
	current_attributes(-, -, -, -, -, -, DefModule, -, -, -, -, - , -),
	!.

current_one(Attribute = Name) :-
	is_alias_for(name, Attribute),
	current_attributes(-, -, -, -, -, -, -, Name, -, -, -, - , -),
	!.

current_one(Attribute = Arity) :-
	is_alias_for(arity, Attribute),
	current_attributes(-, -, -, -, -, -, -, -, Arity, -, -, - , -),
	!.

current_one(Attribute = ModeNumber) :-
	is_alias_for(mode_number, Attribute),
	current_attributes(-, -, -, -, -, -, -, -, -, ModeNumber, -, - 
		, -),
	!.

current_one(Attribute = Proc) :-
	is_alias_for(proc, Attribute),
	(
		free(Proc),
		current_attributes(-,-,-,-, PT, M, -, N, A, MN,-,- , -),
		Proc =  (PT->(M:(N/A-MN))),
		!
	;
		Proc = N,
		is_atom_or_var(N),
		current_attributes(-,-,-,-, -, -, -, N, -, -,-,- , -),!
	;
		Proc = (PT->N),
		is_atom_or_var(N),
		is_atom_or_var(PT),
		current_attributes(-,-,-,-, PT, -, -, N, -, -,-,- , -),
		!
	;
		Proc = M:N,
		current_attributes(-,-,-,-, -, M, -, N, -, -,-,- , -),
		!
	;
		Proc = N/A,
		current_attributes(-,-,-,-, -, -, -, N, A,-,-,- , -),
		!
	;
		Proc = N-MN,
		is_atom_or_var(N),
		is_atom_or_var(MN),
		current_attributes(-,-,-,-, -, -, -, N,-, MN,-,- , -),
		!
	;
		Proc = (N/A-MN),
		is_atom_or_var(N),
		is_atom_or_var(A),
		is_atom_or_var(MN),
		current_attributes(-,-,-,-, -, -, -, N, A, MN,-,- , -),
		!
	;
		Proc = M:(N-MN),
		current_attributes(-,-,-,-, -, M, -, N, -, MN,-,- , -),
		!
	;
		Proc = M:(N/A),
		current_attributes(-,-,-,-, -, M, -, N, A, -,-,- , -),
		!
	;
		Proc = (PT->(N-MN)),
		current_attributes(-,-,-,-, PT, -, -, N, -, MN,-,- , -),
		!
	;
		Proc = (PT->(N/A)),
		current_attributes(-,-,-,-, PT, -, -, N, A, -,-,- , -),
		!
	;
		Proc = (PT->M:N),
		current_attributes(-,-,-,-, PT, M, -, N, -, -,-,- , -),
		!
	;
		Proc = M:(N/A-MN),
		current_attributes(-,-,-,-, -, M, -, N, A, MN,-,- , -),
		!
	;
		Proc = (PT->(N/A-MN)),
		current_attributes(-,-,-,-, PT, -, -, N, A, MN,-,- , -),
		!
	;
		Proc = (PT->M:(N-MN)),
		current_attributes(-,-,-,-, PT, M, -, N, -, MN,-,- , -),
		!
	;
		Proc = (PT->M:(N/A)),
		current_attributes(-,-,-,-, PT, M, -, N, A, -,-,- , -),
		!
	;
		Proc = (PT->M:(N/A-MN)),
		current_attributes(-,-,-,-, PT, M, -, N, A, MN,-,- , -)
	).


current_one(Attribute = Determinism) :-
	is_alias_for(det, Attribute),
	current_attributes(-, -, -, -, -, -, -, -, -, -, Determinism, - 
		, -),
	!.

current_one(Attribute = GoalPath) :-
	is_alias_for(goal_path, Attribute),
	current_attributes(-, -, -, -, -, -, -, -, -, -, -, GoalPath, -),
	!.


current_one(Attribute = LineNumber) :-
	is_alias_for(line_number, Attribute),
	current_attributes(-, -, -, -, -, -, -, -, -, -, -, -, LineNumber),
	!.

%------------------------------------------------------------------------------%
opium_type(
	name		: is_list_or_conj_of_attributes_current,
	implementation	: is_list_or_conj_of_attributes_current_Op,
	message		: 
"Succeeds for list or conjunctions of terms of the form: \
`Attribute = Term', where  `Attribute' is a Mercury event attribute (or an \
alias of it) and `Term' is a term, e.g., a variable or a possible \
value for the attribute.\n\
Example:\n\
`current(name = Name and decl_module = module1), current([port = call, name = \
Name])'.\
"
	).

is_list_or_conj_of_attributes_current_Op(ListOrConj) :-
	(
		is_list(ListOrConj),
		is_list_of_attributes(ListOrConj),
		!
	;
		is_conj_of_attributes(ListOrConj)
	).


is_list_of_attributes([]).
is_list_of_attributes([H | T]) :-
	H = (Alias = Term),
	is_alias_for(Attribute, Alias),
	is_a_current_attribute(Attribute, Term),
	is_list_of_attributes(T).


is_conj_of_attributes(Alias = Term) :-
	is_alias_for(Attribute, Alias),
	is_a_current_attribute(Attribute, Term).
is_conj_of_attributes(Alias = Term and Tail) :-
	is_alias_for(Attribute, Alias),
	is_a_current_attribute(Attribute, Term),
	is_conj_of_attributes(Tail).
	

is_a_current_attribute(Attribute, Term) :-
	(
		member(Attribute, [chrono, call, depth, arity, mode_number]),
		is_integer_or_var(Term),
		!
	;
		member(Attribute, [decl_module, def_module, name, proc_type]),
		is_atom_or_var(Term),
		!
	;
		Attribute = proc,
		is_proc_or_var(Term),
		!
	;
		Attribute = goal_path,
		is_goal_path_or_var(Term),
		!
	;
		Attribute = line_number,
		is_integer_or_var(Term),
		!
	;
		Attribute = port,
		is_port_or_var(Term),
		!
	;
		member(Attribute, [args, arg_names, arg_types]),
		is_list_or_var(Term),
		!
	;
		Attribute = det,
		is_det_marker_or_var(Term),
		!
	;
		member(Attribute, [vars, var_names_and_types, local_vars]),
		is_term(Term),
		!
	;
		Attribute = stack,
		is_list_or_var(Term)
	).

%------------------------------------------------------------------------------%
% opium_command(
% 	name		: stack,
% 	arg_list	: [List],
% 	arg_type_list	: [is_list_or_var],
% 	abbrev		: _,
% 	interface	: button,
% 	command_type	: opium,
% 	implementation	: stack_Op,
% 	parameters	: [],
% 	message		:
% "Retrieves the ancestors stack of the call specified by the current \
% event. This command will report an error message if there is no stack trace \
% information available about any ancestor. \
% "
% 	).

stack1(Stack) :-
	stack_ll_Op(Stackll),
	stack_hl(Stackll, [], [], Stack).

stack_hl([], _, Stack, Stack).
stack_hl([level(N)|Tail], Level, Stack0, Stack) :-
	append([[level(N)|Level]], Stack0, Stack1),
	stack_hl(Tail, [],  Stack1, Stack).

stack_hl([X|Tail], Level, Stack0, Stack) :-
	stack_hl(Tail, [X|Level], Stack0, Stack).

stack_ll_Op(StackList) :-
	getval(state_of_morphine, running),
	send_message_to_socket(stack),
	read_message_until_end_stack([], StackList),
 	read_message_from_socket(Message), 
	( 
		Message = response_ok,
		!
	; 
		Message = response_error(ErrorMessage),
		printf(trace, "\nUnable to retrieve all the ancestors; %w.\n", 
			ErrorMessage)
	),
	!.

stack_ll_Op(_) :-
	write("You can't get any stack ; no program is running.\n"),
	fail.

read_message_until_end_stack(ListIn, ListOut) :-
	read_message_from_socket(Message),
	( Message = response_end_stack ->
		ListOut = ListIn
	;
		List = [Message|ListIn],
		read_message_until_end_stack(List, ListOut)
	).


%------------------------------------------------------------------------------%
opium_command(
	name		: stack,
	arg_list	: [],
	arg_type_list	: [],
	abbrev		: _,
	interface	: button,
	command_type	: opium,
	implementation	: stack_Op,
	parameters	: [],
	message		:
"Displays the ancestors stack."
	).

stack_Op :-
	stack_ll_Op(StackList),
	reverse(StackList, StackListRev),
	display_stack(StackListRev).

%------------------------------------------------------------------------------%
opium_primitive(
	name		:  nondet_stack,
	arg_list	: [],
	arg_type_list	: [],
	abbrev		: _,
	implementation	: nondet_stack_Op,
	message		:
"Prints the contents of the fixed attributes of the frames on the nondet \
stack. This command is intended to be of use only to developers \
of the Mercury implementation."
	).

nondet_stack_Op :-
	getval(state_of_morphine, running),
	send_message_to_socket(nondet_stack),
	read_message_from_socket(ok),
	!.

nondet_stack_Op :-
	write("You can't get the nondet stack ; no program is running.\n"),
	fail.

%------------------------------------------------------------------------------%
opium_primitive(
	name		:  stack_regs,
	arg_list	: [],
	arg_type_list	: [],
	abbrev		: _,
	implementation	: stack_regs_Op,
	message		:
"Prints the contents of the virtual machine registers that point to the det \
and nondet stacks. This command is intended to be of use only to developers \
of the Mercury implementation."
	).

stack_regs_Op :-
	getval(state_of_morphine, running),
	send_message_to_socket(stack_regs),
	read_message_from_socket(Message),
	Message = response_stack_regs(SP, CURFR, MAXFR),
	printf(trace, "\nsp = %p, curfr = %p, maxfr = %p\n", 
		[SP, CURFR, MAXFR]),
	!.

stack_regs_Op :-
	write("You can't get the registers stack ; no program is running.\n"),
	fail.