mercury/compiler/ml_util.m

%-----------------------------------------------------------------------------%
% Copyright (C) 1999-2001 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%

% File: ml_util.m
% Main author: fjh, trd

% This module contains utility predicates for manipulating the MLDS.

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

:- module ml_util.
:- interface.

:- import_module mlds.
:- import_module list, std_util.
:- import_module prog_data.  % for foreign_language

%-----------------------------------------------------------------------------%
	% succeeds iff the definitions contain the entry point to
	% the a main predicate.
	%
:- pred defns_contain_main(mlds__defns).
:- mode defns_contain_main(in) is semidet.

%-----------------------------------------------------------------------------%
	% return `true' if the statement is a tail call which
	% can be optimized into a jump back to the start of the
	% function
:- pred can_optimize_tailcall(mlds__qualified_entity_name, mlds__stmt).
:- mode can_optimize_tailcall(in, in) is semidet.

%-----------------------------------------------------------------------------%
%
% routines that deal with statements
%

	% nondeterministically generates sub-statements from statements.
:- pred statements_contains_statement(mlds__statements, mlds__statement).
:- mode statements_contains_statement(in, out) is nondet.

:- pred statement_contains_statement(mlds__statement, mlds__statement).
:- mode statement_contains_statement(in, out) is multi.

:- pred stmt_contains_statement(mlds__stmt, mlds__statement).
:- mode stmt_contains_statement(in, out) is nondet.

:- pred has_foreign_languages(mlds__statement, list(foreign_language)).
:- mode has_foreign_languages(in, out) is det.

%-----------------------------------------------------------------------------%
%
% routines that deal with definitions
%

	% defn_contains_foreign_code(NativeTargetLang, Defn):
	%	Succeeds iff this definition contains outline_foreign_proc
	%	statements, or inline_target_code statements in a target
	%	language other than the specified native target language.
	%	XXX perhaps we should eliminate the need to check for
	%	inline_target_code, because it shouldn't be generated
	%	with target language different to the native target
	%	language in the long run.
:- pred defn_contains_foreign_code(target_lang, mlds__defn).
:- mode defn_contains_foreign_code(in, in) is semidet.

	% defn_contains_foreign_code(ForeignLang, Defn):
	%	Succeeds iff this definition contains outline_foreign_proc
	%	statements for the given foreign language.
:- pred defn_contains_outline_foreign_proc(foreign_language, mlds__defn).
:- mode defn_contains_outline_foreign_proc(in, in) is semidet.

	% Succeeds iff this definition is a type definition.
:- pred defn_is_type(mlds__defn).
:- mode defn_is_type(in) is semidet.

	% Succeeds iff this definition is a function definition.
:- pred defn_is_function(mlds__defn).
:- mode defn_is_function(in) is semidet.

	% Succeeds iff this definition is a data definition which
	% defines a type_ctor_info constant.
:- pred defn_is_type_ctor_info(mlds__defn).
:- mode defn_is_type_ctor_info(in) is semidet.

	% Succeeds iff this definition is a data definition which
	% defines a variable whose type is mlds__commit_type.
:- pred defn_is_commit_type_var(mlds__defn).
:- mode defn_is_commit_type_var(in) is semidet.

	% Succeeds iff this definition has `public' in the access
	% field in its decl_flags.
:- pred defn_is_public(mlds__defn).
:- mode defn_is_public(in) is semidet.

%-----------------------------------------------------------------------------%
%
% routines that deal with lvals/rvals
%

	%
	% initializer_contains_var:
	% rvals_contains_var:
	% maybe_rval_contains_var:
	% rval_contains_var:
	% lvals_contains_var:
	% lval_contains_var:
	%	Succeeds iff the specified construct contains a reference to
	%	the specified variable.
	%

:- pred initializer_contains_var(mlds__initializer, mlds__var).
:- mode initializer_contains_var(in, in) is semidet.

:- pred rvals_contains_var(list(mlds__rval), mlds__var).
:- mode rvals_contains_var(in, in) is semidet.

:- pred maybe_rval_contains_var(maybe(mlds__rval), mlds__var).
:- mode maybe_rval_contains_var(in, in) is semidet.

:- pred rval_contains_var(mlds__rval, mlds__var).
:- mode rval_contains_var(in, in) is semidet.

:- pred lvals_contains_var(list(mlds__lval), mlds__var).
:- mode lvals_contains_var(in, in) is semidet.

:- pred lval_contains_var(mlds__lval, mlds__var).
:- mode lval_contains_var(in, in) is semidet.

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

:- implementation.

:- import_module rtti.
:- import_module bool, list, std_util, prog_data.

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

defns_contain_main(Defns) :-
	list__member(Defn, Defns),
	Defn = mlds__defn(Name, _, _, _),
	Name = function(FuncName, _, _, _), 
	FuncName = pred(predicate, _, "main", 2, _, _).

can_optimize_tailcall(Name, Call) :-
	Call = call(_Signature, FuncRval, MaybeObject, _CallArgs,
		_Results, IsTailCall),
	%
	% check if this call can be optimized as a tail call
	%
	IsTailCall = tail_call,

	%
	% check if the callee adddress is the same as
	% the caller
	%
	FuncRval = const(code_addr_const(CodeAddr)),
	(	
		CodeAddr = proc(QualifiedProcLabel, _Sig),
		MaybeSeqNum = no
	;
		CodeAddr = internal(QualifiedProcLabel, SeqNum, _Sig),
		MaybeSeqNum = yes(SeqNum)
	),
	QualifiedProcLabel = qual(ModuleName, PredLabel - ProcId),
	% check that the module name matches
	Name = qual(ModuleName, FuncName),
	% check that the PredLabel, ProcId, and MaybeSeqNum match
	FuncName = function(PredLabel, ProcId, MaybeSeqNum, _),

	%
	% In C++, `this' is a constant, so our usual technique
	% of assigning the arguments won't work if it is a
	% member function.  Thus we don't do this optimization
	% if we're optimizing a member function call
	%
	MaybeObject = no.

%-----------------------------------------------------------------------------%
%
% routines that deal with statements
%

statements_contains_statement(Statements, SubStatement) :-
	list__member(Statement, Statements),
	statement_contains_statement(Statement, SubStatement).

:- pred maybe_statement_contains_statement(maybe(mlds__statement),
		mlds__statement).
:- mode maybe_statement_contains_statement(in, out) is nondet.

maybe_statement_contains_statement(no, _Statement) :- fail.
maybe_statement_contains_statement(yes(Statement), SubStatement) :-
	statement_contains_statement(Statement, SubStatement).


statement_contains_statement(Statement, Statement).
statement_contains_statement(Statement, SubStatement) :-
	Statement = mlds__statement(Stmt, _Context),
	stmt_contains_statement(Stmt, SubStatement).


stmt_contains_statement(Stmt, SubStatement) :-
	(
		Stmt = block(_Defns, Statements),
		statements_contains_statement(Statements, SubStatement)
	;
		Stmt = while(_Rval, Statement, _Once),
		statement_contains_statement(Statement, SubStatement)
	;
		Stmt = if_then_else(_Cond, Then, MaybeElse),
		( statement_contains_statement(Then, SubStatement)
		; maybe_statement_contains_statement(MaybeElse, SubStatement)
		)
	;
		Stmt = switch(_Type, _Val, _Range, Cases, Default),
		( cases_contains_statement(Cases, SubStatement)
		; default_contains_statement(Default, SubStatement)
		)
	;
		Stmt = label(_Label),
		fail
	;
		Stmt = goto(_),
		fail
	;
		Stmt = computed_goto(_Rval, _Labels),
		fail
	;
		Stmt = call(_Sig, _Func, _Obj, _Args, _RetLvals, _TailCall),
		fail
	;
		Stmt = return(_Rvals),
		fail
	;
		Stmt = do_commit(_Ref),
		fail
	;
		Stmt = try_commit(_Ref, Statement, Handler),
		( statement_contains_statement(Statement, SubStatement)
		; statement_contains_statement(Handler, SubStatement)
		)
	;
		Stmt = atomic(_AtomicStmt),
		fail
	).

:- pred cases_contains_statement(list(mlds__switch_case), mlds__statement).
:- mode cases_contains_statement(in, out) is nondet.

cases_contains_statement(Cases, SubStatement) :-
	list__member(Case, Cases),
	Case = _MatchCond - Statement,
	statement_contains_statement(Statement, SubStatement).

:- pred default_contains_statement(mlds__switch_default, mlds__statement).
:- mode default_contains_statement(in, out) is nondet.

default_contains_statement(default_do_nothing, _) :- fail.
default_contains_statement(default_is_unreachable, _) :- fail.
default_contains_statement(default_case(Statement), SubStatement) :-
	statement_contains_statement(Statement, SubStatement).

has_foreign_languages(Statement, Langs) :-
	GetTargetCode = (pred(Lang::out) is nondet :-
		statement_contains_statement(Statement, SubStatement),
		SubStatement = statement(atomic(
		  	outline_foreign_proc(Lang, _, _)), _) 
		),
	solutions(GetTargetCode, Langs).

%-----------------------------------------------------------------------------%
%
% routines that deal with definitions
%

defn_contains_foreign_code(NativeTargetLang, Defn) :-
	Defn = mlds__defn(_Name, _Context, _Flags, Body),
	Body = function(_, _, defined_here(FunctionBody), _),
	statement_contains_statement(FunctionBody, Statement),
	Statement = mlds__statement(Stmt, _),
	( 
		Stmt = atomic(inline_target_code(TargetLang, _)),
		TargetLang \= NativeTargetLang
	; 
		Stmt = atomic(outline_foreign_proc(_, _, _))
	).

defn_contains_outline_foreign_proc(ForeignLang, Defn) :-
	Defn = mlds__defn(_Name, _Context, _Flags, Body),
	Body = function(_, _, defined_here(FunctionBody), _),
	statement_contains_statement(FunctionBody, Statement),
	Statement = mlds__statement(Stmt, _),
	Stmt = atomic(outline_foreign_proc(ForeignLang, _, _)).

defn_is_type(Defn) :-
	Defn = mlds__defn(Name, _Context, _Flags, _Body),
	Name = type(_, _).

defn_is_function(Defn) :-
	Defn = mlds__defn(Name, _Context, _Flags, _Body),
	Name = function(_, _, _, _).

defn_is_type_ctor_info(Defn) :-
	Defn = mlds__defn(_Name, _Context, _Flags, Body),
	Body = mlds__data(Type, _),
	Type = mlds__rtti_type(RttiName),
	RttiName = type_ctor_info.

defn_is_commit_type_var(Defn) :-
	Defn = mlds__defn(_Name, _Context, _Flags, Body),
	Body = mlds__data(Type, _),
	Type = mlds__commit_type.

defn_is_public(Defn) :-
	Defn = mlds__defn(_Name, _Context, Flags, _Body),
	access(Flags) = public.

%-----------------------------------------------------------------------------%
%
% routines that deal with lvals/rvals
%

%
% initializer_contains_var:
% rvals_contains_var:
% maybe_rval_contains_var:
% rval_contains_var:
% lvals_contains_var:
% lval_contains_var:
%	Succeeds iff the specified construct contains a reference to
%	the specified variable.
%

% initializer_contains_var(no_initializer, _) :- fail.
initializer_contains_var(init_obj(Rval), Name) :-
	rval_contains_var(Rval, Name).
initializer_contains_var(init_struct(Inits), Name) :-
	list__member(Init, Inits),
	initializer_contains_var(Init, Name).
initializer_contains_var(init_array(Inits), Name) :-
	list__member(Init, Inits),
	initializer_contains_var(Init, Name).

rvals_contains_var(Rvals, Name) :-
	list__member(Rval, Rvals),
	rval_contains_var(Rval, Name).

% maybe_rval_contains_var(no, _Name) :- fail.
maybe_rval_contains_var(yes(Rval), Name) :-
	rval_contains_var(Rval, Name).

rval_contains_var(lval(Lval), Name) :-
	lval_contains_var(Lval, Name).
rval_contains_var(mkword(_Tag, Rval), Name) :-
	rval_contains_var(Rval, Name).
% rval_contains_var(const(_Const), _Name) :- fail.
rval_contains_var(unop(_Op, Rval), Name) :-
	rval_contains_var(Rval, Name).
rval_contains_var(binop(_Op, X, Y), Name) :-
	( rval_contains_var(X, Name)
	; rval_contains_var(Y, Name)
	).
rval_contains_var(mem_addr(Lval), Name) :-
	lval_contains_var(Lval, Name).

lvals_contains_var(Lvals, Name) :-
	list__member(Lval, Lvals),
	lval_contains_var(Lval, Name).

lval_contains_var(field(_MaybeTag, Rval, _FieldId, _, _), Name) :-
	rval_contains_var(Rval, Name).
lval_contains_var(mem_ref(Rval, _Type), Name) :-
	rval_contains_var(Rval, Name).
lval_contains_var(var(Name, _Type), Name).  /* this is where we can succeed! */

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