Files
mercury/compiler/prog_io_util.m
Zoltan Somogyi b56885be93 Fix a bug that caused bootchecks with --optimize-constructor-last-call to fail.
Estimated hours taken: 12
Branches: main

Fix a bug that caused bootchecks with --optimize-constructor-last-call to fail.

The problem was not in lco.m, but in follow_code.m. In some cases,
(specifically, the LCMC version of insert_2 in sparse_bitset.m),
follow_code.m moved an impure goal (store_at_ref) into the arms of an
if-then-else without marking those arms, or the if-then-else, as impure.
The next pass, simplify, then deleted the entire if-then-else, since it
had no outputs. (The store_at_ref that originally appeared after the
if-then-else was the only consumer of its only output.)

The fix is to get follow_code.m to make branched control structures such as
if-then-elses, as well as their arms, semipure or impure if a goal being moved
into them is semipure or impure, or if they came from an semipure or impure
conjunction.

Improve the optimization of the LCMC version of sparse_bitset.insert_2, which
had a foreign_proc invocation of bits_per_int in it: replace such invocations
with a unification of the bits_per_int constant if not cross compiling.

Add a new option, --optimize-constructor-last-call-null. When set, LCMC will
assign NULLs to the fields not yet filled in, to avoid any junk happens to be
there from being followed by the garbage collector's mark phase.

This diff also makes several other changes that helped me to track down
the bug above.

compiler/follow_code.m:
	Make the fix described above.

	Delete all the provisions for --prev-code; it won't be implemented.

	Don't export a predicate that is not now used anywhere else.

compiler/simplify.m:
	Make the optimization described above.

compiler/lco.m:
	Make sure that the LCMC specialized procedure is a predicate, not a
	function: having a function with the mode LCMC_insert_2(in, in) = in
	looks wrong.

	To avoid name collisions when a function and a predicate with the same
	name and arity have LCMC applied to them, include the predicate vs
	function status of the original procedure included in the name of the
	new procedure.

	Update the sym_name of calls to LCMC variants, not just the pred_id,
	because without that, the HLDS dump looks misleading.

compiler/pred_table.m:
	Don't have optimizations like LCMC insert new predicates at the front
	of the list of predicates. Maintain the list of predicates in the
	module as a two part list, to allow efficient addition of new pred_ids
	at the (logical) end without using O(N^2) algorithms. Having predicates
	in chronological order makes it easier to look at HLDS dumps and
	.c files.

compiler/hlds_module.m:
	Make module_info_predids return a module_info that is physically
	updated though logically unchanged.

compiler/options.m:
	Add --optimize-constructor-last-call-null.

	Make the options --dump-hlds-pred-id, --debug-opt-pred-id and
	--debug-opt-pred-name into accumulating options, to allow the user
	to specify more than one predicate to be dumped (e.g. insert_2 and
	its LCMC variant).

	Delete --prev-code.

doc/user_guide.texi:
	Document the changes in options.m.

compiler/code_info.m:
	Record the value of --optimize-constructor-last-call-null in the
	code_info, to avoid lookup at every cell construction.

compiler/unify_gen.m:
compiler/var_locn.m:
	When deciding whether a cell can be static or not, make sure that
	we never make static a cell that has some fields initialized with
	dummy zeros, to be filled in for real later.

compiler/hlds_out.m:
	For goals that are semipure or impure, note this fact. This info was
	lost when I changed the representation of impurity from markers to a
	field.

mdbcomp/prim_data.m:
	Rename some ambiguous function symbols.

compiler/intermod.m:
compiler/trans_opt.m:
	Rename the main predicates (and some function symbols) of these modules
	to avoid ambiguity and to make them more expressive.

compiler/llds.m:
	Don't print line numbers for foreign_code fragments if the user has
	specified --no-line-numbers.

compiler/make.dependencies.m:
compiler/mercury_to_mercury.m:
compiler/recompilation.usage.m:
	Don't use io.write to write out information to files we may need to
	parse again, because this is vulnerable to changes to the names of
	function symbols (e.g. the one to mdbcomp/prim_data.m).

	The compiler still contains some uses of io.write, but they are
	for debugging. I added an item to the todo list of the one exception,
	ilasm.m.

compiler/recompilation.m:
	Rename a misleading function symbol name.

compiler/parse_tree.m:
	Don't import recompilation.m here. It is not needed (all the components
	of parse_tree that need recompilation.m already import it themselves),
	and deleting the import avoids recompiling almost everything when
	recompilation.m changes.

compiler/*.m:
	Conform to the changes above.

compiler/*.m:
browser/*.m:
slice/*.m:
	Conform to the change to mdbcomp.

library/sparse_bitset.m:
	Use some better variable names.
2007-01-19 07:05:06 +00:00

879 lines
32 KiB
Mathematica

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 1996-2007 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: prog_io_util.m.
% Main author: fjh.
%
% This module defines the types used by prog_io and its subcontractors
% to return the results of parsing, and some utility predicates needed
% by several of prog_io's submodules.
%
% Most parsing predicates must check for errors. They return either the
% item(s) they were looking for, or an error indication.
%
% Most of the parsing predicates return a `maybe1(T)' or a `maybe2(T1, T2)',
% which will either be the `ok(ParseTree)' (or `ok(ParseTree1, ParseTree2)'),
% if the parse is successful, or `error(Message, Term)' if it is not.
% The `Term' there should be the term which is syntactically incorrect.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module parse_tree.prog_io_util.
:- interface.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_item.
:- import_module assoc_list.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module term.
%-----------------------------------------------------------------------------%
:- type maybe1(T1) == maybe1(T1, generic).
:- type maybe1(T1, U)
---> error1(assoc_list(string, term(U)))
; ok1(T1).
:- type maybe2(T1, T2) == maybe2(T1, T2, generic).
:- type maybe2(T1, T2, U)
---> error2(assoc_list(string, term(U)))
; ok2(T1, T2).
:- type maybe3(T1, T2, T3) == maybe3(T1, T2, T3, generic).
:- type maybe3(T1, T2, T3, U)
---> error3(assoc_list(string, term(U)))
; ok3(T1, T2, T3).
:- type maybe4(T1, T2, T3, T4) == maybe4(T1, T2, T3, T4, generic).
:- type maybe4(T1, T2, T3, T4, U)
---> error4(assoc_list(string, term(U)))
; ok4(T1, T2, T3, T4).
:- func get_any_errors1(maybe1(T1, U)) = assoc_list(string, term(U)).
:- func get_any_errors2(maybe2(T1, T2, U)) = assoc_list(string, term(U)).
:- func get_any_errors3(maybe3(T1, T2, T3, U)) = assoc_list(string, term(U)).
:- func get_any_errors4(maybe4(T1, T2, T3, T4, U))
= assoc_list(string, term(U)).
:- type maybe_functor == maybe_functor(generic).
:- type maybe_functor(T) == maybe2(sym_name, list(term(T))).
% ok(SymName, Args - MaybeFuncRetArg) ; error(Msg, Term).
:- type maybe_pred_or_func(T) == maybe2(sym_name, pair(list(T), maybe(T))).
:- type maybe_item_and_context == maybe2(item, prog_context).
:- type var2tvar == map(var, tvar).
:- type var2pvar == map(var, prog_var).
:- type parser(T) == pred(term, maybe1(T)).
:- mode parser == (pred(in, out) is det).
:- pred add_context(maybe1(item)::in, prog_context::in,
maybe_item_and_context::out) is det.
% Various predicates to parse small bits of syntax.
% These predicates simply fail if they encounter a syntax error.
:- pred parse_list_of_vars(term(T)::in, list(var(T))::out) is semidet.
% Parse a list of quantified variables.
%
:- pred parse_vars(term(T)::in, maybe1(list(var(T)), T)::out) is det.
% Parse a list of quantified variables, splitting it into
% ordinary logic variables and state variables respectively.
%
:- pred parse_quantifier_vars(term(T)::in,
maybe2(list(var(T)), list(var(T)), T)::out) is det.
% parse_vars_and_state_vars(Term, OrdinaryVars, DotStateVars,
% ColonStateVars):
%
% Similar to parse_vars, but also allow state variables to appear
% in the list. The outputs separate the parsed variables into ordinary
% variables, state variables listed as !.X, and state variables
% listed as !:X.
%
:- pred parse_vars_and_state_vars(term(T)::in,
maybe3(list(var(T)), list(var(T)), list(var(T)), T)::out) is det.
:- pred parse_name_and_arity(module_name::in, term(_T)::in,
sym_name::out, arity::out) is semidet.
:- pred parse_name_and_arity(term(_T)::in, sym_name::out, arity::out)
is semidet.
:- pred parse_pred_or_func_name_and_arity(module_name::in,
term(_T)::in, pred_or_func::out, sym_name::out, arity::out) is semidet.
:- pred parse_pred_or_func_name_and_arity(term(_T)::in, pred_or_func::out,
sym_name::out, arity::out) is semidet.
:- pred parse_pred_or_func_and_args(maybe(module_name)::in, term(_T)::in,
term(_T)::in, string::in, maybe_pred_or_func(term(_T))::out) is det.
:- pred parse_pred_or_func_and_args(term(_T)::in, pred_or_func::out,
sym_name::out, list(term(_T))::out) is semidet.
:- pred parse_type(term::in, maybe1(mer_type)::out) is det.
:- pred parse_types(list(term)::in, maybe1(list(mer_type))::out) is det.
:- pred unparse_type(mer_type::in, term::out) is det.
:- pred parse_purity_annotation(term(T)::in, purity::out, term(T)::out) is det.
:- type allow_constrained_inst_var
---> allow_constrained_inst_var
; no_allow_constrained_inst_var.
:- pred convert_mode_list(allow_constrained_inst_var::in, list(term)::in,
list(mer_mode)::out) is semidet.
:- pred convert_mode(allow_constrained_inst_var::in, term::in, mer_mode::out)
is semidet.
:- pred convert_inst_list(allow_constrained_inst_var::in, list(term)::in,
list(mer_inst)::out) is semidet.
:- pred convert_inst(allow_constrained_inst_var::in, term::in, mer_inst::out)
is semidet.
:- pred standard_det(string::in, determinism::out) is semidet.
% Convert a "disjunction" (bunch of terms separated by ';'s) to a list.
%
:- pred disjunction_to_list(term(T)::in, list(term(T))::out) is det.
% Convert a "conjunction" (bunch of terms separated by ','s) to a list.
%
:- pred conjunction_to_list(term(T)::in, list(term(T))::out) is det.
% list_to_conjunction(Context, First, Rest, Term):
% Convert a list to a "conjunction" (bunch of terms separated by ','s).
%
:- pred list_to_conjunction(prog_context::in, term(T)::in, list(term(T))::in,
term(T)::out) is det.
% Convert a "sum" (bunch of terms separated by '+' operators) to a list.
%
:- pred sum_to_list(term(T)::in, list(term(T))::out) is det.
% Parse a comma-separated list (misleading described as a "conjunction")
% of things.
%
:- pred parse_list(parser(T)::parser, term::in, maybe1(list(T))::out) is det.
:- pred map_parser(parser(T)::parser, list(term)::in, maybe1(list(T))::out)
is det.
:- pred list_term_to_term_list(term::in, list(term)::out) is semidet.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module libs.compiler_util.
:- import_module parse_tree.prog_io.
:- import_module parse_tree.prog_out.
:- import_module parse_tree.prog_util.
:- import_module set.
:- import_module term.
%-----------------------------------------------------------------------------%
get_any_errors1(ok1(_)) = [].
get_any_errors1(error1(Errors)) = Errors.
get_any_errors2(ok2(_, _)) = [].
get_any_errors2(error2(Errors)) = Errors.
get_any_errors3(ok3(_, _, _)) = [].
get_any_errors3(error3(Errors)) = Errors.
get_any_errors4(ok4(_, _, _, _)) = [].
get_any_errors4(error4(Errors)) = Errors.
add_context(error1(Errs), _, error2(Errs)).
add_context(ok1(Item), Context, ok2(Item, Context)).
parse_name_and_arity(ModuleName, PredAndArityTerm, SymName, Arity) :-
PredAndArityTerm = term.functor(term.atom("/"),
[PredNameTerm, ArityTerm], _),
parse_implicitly_qualified_term(ModuleName,
PredNameTerm, PredNameTerm, "", ok2(SymName, [])),
ArityTerm = term.functor(term.integer(Arity), [], _).
parse_name_and_arity(PredAndArityTerm, SymName, Arity) :-
parse_name_and_arity(unqualified(""),
PredAndArityTerm, SymName, Arity).
parse_pred_or_func_name_and_arity(ModuleName, PorFPredAndArityTerm,
PredOrFunc, SymName, Arity) :-
PorFPredAndArityTerm = term.functor(term.atom(PredOrFuncStr), Args, _),
( PredOrFuncStr = "pred", PredOrFunc = pf_predicate
; PredOrFuncStr = "func", PredOrFunc = pf_function
),
Args = [Arg],
parse_name_and_arity(ModuleName, Arg, SymName, Arity).
parse_pred_or_func_name_and_arity(PorFPredAndArityTerm,
PredOrFunc, SymName, Arity) :-
parse_pred_or_func_name_and_arity(unqualified(""),
PorFPredAndArityTerm, PredOrFunc, SymName, Arity).
parse_pred_or_func_and_args(Term, PredOrFunc, SymName, ArgTerms) :-
parse_pred_or_func_and_args(no, Term, Term, "",
ok2(SymName, ArgTerms0 - MaybeRetTerm)),
(
MaybeRetTerm = yes(RetTerm),
PredOrFunc = pf_function,
list.append(ArgTerms0, [RetTerm], ArgTerms)
;
MaybeRetTerm = no,
PredOrFunc = pf_predicate,
ArgTerms = ArgTerms0
).
parse_pred_or_func_and_args(MaybeModuleName, PredAndArgsTerm, ErrorTerm,
Msg, PredAndArgsResult) :-
(
PredAndArgsTerm = term.functor(term.atom("="),
[FuncAndArgsTerm, FuncResultTerm], _)
->
FunctorTerm = FuncAndArgsTerm,
MaybeFuncResult = yes(FuncResultTerm)
;
FunctorTerm = PredAndArgsTerm,
MaybeFuncResult = no
),
(
MaybeModuleName = yes(ModuleName),
parse_implicitly_qualified_term(ModuleName, FunctorTerm,
ErrorTerm, Msg, Result)
;
MaybeModuleName = no,
parse_qualified_term(FunctorTerm, ErrorTerm, Msg, Result)
),
(
Result = ok2(SymName, Args),
PredAndArgsResult = ok2(SymName, Args - MaybeFuncResult)
;
Result = error2(Errors),
PredAndArgsResult = error2(Errors)
).
% XXX kind inference: We currently give all types kind `star'.
% This will be different when we have a kind system.
%
parse_type(Term, Result) :-
(
Term = term.variable(Var0, _)
->
term.coerce_var(Var0, Var),
Result = ok1(type_variable(Var, kind_star))
;
parse_builtin_type(Term, BuiltinType)
->
Result = ok1(builtin_type(BuiltinType))
;
parse_higher_order_type(Term, HOArgs, MaybeRet, Purity, EvalMethod)
->
Result = ok1(higher_order_type(HOArgs, MaybeRet, Purity, EvalMethod))
;
Term = term.functor(term.atom("{}"), Args, _)
->
parse_types(Args, ArgsResult),
(
ArgsResult = ok1(ArgTypes),
Result = ok1(tuple_type(ArgTypes, kind_star))
;
ArgsResult = error1(Errors),
Result = error1(Errors)
)
;
% We don't support apply/N types yet, so we just detect them
% and report an error message.
Term = term.functor(term.atom(""), _, _)
->
Result = error1(["ill-formed type" - Term])
;
% We don't support kind annotations yet, and we don't report
% an error either. Perhaps we should?
parse_qualified_term(Term, Term, "type", NameResult),
(
NameResult = ok2(SymName, ArgTerms),
parse_types(ArgTerms, ArgsResult),
(
ArgsResult = ok1(ArgTypes),
Result = ok1(defined_type(SymName, ArgTypes, kind_star))
;
ArgsResult = error1(Errors),
Result = error1(Errors)
)
;
NameResult = error2(Errors),
Result = error1(Errors)
)
).
parse_types(Terms, Result) :-
parse_types_2(Terms, [], Result).
:- pred parse_types_2(list(term)::in, list(mer_type)::in,
maybe1(list(mer_type))::out) is det.
parse_types_2([], RevTypes, ok1(Types)) :-
list.reverse(RevTypes, Types).
parse_types_2([Term | Terms], RevTypes, Result) :-
parse_type(Term, Result0),
(
Result0 = ok1(Type),
parse_types_2(Terms, [Type | RevTypes], Result)
;
Result0 = error1(Errors),
Result = error1(Errors)
).
:- pred parse_builtin_type(term::in, builtin_type::out) is semidet.
parse_builtin_type(Term, BuiltinType) :-
Term = term.functor(term.atom(Name), [], _),
builtin_type_to_string(BuiltinType, Name).
% If there are any ill-formed types in the argument then we just fail.
% The predicate parse_type will then try to parse the term as an ordinary
% defined type and will produce the required error message.
%
:- pred parse_higher_order_type(term::in, list(mer_type)::out,
maybe(mer_type)::out, purity::out, lambda_eval_method::out) is semidet.
parse_higher_order_type(Term0, ArgTypes, MaybeRet, Purity, lambda_normal) :-
parse_purity_annotation(Term0, Purity, Term1),
( Term1 = term.functor(term.atom("="), [FuncAndArgs, Ret], _) ->
FuncAndArgs = term.functor(term.atom("func"), Args, _),
parse_type(Ret, ok1(RetType)),
MaybeRet = yes(RetType)
;
Term1 = term.functor(term.atom("pred"), Args, _),
MaybeRet = no
),
parse_types(Args, ok1(ArgTypes)).
parse_purity_annotation(Term0, Purity, Term) :-
(
Term0 = term.functor(term.atom(PurityName), [Term1], _),
purity_name(Purity0, PurityName)
->
Purity = Purity0,
Term = Term1
;
Purity = purity_pure,
Term = Term0
).
unparse_type(type_variable(TVar, _), term.variable(Var, context_init)) :-
Var = term.coerce_var(TVar).
unparse_type(defined_type(SymName, Args, _), Term) :-
unparse_type_list(Args, ArgTerms),
unparse_qualified_term(SymName, ArgTerms, Term).
unparse_type(builtin_type(BuiltinType), Term) :-
Context = term.context_init,
builtin_type_to_string(BuiltinType, Name),
Term = term.functor(term.atom(Name), [], Context).
unparse_type(higher_order_type(Args, MaybeRet, Purity, EvalMethod), Term) :-
Context = term.context_init,
unparse_type_list(Args, ArgTerms),
(
MaybeRet = yes(Ret),
Term0 = term.functor(term.atom("func"), ArgTerms, Context),
maybe_add_lambda_eval_method(EvalMethod, Term0, Term1),
unparse_type(Ret, RetTerm),
Term2 = term.functor(term.atom("="), [Term1, RetTerm], Context)
;
MaybeRet = no,
Term0 = term.functor(term.atom("pred"), ArgTerms, Context),
maybe_add_lambda_eval_method(EvalMethod, Term0, Term2)
),
maybe_add_purity_annotation(Purity, Term2, Term).
unparse_type(tuple_type(Args, _), Term) :-
Context = term.context_init,
unparse_type_list(Args, ArgTerms),
Term = term.functor(term.atom("{}"), ArgTerms, Context).
unparse_type(apply_n_type(TVar, Args, _), Term) :-
Context = term.context_init,
Var = term.coerce_var(TVar),
unparse_type_list(Args, ArgTerms),
Term = term.functor(term.atom(""), [term.variable(Var, Context) | ArgTerms],
Context).
unparse_type(kinded_type(_, _), _) :-
unexpected(this_file, "prog_io_util: kind annotation").
:- pred unparse_type_list(list(mer_type)::in, list(term)::out) is det.
unparse_type_list(Types, Terms) :-
list.map(unparse_type, Types, Terms).
:- pred unparse_qualified_term(sym_name::in, list(term)::in, term::out) is det.
unparse_qualified_term(unqualified(Name), Args, Term) :-
Context = term.context_init,
Term = term.functor(term.atom(Name), Args, Context).
unparse_qualified_term(qualified(Qualifier, Name), Args, Term) :-
Context = term.context_init,
unparse_qualified_term(Qualifier, [], QualTerm),
Term0 = term.functor(term.atom(Name), Args, Context),
Term = term.functor(term.atom("."), [QualTerm, Term0], Context).
:- pred maybe_add_lambda_eval_method(lambda_eval_method::in, term::in,
term::out) is det.
maybe_add_lambda_eval_method(lambda_normal, Term, Term).
:- pred maybe_add_purity_annotation(purity::in, term::in, term::out) is det.
maybe_add_purity_annotation(purity_pure, Term, Term).
maybe_add_purity_annotation(purity_semipure, Term0, Term) :-
Context = term.context_init,
Term = term.functor(term.atom("semipure"), [Term0], Context).
maybe_add_purity_annotation(purity_impure, Term0, Term) :-
Context = term.context_init,
Term = term.functor(term.atom("impure"), [Term0], Context).
convert_mode_list(_, [], []).
convert_mode_list(AllowConstrainedInstVar, [H0 | T0], [H | T]) :-
convert_mode(AllowConstrainedInstVar, H0, H),
convert_mode_list(AllowConstrainedInstVar, T0, T).
convert_mode(AllowConstrainedInstVar, Term, Mode) :-
(
Term = term.functor(term.atom(">>"), [InstA, InstB], _)
->
convert_inst(AllowConstrainedInstVar, InstA, ConvertedInstA),
convert_inst(AllowConstrainedInstVar, InstB, ConvertedInstB),
Mode = (ConvertedInstA -> ConvertedInstB)
;
% Handle higher-order predicate modes:
% a mode of the form
% pred(<Mode1>, <Mode2>, ...) is <Det>
% is an abbreviation for the inst mapping
% ( pred(<Mode1>, <Mode2>, ...) is <Det>
% -> pred(<Mode1>, <Mode2>, ...) is <Det>
% )
Term = term.functor(term.atom("is"), [PredTerm, DetTerm], _),
PredTerm = term.functor(term.atom("pred"), ArgModesTerms, _)
->
DetTerm = term.functor(term.atom(DetString), [], _),
standard_det(DetString, Detism),
convert_mode_list(AllowConstrainedInstVar, ArgModesTerms, ArgModes),
PredInstInfo = pred_inst_info(pf_predicate, ArgModes, Detism),
Inst = ground(shared, higher_order(PredInstInfo)),
Mode = (Inst -> Inst)
;
% Handle higher-order function modes:
% a mode of the form
% func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
% is an abbreviation for the inst mapping
% ( func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
% -> func(<Mode1>, <Mode2>, ...) = <RetMode> is <Det>
% )
Term = term.functor(term.atom("is"), [EqTerm, DetTerm], _),
EqTerm = term.functor(term.atom("="), [FuncTerm, RetModeTerm], _),
FuncTerm = term.functor(term.atom("func"), ArgModesTerms, _)
->
DetTerm = term.functor(term.atom(DetString), [], _),
standard_det(DetString, Detism),
convert_mode_list(AllowConstrainedInstVar, ArgModesTerms, ArgModes0),
convert_mode(AllowConstrainedInstVar, RetModeTerm, RetMode),
list.append(ArgModes0, [RetMode], ArgModes),
FuncInstInfo = pred_inst_info(pf_function, ArgModes, Detism),
Inst = ground(shared, higher_order(FuncInstInfo)),
Mode = (Inst -> Inst)
;
parse_qualified_term(Term, Term, "mode definition", R),
R = ok2(Name, Args), % should improve error reporting
convert_inst_list(AllowConstrainedInstVar, Args, ConvertedArgs),
Mode = user_defined_mode(Name, ConvertedArgs)
).
convert_inst_list(_, [], []).
convert_inst_list(AllowConstrainedInstVar, [H0 | T0], [H | T]) :-
convert_inst(AllowConstrainedInstVar, H0, H),
convert_inst_list(AllowConstrainedInstVar, T0, T).
convert_inst(_, term.variable(V0, _), inst_var(V)) :-
term.coerce_var(V0, V).
convert_inst(AllowConstrainedInstVar, Term, Result) :-
Term = term.functor(term.atom(Name), Args0, _Context),
(
convert_simple_builtin_inst(Name, Args0, Result0)
->
Result = Result0
;
% The syntax for a higher-order pred inst is
%
% pred(<Mode1>, <Mode2>, ...) is <Detism>
%
% where <Mode1>, <Mode2>, ... are a list of modes,
% and <Detism> is a determinism.
Name = "is", Args0 = [PredTerm, DetTerm],
PredTerm = term.functor(term.atom("pred"), ArgModesTerm, _)
->
DetTerm = term.functor(term.atom(DetString), [], _),
standard_det(DetString, Detism),
convert_mode_list(AllowConstrainedInstVar, ArgModesTerm, ArgModes),
PredInst = pred_inst_info(pf_predicate, ArgModes, Detism),
Result = ground(shared, higher_order(PredInst))
;
% The syntax for a higher-order func inst is
%
% func(<Mode1>, <Mode2>, ...) = <RetMode> is <Detism>
%
% where <Mode1>, <Mode2>, ... are a list of modes,
% <RetMode> is a mode, and <Detism> is a determinism.
Name = "is", Args0 = [EqTerm, DetTerm],
EqTerm = term.functor(term.atom("="), [FuncTerm, RetModeTerm], _),
FuncTerm = term.functor(term.atom("func"), ArgModesTerm, _)
->
DetTerm = term.functor(term.atom(DetString), [], _),
standard_det(DetString, Detism),
convert_mode_list(AllowConstrainedInstVar, ArgModesTerm, ArgModes0),
convert_mode(AllowConstrainedInstVar, RetModeTerm, RetMode),
list.append(ArgModes0, [RetMode], ArgModes),
FuncInst = pred_inst_info(pf_function, ArgModes, Detism),
Result = ground(shared, higher_order(FuncInst))
; Name = "bound", Args0 = [Disj] ->
% `bound' insts
parse_bound_inst_list(AllowConstrainedInstVar, Disj, shared, Result)
; Name = "bound_unique", Args0 = [Disj] ->
% `bound_unique' is for backwards compatibility - use `unique' instead.
parse_bound_inst_list(AllowConstrainedInstVar, Disj, unique, Result)
; Name = "unique", Args0 = [Disj] ->
parse_bound_inst_list(AllowConstrainedInstVar, Disj, unique, Result)
; Name = "mostly_unique", Args0 = [Disj] ->
parse_bound_inst_list(AllowConstrainedInstVar, Disj, mostly_unique,
Result)
; Name = "=<", Args0 = [VarTerm, InstTerm] ->
AllowConstrainedInstVar = allow_constrained_inst_var,
VarTerm = term.variable(Var, _),
% Do not allow nested constrained_inst_vars.
convert_inst(no_allow_constrained_inst_var, InstTerm, Inst),
Result = constrained_inst_vars(set.make_singleton_set(
term.coerce_var(Var)), Inst)
;
% Anything else must be a user-defined inst.
parse_qualified_term(Term, Term, "inst", ok2(QualifiedName, Args1)),
(
BuiltinModule = mercury_public_builtin_module,
sym_name_get_module_name(QualifiedName, unqualified(""),
BuiltinModule),
% If the term is qualified with the `builtin' module
% then it may be one of the simple builtin insts.
% We call convert_inst recursively to check for this.
UnqualifiedName = unqualify_name(QualifiedName),
convert_simple_builtin_inst(UnqualifiedName, Args1, Result0),
% However, if the inst is a user_inst defined inside
% the `builtin' module then we need to make sure it is
% properly module-qualified.
Result0 \= defined_inst(user_inst(_, _))
->
Result = Result0
;
convert_inst_list(AllowConstrainedInstVar, Args1, Args),
Result = defined_inst(user_inst(QualifiedName, Args))
)
).
% A "simple" builtin inst is one that has no arguments and no special
% syntax.
%
:- pred convert_simple_builtin_inst(string::in, list(term)::in, mer_inst::out)
is semidet.
convert_simple_builtin_inst(Name, [], Inst) :-
convert_simple_builtin_inst_2(Name, Inst).
:- pred convert_simple_builtin_inst_2(string::in, mer_inst::out) is semidet.
% `free' insts
convert_simple_builtin_inst_2("free", free).
% `any' insts
convert_simple_builtin_inst_2("any", any(shared)).
convert_simple_builtin_inst_2("unique_any", any(unique)).
convert_simple_builtin_inst_2("mostly_unique_any", any(mostly_unique)).
convert_simple_builtin_inst_2("clobbered_any", any(clobbered)).
convert_simple_builtin_inst_2("mostly_clobbered_any", any(mostly_clobbered)).
% `ground' insts
convert_simple_builtin_inst_2("ground", ground(shared, none)).
convert_simple_builtin_inst_2("unique", ground(unique, none)).
convert_simple_builtin_inst_2("mostly_unique", ground(mostly_unique, none)).
convert_simple_builtin_inst_2("clobbered", ground(clobbered, none)).
convert_simple_builtin_inst_2("mostly_clobbered",
ground(mostly_clobbered, none)).
% `not_reached' inst
convert_simple_builtin_inst_2("not_reached", not_reached).
standard_det("det", detism_det).
standard_det("cc_nondet", detism_cc_non).
standard_det("cc_multi", detism_cc_multi).
standard_det("nondet", detism_non).
standard_det("multi", detism_multi).
standard_det("multidet", detism_multi).
standard_det("semidet", detism_semi).
standard_det("erroneous", detism_erroneous).
standard_det("failure", detism_failure).
:- pred parse_bound_inst_list(allow_constrained_inst_var::in, term::in,
uniqueness::in, mer_inst::out) is semidet.
parse_bound_inst_list(AllowConstrainedInstVar, Disj, Uniqueness,
bound(Uniqueness, Functors)) :-
disjunction_to_list(Disj, List),
convert_bound_inst_list(AllowConstrainedInstVar, List, Functors0),
list.sort(Functors0, Functors),
% Check that the list doesn't specify the same functor twice.
\+ (
list.append(_, SubList, Functors),
SubList = [F1, F2 | _],
F1 = bound_functor(ConsId, _),
F2 = bound_functor(ConsId, _)
).
:- pred convert_bound_inst_list(allow_constrained_inst_var::in, list(term)::in,
list(bound_inst)::out) is semidet.
convert_bound_inst_list(_, [], []).
convert_bound_inst_list(AllowConstrainedInstVar, [H0 | T0], [H | T]) :-
convert_bound_inst(AllowConstrainedInstVar, H0, H),
convert_bound_inst_list(AllowConstrainedInstVar, T0, T).
:- pred convert_bound_inst(allow_constrained_inst_var::in, term::in,
bound_inst::out) is semidet.
convert_bound_inst(AllowConstrainedInstVar, InstTerm,
bound_functor(ConsId, Args)) :-
InstTerm = term.functor(Functor, Args0, _),
( Functor = term.atom(_) ->
parse_qualified_term(InstTerm, InstTerm, "inst", ok2(SymName, Args1)),
list.length(Args1, Arity),
ConsId = cons(SymName, Arity)
;
Args1 = Args0,
list.length(Args1, Arity),
ConsId = make_functor_cons_id(Functor, Arity)
),
convert_inst_list(AllowConstrainedInstVar, Args1, Args).
disjunction_to_list(Term, List) :-
binop_term_to_list(";", Term, List).
conjunction_to_list(Term, List) :-
binop_term_to_list(",", Term, List).
list_to_conjunction(_, Term, [], Term).
list_to_conjunction(Context, First, [Second | Rest], Term) :-
list_to_conjunction(Context, Second, Rest, Tail),
Term = term.functor(term.atom(","), [First, Tail], Context).
sum_to_list(Term, List) :-
binop_term_to_list("+", Term, List).
% General predicate to convert terms separated by any specified operator
% into a list.
%
:- pred binop_term_to_list(string::in, term(T)::in, list(term(T))::out) is det.
binop_term_to_list(Op, Term, List) :-
binop_term_to_list_2(Op, Term, [], List).
:- pred binop_term_to_list_2(string::in, term(T)::in, list(term(T))::in,
list(term(T))::out) is det.
binop_term_to_list_2(Op, Term, !List) :-
( Term = term.functor(term.atom(Op), [L, R], _Context) ->
binop_term_to_list_2(Op, R, !List),
binop_term_to_list_2(Op, L, !List)
;
!:List = [Term | !.List]
).
parse_list(Parser, Term, Result) :-
conjunction_to_list(Term, List),
map_parser(Parser, List, Result).
map_parser(_, [], ok1([])).
map_parser(Parser, [X | Xs], Result) :-
call(Parser, X, X_Result),
map_parser(Parser, Xs, Xs_Result),
combine_list_results(X_Result, Xs_Result, Result).
% If a list of things contains multiple errors, then we only
% report the first one.
%
:- pred combine_list_results(maybe1(T)::in, maybe1(list(T))::in,
maybe1(list(T))::out) is det.
combine_list_results(error1(ErrorsA), error1(ErrorsB),
error1(ErrorsA ++ ErrorsB)).
combine_list_results(error1(Errors), ok1(_), error1(Errors)).
combine_list_results(ok1(_), error1(Errors), error1(Errors)).
combine_list_results(ok1(X), ok1(Xs), ok1([X | Xs])).
%-----------------------------------------------------------------------------%
parse_list_of_vars(term.functor(term.atom("[]"), [], _), []).
parse_list_of_vars(term.functor(term.atom("[|]"), [Head, Tail], _),
[V | Vs]) :-
Head = term.variable(V, _),
parse_list_of_vars(Tail, Vs).
parse_vars(Term, MaybeVars) :-
( Term = functor(atom("[]"), [], _) ->
MaybeVars = ok1([])
; Term = functor(atom("[|]"), [Head, Tail], _) ->
( Head = variable(V, _) ->
parse_vars(Tail, MaybeVarsTail),
(
MaybeVarsTail = ok1(TailVars),
Vars = [V] ++ TailVars,
MaybeVars = ok1(Vars)
;
MaybeVarsTail = error1(_),
MaybeVars = MaybeVarsTail
)
;
Msg = "expected variable",
MaybeVars = error1([Msg - Head])
)
;
Msg = "expected list of variables",
MaybeVars = error1([Msg - Term])
).
parse_quantifier_vars(Term, MaybeQVars) :-
( Term = functor(atom("[]"), [], _) ->
MaybeQVars = ok2([], [])
; Term = functor(atom("[|]"), [Head, Tail], _) ->
(
(
Head = functor(atom("!"), [variable(SV, _)], _),
HeadVars = [],
HeadStateVars = [SV]
;
Head = variable(V, _),
HeadVars = [V],
HeadStateVars = []
)
->
parse_quantifier_vars(Tail, MaybeQVarsTail),
(
MaybeQVarsTail = ok2(TailVars, TailStateVars),
Vars = HeadVars ++ TailVars,
StateVars = HeadStateVars ++ TailStateVars,
MaybeQVars = ok2(Vars, StateVars)
;
MaybeQVarsTail = error2(_),
MaybeQVars = MaybeQVarsTail
)
;
Msg = "expected variable or state variable",
MaybeQVars = error2([Msg - Head])
)
;
Msg = "expected list of variables and/or state variables",
MaybeQVars = error2([Msg - Term])
).
parse_vars_and_state_vars(Term, MaybeVars) :-
( Term = functor(atom("[]"), [], _) ->
MaybeVars = ok3([], [], [])
; Term = functor(atom("[|]"), [Head, Tail], _) ->
(
(
Head = functor(atom("!"), [variable(SV, _)], _),
HeadVars = [],
HeadDotVars = [SV],
HeadColonVars = [SV]
;
Head = functor(atom("!."), [variable(SV, _)], _),
HeadVars = [],
HeadDotVars = [SV],
HeadColonVars = []
;
Head = functor(atom("!:"), [variable(SV, _)], _),
HeadVars = [],
HeadDotVars = [],
HeadColonVars = [SV]
;
Head = variable(V, _),
HeadVars = [V],
HeadDotVars = [],
HeadColonVars = []
)
->
parse_vars_and_state_vars(Tail, MaybeVarsTail),
(
MaybeVarsTail = ok3(TailVars, TailDotVars, TailColonVars),
Vars = HeadVars ++ TailVars,
DotVars = HeadDotVars ++ TailDotVars,
ColonVars = HeadColonVars ++ TailColonVars,
MaybeVars = ok3(Vars, DotVars, ColonVars)
;
MaybeVarsTail = error3(_),
MaybeVars = MaybeVarsTail
)
;
Msg = "expected variable or state variable",
MaybeVars = error3([Msg - Head])
)
;
Msg = "expected list of variables and/or state variables",
MaybeVars = error3([Msg - Term])
).
%-----------------------------------------------------------------------------%
list_term_to_term_list(Methods, MethodList) :-
(
Methods = term.functor(term.atom("[|]"), [Head, Tail0], _),
list_term_to_term_list(Tail0, Tail),
MethodList = [Head|Tail]
;
Methods = term.functor(term.atom("[]"), [], _),
MethodList = []
).
%-----------------------------------------------------------------------------%
:- func this_file = string.
this_file = "prog_io_util.m".
%-----------------------------------------------------------------------------%
:- end_module parse_tree.prog_io_util.
%-----------------------------------------------------------------------------%